REBOL [
Title: "Submit to Script Library"
Date: 26-Mar-2002
Version: 1.0.5
File: %add-script-offline.r
Author: "Carl Sassenrath, Oldes"
Purpose: "Submits a script to the script library."
Comment: {Oldes: This script was already in the library but Carl replaced it again with it's older version (even older than the one I was using - 1.0.2). He probably doesn't like this modification, but I don't like messages as "You cannot do something, becasue...". Some people still have to use dialup connections and pay for every second! Why don't prepare the upload offline!
^-And another thing: people in Rebol probably don't think that on one script may work more people, because there is posibility to fill only one email (author) - that seems to be silly!
^-That reminds me, that some better library with access to older version would be useful.}
History: [
1.0.5 {Oldes: renamed from add-script to add-script-offline.r}
1.0.4 "Oldes: added offline possibility"
1.0.3 "Carl's latest version"
]
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
off-data-file: %add-script-data.rb ;Oldes: where to save offline data
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
]
init: does [
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]
]
];end of init
init
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 "If you are not connected to the Internet, the script will be uploaded later."]
offline-save str
clear-fields
][
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."]
]
clear-fields: func[][
hdr: make system/standard/script [Email: none Web: none Category: copy []]
init
view lo
]
offline-save: func[str /local off-data][
str: compress str
system/options/binary-base: 64
off-data: either exists? off-data-file [load off-data-file][make block! []]
file: either block? file [first file][file]
either found? f: find/tail off-data file [
poke off-data (index? f) str
][ repend off-data [file str]]
save off-data-file off-data
]
offline-send: func/local tmp msg off-data][
either exists? off-data-file [off-data: load off-data-file][return]
tmp: length? off-data
while [not tail? off-data] [
flash rejoin ["Uploading..." off-data/1]
either error? try [
msg: read/custom http://www.reboltech.com/cgi/rebol/post-script.r reduce ['post decompress off-data/2]
msg: trim/lines msg
][
off-data: skip off-data 2
][
either msg <> "ok" [alert reform ["Script" off-data/1 "rejected:" msg]][
alert "Your script has been posted to the library."
]
remove/part off-data 2 ;the script is removed even if it's rejected!!
]
unview
]
off-data: head off-data
if tmp <> length? off-data [save off-data-file off-data]
]
;if not connected? [alert "Must be connected to the Internet to add a script." quit]
;No, I want to prepare the upload offline!...
if connected? [offline-send]
;...and send them after connection:)
view lo