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