#!/usr/local/bin/rebol -c
REBOL [
Title: "QuarterMaster"
Author: "Christopher Ross-Gill"
Version: 0.3.8
Notes: {Warning: Work-In-Progress - no liabilities for damage, etc.}
License: http://creativecommons.org/licenses/by-sa/3.0/
]
config: construct [
public-key: "a key that will be visible - for cookie ids"
private-key: "a private key - for encrypting passwords"
session-timeout: 0:02:00
zone: -6:00
post-limit: 500 ;-- not active yet; can be altered per controller/action
default-controller: "blog"
spaces: [
;-- QM requires entries for "system" "data" "site" "support"
"system" %/Path/To/app/application/
"space" %/Path/To/app/space/
"site" %/Path/To/HTTPD/root/
"support" %/Path/To/support/
;-- Add more for your convenience
]
]
;--## APPLICATION BEYOND THIS POINT
;-------------------------------------------------------------------##
system/options/binary-base: 64
system/error/user/type: "QuarterMaster Error"
date: now - now/zone + config/zone
range!: :pair! ; until REBOL v3
else: #[true] ; for 'case statements
random/seed to-integer checksum/secure form now/precise ; any better?
if debug: found? find any [system/options/cgi/query-string ""] "debug" [
print "Content-Type: text/plain; charset=utf-8^/"
]
;--## APPLICATION NAMESPACE
;-------------------------------------------------------------------##
qm: context [
binding: 'self
controller: metadata: action: #[none]
models: request: response: #[none]
alerts: []
errors: []
notices: []
handler: %.rsp
view-path: #[none]
title: ""
code: []
]
;--## EXTENDED CORE FUNCTIONS
;-------------------------------------------------------------------##
context [
func: make function! [spec [block!] body [block!]][make function! spec body]
does: func [body [block!]][make function! [] body]
uses: func [proto [block!] spec [block!]][
proto: context proto
func [args [block! object!]] compose/only [
args: make (proto) args
do bind (spec) args
]
]
try-else: func [[throw] 'try-first [any-block!] on-fail [block!] /local reason][
either error? reason: try :try-first bind :on-fail 'reason [:reason]
]
assert-all: func [[throw] cases [block!] /local value][
until [
set [value cases] do/next cases
unless value cases/1
cases: next cases
any [not value tail? cases]
]
any [value]
]
; step-through: try-each: func ['steps [block!] else [block!] /local reason][
; foreach [block err-code] steps [
; either error? reason: try :block [do bind else 'reason return err-code][:reason]
; ]
; ]
fortype: func [[throw] type [datatype!] block [block!] f [any-function!] /local val][
parse block [some [to type set val type (f :val)]]
]
with: func [object [any-word! object! port!] block [any-block!] /only][
block: bind block object
either only [block] :block
]
envelope: func [val [any-type!]][either any-block? val [val][reduce [val]]]
raise: func [[catch] reason][throw make error! rejoin envelope reason]
export: func [words [word! block!] /to dest [object!] /local word][
dest: any [dest system/words]
fortype word! to-block words func [word] [
set/any in dest word get/any word
; protect in dest word
]
]
true?: func [test][either test [#[true]][#[false]]]
export [func does uses try-else assert-all fortype export envelope raise with true?]
]
;--## SERIES HELPERS
;-------------------------------------------------------------------##
context [
push: func [stack [series! port!] value [any-type!] /only][
head either only [insert/only stack :value][insert stack :value]
]
pop: take: func [series [series! port! none!] /last /part range [integer!] /local result][
range: any [range 1]
case [
none? series [return none]
last [series: skip tail series negate abs range]
]
either part [
result: copy/part series range
remove/part series range
][
result: pick series 1
remove series
]
result
]
pop*: func [stack [series! port!] /local val][
val: pick stack 1
remove stack
:val
]
flatten: func [block [any-block!] /once][
once: either once [
[(block: insert block pop block)]
][
[(insert block pop block)]
]
parse block [
any [block: any-block! (insert block pop block) :block | skip]
]
head block
]
map: func [series [any-block! port!] action [any-function!] /only /copy /local new][
if copy [series: system/words/copy/deep series]
while [not tail? series][
series: either only [
change/part/only series action series/1 1
][
change/part series action series/1 1
]
]
head series
]
map-each: func [[catch throw] 'word [word! block!] series [any-block!] body [block!] /copy /local new][
case/all [
word? word [word: envelope word]
not parse word [some word!][
raise "WORDS argument should be a word or block of words"
]
copy [series: system/words/copy/deep series]
]
use word compose/deep [
while [not tail? series][
set [(word)] series (body)
series: change/part series reduce [(word)] (length? word)
]
]
head series
]
get-choice: func [word [string! word!] words [any-block!]][
all [
word: attempt [to-word word]
find words word
word
]
]
get-class: func [classes [block!] item /local type][
all [
type: type? classes/1
classes: find classes item
first find/reverse classes type
]
]
link-to: func ['path [any-block!] /local out][
out: copy %""
path: compose to-block path
foreach val path [
either issue? val [append out mold val][repend out ["/" form val]]
]
]
compose-path: func ['path [path! lit-path! word! lit-word!]][
to-path new-line/all compose to-block envelope path none
]
paginate: func [series [series! port!] page [integer! none!] /window padding /size length][
page: any [page 1]
length: any [length 15]
padding: any [padding 2]
context [
last: max 1 to-integer (length? series) - 1 / length + 1
current: max 1 min last page
next: either last > current [current + 1][false]
previous: either 1 < current [current - 1][false]
records: copy/part skip series offset: current - 1 * length length
upper: copy [] lower: copy []
repeat cnt padding [
insert lower current - cnt
append upper current + cnt
]
remove-each val lower [val <= 1]
remove-each val upper [val >= last]
start: current - 2 <= padding
end: last - current - 1 <= padding
]
]
prepare: use [rule flat nest val][
rule: [val: paren! (do val/1 remove val) :val | get-word! (change/part val get/any val/1 1)]
flat: [some [rule | skip]]
nest: [some [rule | into nest | skip]]
func [block [any-block!] /deep][
parse block: copy/deep block either deep [nest][flat]
block
]
]
export [push take pop flatten map map-each get-choice get-class compose-path prepare link-to paginate]
]
;--## KEY-VALUE HELPERS
;-------------------------------------------------------------------##
context [
add-to: func [ser key val][
key: envelope key
map key func [key][as word! key]
if find key none! [return none]
until [
ser: any [
find/tail ser key/1
insert tail ser key/1
]
key: next key
switch type?/word ser/1 [
none! [unless tail? key [insert/only ser ser: copy []]]
string! [change/only ser ser: envelope ser/1]
block! [ser: ser/1]
]
if tail? key [append ser val]
]
]
get-from: func [series 'key][
key: copy envelope key
while [all [not tail? key any-block? series]][
series: select series pop key
]
all [tail? key series]
]
export [add-to get-from]
]
;--## CHARACTER SETS
;-------------------------------------------------------------------##
context [
comment {
Will consider the possibility of using more bnf friendly words...
[
snip: difference charset [#"^(20)" - #"^(7F)"] charset [{:*.<>=} #"{" #"}"]
chars-n: charset [#"0" - #"9"] ; digit
chars-la: charset [#"a" - #"z"] ; lower-alpha
chars-ua: charset [#"A" - #"Z"] ; upper-alpha
chars-a: union chars-la chars-ua ; alpha
chars-an: union chars-a chars-n ; alphanumeric
chars-hx: union chars-n charset [#"A" - #"F" #"a" - #"f"] ; hexdig
chars-ud: union chars-an charset "*-._!~'," ; url decode
chars-u: union chars-ud charset ":+%&=?" ; url
chars-f: union chars-an charset "-_" ; file
chars-w1: union chars-a charset "*-._!+?&|"
chars-w*: union chars-w1 chars-n
chars-p: union chars-an charset "-_!+%" ; path
chars-sp: charset " ^-" ; space
chars-as: charset ["^/^-" #"^(20)" - #"^(7F)"] ; ascii
chars-up: charset [#"^(80)" - #"^(FF)"] ; above ascii
; chars-ht: exclude union chars-as chars-up charset {&<>"}
chars-ht: exclude chars-as charset {&<>"}
chars: complement nochar: charset " ^-^/"
]
}
chars-n: #[bitset! 64#{AAAAAAAA/wMAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA=}]
chars-la: #[bitset! 64#{AAAAAAAAAAAAAAAA/v//BwAAAAAAAAAAAAAAAAAAAAA=}]
chars-ua: #[bitset! 64#{AAAAAAAAAAD+//8HAAAAAAAAAAAAAAAAAAAAAAAAAAA=}]
chars-a: #[bitset! 64#{AAAAAAAAAAD+//8H/v//BwAAAAAAAAAAAAAAAAAAAAA=}]
chars-an: #[bitset! 64#{AAAAAAAA/wP+//8H/v//BwAAAAAAAAAAAAAAAAAAAAA=}]
chars-hx: #[bitset! 64#{AAAAAAAA/wN+AAAAfgAAAAAAAAAAAAAAAAAAAAAAAAA=}]
chars-ud: #[bitset! 64#{AAAAAIJ0/wP+//+H/v//RwAAAAAAAAAAAAAAAAAAAAA=}]
chars-u: #[bitset! 64#{AAAAAKJ8/wf+//+H/v//RwAAAAAAAAAAAAAAAAAAAAA=}]
chars-f: #[bitset! 64#{AAAAAAAg/wP+//+H/v//BwAAAAAAAAAAAAAAAAAAAAA=}]
chars-w1: #[bitset! 64#{AAAAAEJsAID+//+H/v//FwAAAAAAAAAAAAAAAAAAAAA=}]
chars-w*: #[bitset! 64#{AAAAAEJs/4P+//+H/v//FwAAAAAAAAAAAAAAAAAAAAA=}]
chars-p: #[bitset! 64#{AAAAAKJo/wP+//+H/v//BwAAAAAAAAAAAAAAAAAAAAA=}]
chars-sp: #[bitset! 64#{AAIAAAEAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA=}]
chars-as: #[bitset! 64#{AAYAAP///////////////wAAAAAAAAAAAAAAAAAAAAA=}]
chars-up: #[bitset! 64#{AAAAAAAAAAAAAAAAAAAAAP////////////////////8=}]
; chars-ht: #[bitset! 64#{AAYAALv//6////////////////////////////////8=}]
chars-ht: #[bitset! 64#{AAYAALv//6///////////wAAAAAAAAAAAAAAAAAAAAA=}]
chars: #[bitset! 64#{//n///7///////////////////////////////////8=}]
nochar: #[bitset! 64#{AAYAAAEAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA=}]
export [
chars-n chars-la chars-ua chars-a chars-an chars-hx
chars-w1 chars-w* chars-f chars-p chars-u chars-ud chars-sp
chars-up chars-as chars-ht chars nochar
]
]
;--## UTF-8
;-------------------------------------------------------------------##
context [
utf-2: #[bitset! 64#{AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA/////wAAAAA=}]
utf-3: #[bitset! 64#{AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAP//AAA=}]
utf-4: #[bitset! 64#{AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA/wA=}]
utf-5: #[bitset! 64#{AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA8=}]
utf-b: #[bitset! 64#{AAAAAAAAAAAAAAAAAAAAAP//////////AAAAAAAAAAA=}]
utf-8: [utf-2 1 utf-b | utf-3 2 utf-b | utf-4 3 utf-b | utf-5 4 utf-b]
utf-os: [0 192 224 240 248 252]
utf-fc: [1 64 4096 262144 16777216]
get-ucs-code: func [char /local int][
int: 0
char: change char char/1 xor pick utf-os length? char
forskip char 1 [change char char/1 xor 128]
char: head reverse head char
forskip char 1 [int: (to-integer char/1) * (pick utf-fc index? char) + int]
all [int > 127 int <= 65535 int]
]
export [utf-8 get-ucs-code]
]
;--## STRING HELPERS
;-------------------------------------------------------------------##
context [
pad: func [text length [integer!] /with padding [char!]][
padding: any [padding #"0"]
text: form text
skip tail insert/dup text padding length negate length
]
url-encode: func [text [any-string!]][
parse/all copy text [
copy text any [
some chars-ud |
#" " text: (change back text #"+") |
skip text: (change/part back text join "%" enbase/base to-string text/-1 16 1)
]
]
text
]
deplus: func [text][
parse/all text [some [to #"+" text: (text: change text #" ") :text] to end]
head text
]
decrlf: func [text][
parse/all text [some [to crlf text: (text: change/part text #"^/" 2) :text] to end]
head text
]
url-decode: func [text [any-string!]][decrlf dehex deplus to-string text]
decode-query: func [query [string! none!] /local store name value val-ptr mk][
query: any [query ""]
store: copy []
if query [
query: parse/all query "&"
map/only query func [value][parse/all value "="]
foreach value query [change/only value parse/all value/1 "."]
]
parse query [
any [
into [
set name block! set value opt string! (
add-to store name any [all [value url-decode value] ""]
)
]
]
]
return store
]
; doesn't work right, yet
decode-options: func [options [string! none!] type [datatype!]][
options: any [options ""]
options: parse lowercase options ";,"
map options func [val [string!] /local weight][
either parse/all val ["q=" weight: "0." integer!][
load weight
][
as :type val
]
]
]
compose-tags: func [body [string!] callback [any-function!] /local out tag block][
out: make string! length? body
while [tag: find body "=["][
insert/part tail out body offset? body tag
body: either error? err: try [
block: load/next tag: next tag
][
append out "**Tag Loading Error: #"
tag
][
append out any [callback first block ""]
second block
]
]
append out body
]
interpolate: func [body [string!] escapes [any-block!] /local out][
body: out: copy body
parse/all body [
any [
to #"%" body: (
body: change/part body reduce any [
select/case escapes body/2 body/2
] 2
) :body
]
]
out
]
replace: func [target [any-string!] search [char! any-string!] replace /all /case /local len rule][
len: either char? search [1][length? search]
rule: [any [to search target: (target: change/part target replace len) :target] to end]
rule/1: pick [opt any] none? all
do pick [parse parse/case] none? case target rule
head target
]
sanitize: func [text [any-string!] /local char][
parse/all copy text [
copy text any [
text: some chars-ht
| #"&" (text: change/part text "&" 1) :text
| #"<" (text: change/part text "<" 1) :text
| #">" (text: change/part text ">" 1) :text
| #"^"" (text: change/part text """ 1) :text
| #"^M" (remove text) :text
| copy char utf-8 (text: change/part text rejoin ["&#" get-ucs-code char ";"] length? char)
| skip (text: change/part text rejoin ["#(" to-integer text/1 ")"] 1) :text
; | skip (text: change text "#") :text
]
]
any [text ""]
]
; sanitize: func [text][
; replace/all text: copy text #"&" "&"
; replace/all text #"<" "<"
; replace/all text #">" ">"
; replace/all text #"^"" """
; ]
load-multipart: func [
[catch] data [binary!] boundary
/local store name content filetype filename
file-prototype qchars nchars dchars
][
store: copy []
file-prototype: context [name: data: type: meta: #[none]]
qchars: #[bitset! 64#{//////v///////////////////////////////////8=}]
nchars: #[bitset! 64#{//////////f///////////////////////////////8=}]
unless parse/all/case data [boundary data: to end][
raise "Postdata not Multipart"
]
boundary: join crlf boundary
unless parse/all/case data [
some [
"--" crlf end |
(name: content: filemime: filetype: filename: none)
crlf {Content-Disposition: form-data; name=}
[{"} copy name some qchars {"} | copy name some nchars]
(name: parse/all name ".")
opt [
{; filename=} [
[{"} copy filename any qchars {"} | copy filename any nchars]
crlf {Content-Type: } copy filetype to crlf
]
]
crlf crlf copy content to boundary boundary (
content: any [content ""]
either all [filetype filetype: as path! filetype][
filename: either filename [
as file! any [
find/last/tail filename #"/"
find/last/tail filename #"\"
find/last/tail filename #":"
filename
]
][%file.dat]
content: either filetype/1 = 'text [decrlf content][to-binary content]
add-to store name make file-prototype [
name: :filename type: :filetype data: :content
]
][
add-to store name to-string decrlf content
]
)
]
][
raise "Invalid Multipart Postdata"
]
store
]
export [
pad url-encode url-decode decode-query decode-options
load-multipart compose-tags interpolate replace sanitize
]
]
;--## PORT HELPERS
;-------------------------------------------------------------------##
context [
add-protocol: func ['name id handler /with block][
unless in system/schemes name [
system/schemes: make system/schemes compose [
(to-set-word name) #[none]
]
]
set in system/schemes name make system/standard/port compose [
scheme: name
port-id: (id)
handler: (handler)
passive: #[none]
cache-size: 5
proxy: make object! [host: port-id: user: pass: type: bypass: #[none]]
(block)
]
]
to-header: func [object [object!] /local header][
header: make string! (20 * length? first object)
foreach word next first object [
if get word: in object word [
insert tail header reduce [word ": " get word newline]
]
]
header
]
codes: [read 1 write 2 append 4 new 8 binary 32 lines 64 direct 524288]
get-port-flags: func [port words][
remove-each word copy words [
word: select codes word
word <> (port/state/flags and word)
]
]
chars: ; charset [#"a" - #"z" #"A" - #"Z" #"0" - #"9" "-_!+%"]
#[bitset! 64#{AAAAACIo/wP+//+H/v//BwAAAAAAAAAAAAAAAAAAAAA=}]
space!: context [
root: domain: path: target: folder: file: suffix: #[none]
]
get-space: func [base [url!] location [url!] /local space][
base: form base
space: make space! [uri: :location]
if all with/only space [
parse/all uri [
base
copy domain some chars #"/"
copy path any [some [some chars | #"."] #"/"]
copy target opt [any chars #"." 1 10 chars]
]
root: select config/spaces domain
] with/only space [
path: all [path to-file path]
target: all [target to-file target]
folder: join root any [path ""]
file: join folder any [target ""]
suffix: suffix? file
self
]
]
export [add-protocol to-header get-port-flags get-space]
]
;--## VALUES HELPERS
;-------------------------------------------------------------------##
context [
pad-zone: func [time /flat][
rejoin [
pick "-+" time/hour < 0
pad abs time/hour 2
either flat [""][#":"]
pad time/minute 2
]
]
get-iso-year: func [year [integer!] /local d1 d2][
d1: to-date join "4-1-" year
d2: to-date join "28-12-" year
return reduce [d1 + 1 - d1/weekday d2 + 7 - d2/weekday]
]
to-iso-week: func [date [date!] /local out d1 d2][
out: 0x0
set [d1 d2] get-iso-year out/y: date/year
case [
date < d1 [d1: first get-iso-year out/y: date/year - 1]
date > d2 [d1: first get-iso-year out/y: date/year + 1]
]
out/x: date + 8 - date/weekday - d1 / 7
out
]
date-codes: [
#"a" [copy/part pick system/locale/days date/weekday 3]
#"A" [pick system/locale/days date/weekday]
#"b" [copy/part pick system/locale/months date/month 3]
#"B" [pick system/locale/months date/month]
#"C" [to-integer date/year / 100]
#"d" [pad date/day 2]
#"D" [date/year #"/" pad date/month 2 #"/" pad date/day 2]
#"e" [date/day]
#"g" [pad (second to-iso-week date) // 100 2]
#"G" [second to-iso-week date]
#"h" [time/hour + 11 // 12 + 1]
#"H" [pad time/hour 2]
#"i" [any [get-class [st 1 21 31 nd 2 22 rd 3 23] date/day "th"]]
#"I" [pad time/hour + 11 // 12 + 1 2]
#"j" [pad date/julian 3]
#"J" [date/julian]
#"m" [pad date/month 2]
#"M" [pad time/minute 2]
#"p" [pick ["am" "pm"] time/hour < 12]
#"P" [pick ["AM" "PM"] time/hour < 12]
#"S" [pad round time/second 2]
#"t" [#"^-"]
#"T" [pad time/hour 2 #":" pad time/minute 2 #":" pad round time/second 2]
#"u" [date/weekday]
#"U" [pad to-integer date/julian + 6 - (date/weekday // 7) / 7 2]
#"V" [pad first to-iso-week date 2]
#"w" [date/weekday // 7]
#"W" [pad to-integer date/julian + 7 - date/weekday / 7 2]
#"y" [pad date/year // 100 2]
#"Y" [date/year]
#"z" [pad-zone/flat zone]
#"Z" [pad-zone zone]
]
form-date: func [date [date!] format [any-string!] /gmt /local time zone nyd][
all [
date/time date/zone
date/time: date/time - date/zone
date/time: date/time + date/zone: either gmt [0:00][config/zone]
]
time: any [date/time 0:00]
zone: any [date/zone config/zone 0:00]
interpolate format bind date-codes 'date
]
color-codes: [
#"r" [color/1] #"1" [to-char color/1]
#"g" [color/2] #"2" [to-char color/2]
#"b" [color/3] #"3" [to-char color/3]
#"a" [color/4] #"4" [to-char color/4]
#"R" [skip tail to-hex color/1 -2]
#"G" [skip tail to-hex color/2 -2]
#"B" [skip tail to-hex color/3 -2]
#"A" [skip tail to-hex color/4 -2]
]
form-color: func [color [tuple!] format [any-string!]][
bind color-codes 'color
color: 0.0.0.0 + color
interpolate format color-codes
]
pluralize: func [string [string!] count [number!]][
unless any [count = 1 count = -1][string: join string "s"]
reform [count string]
]
export [form-date to-local-time form-color pluralize]
]
;--## VALUES FILTER
;-------------------------------------------------------------------##
context [
id: [chars-la 0 15 chars-f]
word: [chars-w1 0 25 chars-w*]
number: [integer!]
integer: [opt #"-" number]
masks: reduce [
issue! [some chars-u]
logic! ["true" | "on" | "yes"]
word! [word]
url! [id #":" some [chars-u | #":" | #"/"]]
email! [some chars-u #"@" some chars-u]
path! [word 0 3 [#"/" [word | integer]]]
integer! [integer]
string! [some [some chars-as | utf-8]]
'positive [number]
'id [id]
'key [word 0 6 [#"." word]]
]
as: func [
[catch] type [datatype!] value [any-type!]
/where format [none! block! any-word!]
][
case/all [
none? format [
format: select masks type
if all [none? format type = type? value][
return value
]
]
any-word? format [format: select masks to-word format]
block? format [
unless parse/all form value format [return none]
]
type = path! [return load value]
]
attempt [make type value]
]
export [as]
]
;--## IMPORT
;-------------------------------------------------------------------##
context [
result: errors: #[none]
messages: [
not-included "is not included in the list"
excluded "is reserved"
invalid "is missing or invalid"
not-confirmed "doesn't match confirmation"
not-accepted "must be accepted"
empty "can't be empty"
blank "can't be blank"
too-long "is too long (maximum is %d characters)"
too-short "is too short (minimum is %d characters)"
wrong-length "is the wrong length (should be %d characters)"
not-a-number "is not a number"
too-many "has too many arguments"
]
datatype: [
'any-string! | 'binary! | 'block! | 'char! | 'date! | 'decimal! | 'email! | 'file! |
'get-word! | 'integer! | 'issue! | 'lit-path! | 'lit-word! | 'logic! | 'money! |
'none! | 'number! | 'pair! | 'paren! | 'path! | 'range! | 'refinement! |
'set-path! | 'set-word! | 'string! | 'tag! | 'time! | 'tuple! | 'url! | 'word!
]
else: #[none]
otherwise: [
['else | 'or][
set else string! | copy else any [word! string!]
] | (else: #[none])
]
source: key: value: target: type: format: constraints: else: none
constraint: use [is is-not? is-or-length-is op val val-type range group][
op: val: val-type: none
is: ['is | 'are]
is-or-length-is: [
[
['length | 'size] (val: length? value val-type: integer!)
| (val: :value val-type: :type)
] is
]
is-not?: ['not (op: false) | (op: true)]
[
is [
'accepted otherwise (
unless true = value [report not-accepted]
) |
'confirmed opt 'by set val get-word! otherwise (
val: to-word val
unless value = as/where :type get-from source :val format [
report not-confirmed
]
) |
is-not? 'within set group any-block! otherwise (
either found? find group value [
unless op [report excluded]
][
if op [report not-included]
]
)
] |
is-or-length-is [
is-not? 'between [set range [range! | into [2 val-type]]] otherwise (
either op [
case [
val < target: range/1 [report too-short]
val > target: range/2 [report too-long]
]
][
unless any [
val < range/1
val > range/2
][report excluded]
]
) |
'more-than set target val-type otherwise (
unless val > target [report too-short]
) |
'less-than set target val-type otherwise (
unless val < target [report too-long]
) |
set target val-type otherwise (
unless val = target [report wrong-length]
)
]
]
]
do-constraints: does [constraints: [any constraint]]
no-constraints: does [constraints: [to set-word! | to end]]
humanize: func [word][uppercase/part replace/all form word "-" " " 1]
report: func ['message [word!]][
message: any [
all [string? else else]
all [block? else select else message]
reform [humanize key any [select messages message ""]]
]
unless select errors :key [repend errors [:key copy []]]
append select errors :key interpolate message [
#"w" [form key]
#"W" [humanize key]
#"d" [form target]
#"t" [form type]
]
]
import: func [
[catch] source* [block! none!] spec [block!]
/report-to errs [block!]
/block /local required present
][
unless source* [return none]
errors: copy []
result: copy []
source: source* []
unless parse compose/deep/only spec [
any [
set key set-word! (key: to-word key)
set required opt 'opt (required: required <> 'opt)
set type datatype (type: get type)
set format opt [block! | get-word!]
otherwise
(
value: either block [
pick source 1
][
get-from source :key
]
present: not any [
none? value
empty? trim/head/tail form value
]
either all [present value: as/where :type value format][
if block [source: next source]
do-constraints
repend result [key value]
][
no-constraints
case [
all [present not block] [report invalid]
required [report blank]
not required [repend result [key none]]
]
]
)
constraints
]
][raise "Could not parse Import specification"]
all [block? errs insert clear errs errors]
unless qm/errors: all [not empty? errors errors][result]
]
get-one: func [data type /local res][
parse data [some [res: type to end break | skip]]
unless tail? res [take res]
]
get-some: func [data type /local pos res][
res: make block! length? data
parse data [some [pos: type (append res take pos) :pos | skip]]
unless empty? res [res]
]
match: func [
[catch] source* [block!] spec [block!]
/report-to errs [block!]
/local out required format
][
source: copy :source*
errors: copy []
result: copy []
unless parse spec [
some [
set key set-word! (key: to-word key)
set required ['opt | 'any | 'some | ]
copy type [datatype any ['| datatype]]
otherwise
(
switch/default required [
any [
value: get-some source type
either value [do-constraints][no-constraints]
]
opt [
value: get-one source type
either value [do-constraints][no-constraints]
]
some [
value: get-some source type
either value [do-constraints][no-constraints report invalid]
]
][
value: get-one source type
either value [do-constraints][no-constraints report invalid]
]
repend result [to-set-word key value]
)
constraints
]
][raise "Could not parse Match specification"]
all [block? errs insert clear errs errors]
unless empty? source [key: 'match report too-many]
unless qm/errors: all [not empty? errors errors][construct result]
]
export [import match]
]
;--## Q(uick)TAG DIALECT
;-------------------------------------------------------------------##
context [
qtags: []
form-val: func [val /local value][
val: switch/default type?/word val [
get-word! [
if value: get/any :val [
rejoin [{ } val {="} sanitize form value {"}]
]
]
word! [
all [val: get val sanitize form val]
]
none! [val]
string! [val]
][sanitize form val]
any [val ""]
]
add-qtag: func ['name [word!] format [block!] spec [block!] prep [block!]][
repend qtags [
name
func [[catch] spec [block!]] compose/deep/only [
throw-on-error [
either spec: match spec (spec) [
spec: make spec (prep)
rejoin map/copy with/only spec (format) :form-val
][
(rejoin ["!!!Invalid " uppercase form name " tag."])
]
]
]
]
]
add-qtag a [
"<a" :id :href :rel :class :title :accesskey ">"
][
href: file! | url! | path!
id: opt issue!
class: any refinement!
title: opt string!
accesskey: opt char!
rel: any lit-word!
][
all [path? href href: link-to :href]
]
add-qtag div ["<div" :id :class ">"][
id: opt issue!
class: any refinement!
][]
add-qtag img [
"<img" :id :width :height :src :class :alt :title " />"
][
src: file! | url! | path!
size: opt pair!
alt: string!
title: opt string!
id: opt issue!
class: any refinement!
][
all [path? src src: link-to :src]
size: any [size -1x-1]
set [width height] reduce [size/x size/y]
all [width < 0 width: none] all [height < 0 height: none]
]
add-qtag form [
"<form" :method :action :enctype :id :class ">"
][
method: opt word! is within [get post upload]
action: file! | url! | path!
id: opt issue!
class: any refinement!
][
enctype: none
case/all [
path? action [action: link-to :action]
none? method [method: 'post]
method = 'upload [method: 'post enctype: 'multipart/form-data]
]
]
to-key: func [key [path! word!]][replace/all form compose-path :key #"/" #"."]
add-qtag label [
"<label" :for :accesskey :title :class ">"
][
title: opt string!
for: opt issue!
class: any refinement!
accesskey: opt char!
][]
add-qtag hidden [
{<input type="hidden"} :name :value " />"
][
name: word! | path!
value: opt any-string! | number! | none!
][
name: to-key name
value: any [value ""]
]
field: [
name: word! | path!
id: opt issue!
size: opt integer! | pair!
value: opt any-string! | number! | none!
class: any refinement!
]
add-qtag field [
{<input type="text"} :name :value :id :size :class " />"
] field [
name: to-key name
class: append any [class copy []] /field
value: any [value ""]
]
add-qtag password [
{<input type="password"} :name :value :id :size :class " />"
] field [
name: to-key name
class: append any [class copy []] /field
value: any [value ""]
]
add-qtag area [
{<textarea} :name :id :cols :rows :class ">" value "</textarea>"
] field [
name: to-key name
class: append any [class copy []] /field
size: 0x0 + any [size 12x50]
cols: abs size/x
rows: abs size/y
value: any [value ""]
]
check-options: [
name: word! | path!
id: opt issue!
value: any-string! | number!
checked: opt logic! | none! | any-string! | number!
class: any refinement!
]
check-line-options: [
name: word! | path!
id: issue!
accesskey: opt char!
label: string!
value: any-string! | number!
checked: opt logic! | none! | any-string! | number!
class: any refinement!
]
check-action: [
for: :id
name: to-key name
value: any [value ""]
checked: if any [value = checked true? checked]["checked"]
]
add-qtag check [
{<input type="checkbox"} :name :value :checked :id :class " />"
] :check-options :check-action
add-qtag check-line [
{<label} :for :accesskey :class {><input type="checkbox"} :name :value :checked :id " /> " label "</label>"
] :check-line-options :check-action
add-qtag radio [
{<input type="radio"} :name :value :checked :id :class " />"
] :check-options :check-action
add-qtag radio-line [
{<label} :for :accesskey {><input type="radio"} :name :value :checked :id :class " /> " label "</label>"
] :check-line-options :check-action
[
| 'select [
'many
| opt 'one
]
]
add-qtag get-file [
{<input type="file"} :name :id :class " />"
][
name: word! | path!
id: opt issue!
class: any refinement!
][
name: to-key name
class: append any [class copy []] /get-file
]
add-qtag submit [
{<input type="submit"} :name :value :id :size :class " />"
][
name: word! | path!
id: opt issue!
size: opt integer! is more-than 0
value: opt any-string! | number! | none!
class: any refinement!
][
name: to-key name
value: any [value ""]
class: append any [class copy []] /submit
]
build-tag: func [[catch] spec [block!] /local cmd action][
either action: select qtags cmd: pop spec: compose spec [
action spec
][
rejoin ["!!! Invalid QuickTag Type: <" cmd ">"]
]
]
export [add-qtag build-tag]
]
;--## FILESYSTEM
;-------------------------------------------------------------------##
context [
sw*: system/words
rights: [
folder [
owner-read: group-read: world-read:
owner-write: group-write: world-write:
owner-execute: group-execute: world-execute: #[true]
]
file [
owner-read: group-read: world-read:
owner-write: group-write: world-write: #[true]
owner-execute: group-execute: world-execute: #[false]
]
]
set-rights: func [file access][
unless find [1 3] system/version/4 [
attempt [set-modes file rights/:access]
; not perfect
]
]
break-path: func [[catch] target [file!] base [file!] /local path mk][
path: make block! []
either parse/all target: form target [
base some [
thru #"/" mk: (append path to-file copy/part target mk)
] end
][return path][
raise compose [access invalid-path (target)]
]
]
make-dir: func [[catch] path [file!] /root base [file!] /deep /local dirs][
all [empty? path return path]
if exists? path [
return either dir? path [path][false]
]
either deep [
close throw-on-error [open/new path]
any [
find [1 3] system/version/4
throw-on-error [set-rights path 'folder]
]
][
dirs: break-path path base
foreach path dirs [make-dir/deep path]
]
path
]
get-subfolders: func [folder /deep /local tree files][
tree: []
unless deep [clear tree]
insert tree folder
files: read folder
foreach file files [
if equal? last folder/:file #"/" [
get-subfolders/deep folder/:file
]
]
tree
]
delete: func [[catch] target [url!] /pare /local path folder err][
either error? set/any 'err try [
; Delete Children
if dir? target [
folder: get-subfolders dirize target
foreach path folder [close clear open path]
]
; Delete Target
set [path target] split-path target
folder: open path
remove find folder target
close folder
; Delete Empty Parents
if pare [
while [
pare: empty? folder: open path
close folder
pare
][
set [path target] split-path path
folder: open path
remove find folder target
close folder
]
]
][throw err][path]
]
dir?: func [[catch] target [file! url!]][
throw-on-error [
target: make port! target
query target
]
target/status = 'directory
]
touch: func [[catch] target [file! url!]][
throw-on-error [
target: make port! target
switch target/scheme [
qm [target: make port! target/locals/file]
]
query target
switch target/status [
file [set-modes target [modification-date: now]]
#[none] [close open/new target]
]
]
exit
]
export [delete make-dir touch]
; INTERFACE
add-protocol qm 0 context [
port-flags: system/standard/port-flags/pass-thru
init: func [port url /local spec][
unless all [
url? url
spec: get-space qm:// url
][
raise ["Filesystem URL <" url "> is invalid."]
]
with port [
set [url host path target] reduce bind [uri domain path target] spec
locals: context [
flags: []
root: spec/root
folder: spec/folder
file: spec/file
suffix: spec/suffix
open: #[none]
]
sub-port: make port! spec/file
]
]
open: func [port][
with port [
locals/flags: get-port-flags port [read write append new binary lines]
all [
sw*/find locals/flags 'new
not dir? locals/folder
make-dir/root locals/folder locals/root
]
either all [
any [
exists? locals/file
sw*/find locals/flags 'new
]
sw*/open/mode sub-port locals/flags
][
locals/open: true
state/tail: sub-port/state/tail
][
state/tail: 0
]
state/index: 0
state/flags: state/flags or port-flags
]
]
copy: func [port][
if port/locals/open with/only port [
user-data: sw*/copy skip sub-port state/index
all [
block? user-data block? state/custom
remove-each file user-data [not parse file state/custom]
]
user-data
]
]
insert: func [port data][
if port/locals/open with/only port [
foreach [test onfail][
[sw*/insert sub-port data]
["Could not write <" url ">"]
[set-rights sub-port 'file]
["Could not set permissions <" url ">"]
][
if error? try :test [raise :onfail]
]
self
]
]
remove: func [port][
either port/locals/open with/only port [
sub-port: skip sub-port state/index
system/words/remove/part sub-port state/num
self
][]
]
find: func [port value][
if port/locals/open with/only port [
if value: system/words/find sub-port value [
sub-port: :value
self
]
]
]
close: