Scripts
AI
Animation
CGI
Compression
Console
Database
Debug
Dialects
Dialogs
Editor
Email
Encryption
Extension
External Library
File
File Handling
Files
Financial
FTP
Game
Games
Graphics
GUI
HTML
HTTP
Internet
LDC
Markup
Math
Module
Network
Networking
None
Other - Net
Parse
Patch
Printing
Protocol
Rebol
Scheme
Scientific
SDK
Security
Shell
Sound
SQL
TCP
Testing
Text
Text Processing
UI
User Interface
Util
Utility
VID
Visualization
Web
Win API
X-File
XML
Wiki
REBOL [
Title: "Import and Validate User Input"
Author: "Christopher Ross-Gill"
Date: 5-Jun-2007
Version: 0.1.1
File: %filtered-import.r
Rights: {Copyright (c) 2007, Christopher Ross-Gill}
Purpose: {Filters user input based upon a given spec}
Home: http://www.ross-gill.com/QM/
Comment: {Extracted from the QuarterMaster web framework}
History: [
0.1.0 26-Apr-2007 chrisrg "First standalone release"
0.1.1 5-Jun-2007 chrisrg "Fixed optional value handling"
]
Library: [
level: 'intermediate
platform: 'all
type: [dialect function]
domain: [cgi database dialects parse ui]
tested-under: [Core 2.6.2 WinXP OSX]
support: none
license: 'cc-by-sa
see-also: ""
]
Notes: {}
]
context [
range!: :pair!
pop: func [stack [series! port!] /local val][
val: pick stack 1
remove stack
:val
]
envelope: func [val [any-type!]][either any-block? val [val][reduce [val]]]
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 get key
while [all [not tail? key any-block? series]][
series: select series pop key
]
all [tail? key series]
]
comment {[
chars-n: charset [#"0" - #"9"] ; numeric
chars-la: charset [#"a" - #"z"] ; lower-alpha
chars-ua: charset [#"A" - #"Z"] ; upper-alpha
chars-a: union chars-la chars-ua ; alphabetic
chars-an: union chars-a chars-n ; alphanumeric
chars-hx: union chars-n charset [#"A" - #"F" #"a" - #"f"] ; hex
chars-ud: union chars-an charset "*-._!~'," ; url decode
chars-u: union chars-ud charset ":+%&=?" ; url
chars-id: union chars-n union chars-la charset "-_" ; id
chars-w1: union chars-a charset "*-._!+?&|" ; word-first-letter
chars-w*: union chars-w1 chars-n ; word
chars-f: insert copy chars-an #"-" ; file
chars-p: union chars-an charset "-_!+%" ; path
chars-sp: charset " ^-" ; space
chars-up: charset [#"^(80)" - #"^(FF)"] ; above ascii
chars: complement nochar: charset " ^-^/" ; no-space
]}
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-id: #[bitset! 64#{AAAAAAAg/wMAAACA/v//BwAAAAAAAAAAAAAAAAAAAAA=}]
chars-w1: #[bitset! 64#{AAAAAEJsAID+//+H/v//FwAAAAAAAAAAAAAAAAAAAAA=}]
chars-w*: #[bitset! 64#{AAAAAEJs/4P+//+H/v//FwAAAAAAAAAAAAAAAAAAAAA=}]
chars-f: #[bitset! 64#{AAAAAAAg/wP+//8H/v//BwAAAAAAAAAAAAAAAAAAAAA=}]
chars-p: #[bitset! 64#{AAAAAKJo/wP+//+H/v//BwAAAAAAAAAAAAAAAAAAAAA=}]
chars-sp: #[bitset! 64#{AAIAAAEAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA=}]
chars-up: #[bitset! 64#{AAAAAAAAAAAAAAAAAAAAAP////////////////////8=}]
chars: #[bitset! 64#{//n///7///////////////////////////////////8=}]
nochar: #[bitset! 64#{AAYAAAEAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA=}]
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]
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
]
id: [chars-la 0 15 chars-id]
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]
'positive [number]
'id [id]
'key [word 0 6 [#"." word]]
]
system/words/as: as: func [
[catch] type [datatype!] value [any-type! none!]
/where format [none! block! word!]
][
case/all [
word? format [format: select masks format]
none? format [format: select masks type]
block? format [
unless parse/all form value format [return #[none]]
]
]
attempt [make type value]
]
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"
]
else: #[none]
otherwise: [
['else | 'or][
set else string! | copy else any [word! string!]
] | (else: #[none])
]
key: value: target: format: 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 (
unless value = as/where :type get-from source to-word 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 | 'after] set target val-type otherwise (
unless val > target [report too-short]
) |
['less-than | 'before] set target val-type otherwise (
unless val < target [report too-long]
) |
is-not? set target val-type otherwise (
either value = target [
unless op [report wrong-length]
][
if op [report wrong-length]
]
)
]
]
]
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" [head remove back tail form type]
]
]
system/words/import: import: func [
"Imports and validates user input" [catch]
source [block!] {User input: [word! any-type! ...]}
spec [block!] {Importation and validation rules}
/else word [word!] {A word to assign an error report to}
/local required present constraints
][
errors: copy []
result: copy []
bind constraint 'source
bind spec 'self
unless parse compose/deep/only spec [
any [
set key set-word! (key: to-word key)
set required opt 'opt (required: required <> 'opt)
set type word! (throw-on-error [type: to-datatype :type])
set format opt block!
otherwise
(
value: get-from source key
present: not any [
none? value
empty? trim/head/tail form value
]
either all [present value: as/where :type value format][
constraints: [any constraint]
repend result [key value]
][
constraints: [to set-word! | to end]
case [
present [report invalid]
required [report blank]
not required [repend result [key none]]
]
]
)
constraints
]
][
throw make error! "Could not parse Import specification"
]
unless set any [word 'word] all [not empty? errors errors][result]
]
]