steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Moving validators to their own vocabulary

db4
Slava Pestov 2008-05-22 22:41:23 -05:00
parent eee90b69c4
commit e8815e7bb2
2 changed files with 212 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

70
extra/validators/validators-tests.factor Normal file
View File

@ -0,0 +1,70 @@
IN: validators.tests
USING: kernel sequences tools.test validators accessors ;
[ "foo" v-number ] must-fail
[ 123 ] [ "123" v-number ] unit-test
[ "slava@factorcode.org" ] [
"slava@factorcode.org" v-email
] unit-test
[ "slava+foo@factorcode.org" ] [
"slava+foo@factorcode.org" v-email
] unit-test
[ "slava@factorcode.o" v-email ]
[ "invalid e-mail" = ] must-fail-with
[ "sla@@factorcode.o" v-email ]
[ "invalid e-mail" = ] must-fail-with
[ "slava@factorcodeorg" v-email ]
[ "invalid e-mail" = ] must-fail-with
[ "http://www.factorcode.org" ]
[ "http://www.factorcode.org" v-url ] unit-test
[ "http:/www.factorcode.org" v-url ]
[ "invalid URL" = ] must-fail-with
[ 14 V{ } ] [
[
"14" "age" [ drop v-number 13 v-min-value 100 v-max-value ] validate
] with-validation
] unit-test
[ f t ] [
[
"140" "age" [ drop v-number 13 v-min-value 100 v-max-value ] validate
] with-validation first
[ first "age" = ]
[ second validation-error? ]
[ second value>> "140" = ]
tri and and
] unit-test
TUPLE: person name age ;
person {
{ "name" [ v-required ] }
{ "age" [ v-number 13 v-min-value 100 v-max-value ] }
} define-validators
[ 14 V{ } ] [
[
person new dup
{ { "age" "14" } }
deposit-slots
age>>
] with-validation
] unit-test
[ t ] [
[
{ { "age" "" } } required-values
] with-validation first
[ first "age" = ]
[ second validation-error? ]
[ second message>> "required" = ]
tri and and
] unit-test

142
extra/validators/validators.factor Normal file
View File

@ -0,0 +1,142 @@
! Copyright (C) 2006, 2008 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
USING: kernel continuations sequences math namespaces sets
math.parser assocs regexp fry unicode.categories sequences
arrays hashtables words combinators mirrors classes quotations ;
IN: validators
: v-default ( str def -- str )
over empty? spin ? ;
: v-required ( str -- str )
dup empty? [ "required" throw ] when ;
: v-optional ( str quot -- str )
over empty? [ 2drop f ] [ call ] if ; inline
: v-min-length ( str n -- str )
over length over < [
[ "must be at least " % # " characters" % ] "" make
throw
] [
drop
] if ;
: v-max-length ( str n -- str )
over length over > [
[ "must be no more than " % # " characters" % ] "" make
throw
] [
drop
] if ;
: v-number ( str -- n )
dup string>number [ ] [ "must be a number" throw ] ?if ;
: v-integer ( n -- n )
dup integer? [ "must be an integer" throw ] unless ;
: v-min-value ( x n -- x )
2dup < [
[ "must be at least " % # ] "" make throw
] [
drop
] if ;
: v-max-value ( x n -- x )
2dup > [
[ "must be no more than " % # ] "" make throw
] [
drop
] if ;
: v-regexp ( str what regexp -- str )
>r over r> matches?
[ drop ] [ "invalid " prepend throw ] if ;
: v-email ( str -- str )
#! From http://www.regular-expressions.info/email.html
"e-mail"
R' [A-Z0-9._%+-]+@[A-Z0-9.-]+\.[A-Z]{2,4}'i
v-regexp ;
: v-url ( str -- str )
"URL"
R' (ftp|http|https)://(\w+:?\w*@)?(\S+)(:[0-9]+)?(/|/([\w#!:.?+=&%@!\-/]))?'
v-regexp ;
: v-captcha ( str -- str )
dup empty? [ "must remain blank" throw ] unless ;
: v-one-line ( str -- str )
dup "\r\n" intersect empty?
[ "must be a single line" throw ] unless ;
: v-one-word ( str -- str )
dup [ alpha? ] all?
[ "must be a single word" throw ] unless ;
SYMBOL: validation-messages
: with-validation ( quot -- messages )
V{ } clone [
validation-messages rot with-variable
] keep ; inline
: (validation-message) ( obj -- )
validation-messages get push ;
: (validation-message-for) ( obj name -- )
swap 2array (validation-message) ;
TUPLE: validation-message message ;
C: <validation-message> validation-message
: validation-message ( string -- )
<validation-message> (validation-message) ;
: validation-message-for ( string name -- )
[ <validation-message> ] dip (validation-message-for) ;
TUPLE: validation-error value message ;
C: <validation-error> validation-error
: validation-error ( reason -- )
f <validation-error> (validation-message) ;
: validation-error-for ( reason value name -- )
[ <validation-error> ] dip (validation-message-for) ;
: validation-failed? ( -- ? )
validation-messages get [
dup pair? [ second ] when validation-error?
] contains? ;
: define-validators ( class validators -- )
>hashtable "validators" set-word-prop ;
: validate ( value name quot -- result )
[ swap validation-error-for f ] recover ; inline
: validate-value ( value name validators -- result )
'[
, at {
{ [ dup pair? ] [ first ] }
{ [ dup quotation? ] [ ] }
} cond call
] validate ;
: required-values ( assoc -- )
[ swap [ drop v-required ] validate drop ] assoc-each ;
: validate-values ( assoc validators -- assoc' )
'[ over , validate-value ] assoc-map ;
: deposit-values ( destination assoc validators -- )
validate-values update ;
: deposit-slots ( tuple assoc -- )
[ [ <mirror> ] [ class "validators" word-prop ] bi ] dip
swap deposit-values ;