REBOL [ Title: "Submit to Script Library" Date: 22-May-2001 Version: 1.0.3 File: %add-script.r Author: "Carl Sassenrath" Purpose: "Submits a script to the script library.^/" Email: carl@rebol.com Category: [cgi util ldc 4] ] categories: [ "Email Related" email "Web Related" web "CGI Related" cgi "HTML/XML Related" markup "FTP Related" ftp "Network Related" net "TCP/Network Related" tcp "Distributed Computing" ldc "View Related" view "VID Visual Interface" vid "Scripting Style" script "Tutorial Scripts" tutor "File I/O Related" file "Text-Processing" text "Database Related" db "Encryption Related" crypt "External Library" lib "Shell Access" shell "Math Related" math "Utility Functions" util "General Example" misc "Game Related" game "Sound Related" sound "Compression Related" compress "[Very Simple]" 1 "[Beginner Level]" 2 "[Moderate Level]" 3 "[Advanced Level]" 4 "[Guru Level]" 5 ] sort/skip categories 2 field-types: [ f-title title [string!] f-author author [string!] f-date date [date!] f-vers version [tuple!] f-file file [file!] f-purpose purpose [string!] f-email email [email!] f-web web [url!] ] tell: func [str] [stat/text: str show stat] set-field: func [face 'fld /local val typ] [ types: select field-types fld foreach type types [ if find [string! file!] type [ set in hdr fld to get type face/text check-all exit ] if not error? try [val: load face/text][ if type = type?/word val [ set in hdr fld val check-all exit ] ] ] set in hdr fld none tell reform [fld "must be of" types "format"] err-label face true ] cats: [] cnt: 0 lo: center-face layout [ style label label 80x24 right style field field 300 space 4x8 across label "Script:" button 300 "Open and Examine File" [ file: request-file/keep if all [file file/1] [certify first file] ] return space 4x0 label "Title:" f-title: field [set-field face title] return label "Author:" f-author: field [set-field face author] return label "Date:" f-date: field [set-field face date] return label "Version:" f-vers: field [set-field face version] return label "File:" f-file: field [set-field face file] return label "Purpose:" f-purpose: field 300x74 wrap [set-field face purpose] return label "Optional Fields (Useful for feedback):" 340 left yellow return label "Email:" f-email: field [set-field face email] return label "Web URL:" f-web: field [set-field face web] return space 0 at f-title/offset + 310x0 guide sc: text bold white black 176 "Categories" return cl: list 160x174 [ space 0 text 160x16 font [colors: [0.0.0 130.130.130]] [alter cats word] ] supply [ count: count + cnt face/text: face/color: none if count * 2 > length? categories [return none] set [name word] at categories count * 2 - 1 face/text: name face/color: if find cats word [yellow] ] sl: slider cl/size * 0x1 + 16x0 [ c: to-integer value * ((length? categories) / 2 - 8) if cnt <> c [cnt: c show cl] ] return pad 0x20 stat: text 160x30 red black "error window" font-size 10 return button 80 "Submit" [submit-script] button 80 "Close" [quit] ] err-label: func [face state] [ face: first back find lo/pane face face/color: either state [180.0.0][none] show face ] check-type: func [face word types /local var] [ var: all [var: in hdr word get var] if all [any-string? var empty? var] [var: none] either all [var find types type?/word var] [ face/text: form var err-label face none ][ ;print word if negative? offset? find field-types 'email find field-types word [ if not stat/text [stat/text: reform [word "needs" types]] ] err-label face true ] ] check-all: does [ stat/text: none foreach [face fld type] field-types [check-type get face fld type] cats: hdr/category sc/color: black if all [not stat/text empty? cats][ sc/color: 180.0.0 stat/text: "select script categories" ] show lo not stat/text ] certify: func [file /local msg] [ msg: none either all [ ; verify the script and header msg: "File not found" exists? file msg: "REBOL header not found" script? file msg: "File cannot be loaded" not error? try [set [hdr src] load/header/next file] msg: "Invalid header block" hdr: make context [Email: none Web: none Category: copy []] hdr not error? try [hdr: make system/standard/script hdr] ][ if string? hdr/purpose [trim/auto hdr/purpose] if none? hdr/date [hdr/date: now] if none? hdr/author [hdr/author: user-prefs/name] if none? hdr/file [hdr/file: second split-path file] if none? hdr/version [hdr/version: 1.0.0] if none? hdr/email [hdr/email: system/user/email] check-all ][ alert join "Error: " msg ] ] out-head: has [val str] [ str: make string! 4096 repend str "REBOL [^/" foreach fld next first hdr [ val: get in hdr fld if val [ repend str [tab fld ": " detab mold val newline] ] ] repend str ["]" src] flash "Uploading..." msg: "Cannot access library server." either error? try [ parse str [any [thru "^J" (append str " ")]] ; Yuk. Accounts for bug in HTTP POST function. ;probe str msg: read/custom http://www.reboltech.com/cgi/rebol/post-script.r reduce ['post str] ;probe msg msg: trim/lines msg ][ unview alert reform ["Error on upload:" msg "Are you connected to the Internet?"] ][ unview either msg <> "ok" [alert join "Script rejected: " msg][ alert "Your script has been posted to the library." quit ] ] ] submit-script: does [ either check-all [out-head][alert "Cannot submit with missing or invalid fields."] ] if not connected? [alert "Must be connected to the Internet to add a script." quit] view lo