]> gitweb.factorcode.org Git - factor.git/commitdiff
Merge with erg's changes
authorSlava Pestov <slava@slava-pestovs-macbook-pro.local>
Mon, 14 Apr 2008 09:42:43 +0000 (04:42 -0500)
committerSlava Pestov <slava@slava-pestovs-macbook-pro.local>
Mon, 14 Apr 2008 09:42:43 +0000 (04:42 -0500)
1  2 
core/classes/tuple/tuple-tests.factor
core/classes/tuple/tuple.factor
core/parser/parser.factor
extra/http/server/auth/providers/providers.factor
extra/http/server/components/components-tests.factor
extra/http/server/components/components.factor
extra/http/server/server.factor
extra/http/server/sessions/sessions.factor

Simple merge
Simple merge
Simple merge
index 4b440089ad70e27d6f382046bb45d8da0d6adb7f,255cb5bfb80f8eb6e553f5253713548c36c1a3ad..1e5e33c4a02ea296dcd93ae87f2a1852a3305632
@@@ -50,94 -26,143 +50,94 @@@ SYMBOL: value
  
  : set-value values get set-at ;
  
 -: validate ( value component -- result )
 -    '[
 -        ,
 -        over empty? [
 -            [ default>> [ v-default ] when* ]
 -            [ required>> [ v-required ] when ]
 -            bi
 -        ] [ validate* ] if
 -    ] with-validator ;
 +: blank-values H{ } clone values set ;
  
 -: render-view ( component -- )
 -    [ id>> value ] [ render-view* ] bi ;
 +: from-tuple <mirror> values set ;
  
 -: render-error ( error -- )
 -    <span "error" =class span> write </span> ;
 +: values-tuple values get mirror-object ;
  
 -: render-edit ( component -- )
 -    dup id>> value dup validation-error? [
 -        [ reason>> ] [ value>> ] bi rot render-error*
 -    ] [
 -        swap [ default>> or ] keep render-edit*
 -    ] if ;
 -
 -: <component> ( id class -- component )
 -    \ component new
 -    swap construct-delegate
 -    swap >>id ; inline
 -
 -! Forms
 -TUPLE: form view-template edit-template components ;
 -
 -: <form> ( id -- form )
 -    form <component>
 -        V{ } clone >>components ;
 -
 -: add-field ( form component -- form )
 -    dup id>> pick components>> set-at ;
 -
 -: with-form ( form quot -- )
 -    >r components>> components r> with-variable ; inline
 -
 -: set-defaults ( form -- )
 -    [
 -        components get [
 -            swap values get [
 -                swap default>> or
 -            ] change-at
 -        ] assoc-each
 -    ] with-form ;
 -
 -: view-form ( form -- )
 -    dup view-template>> '[ , run-template ] with-form ;
 -
 -: edit-form ( form -- )
 -    dup edit-template>> '[ , run-template ] with-form ;
 -
 -: validate-param ( id component -- )
 -    [ [ params get at ] [ validate ] bi* ]
 -    [ drop set-value ] 2bi ;
 -
 -: (validate-form) ( form -- error? )
 -    [
 -        validation-failed? off
 -        components get [ validate-param ] assoc-each
 -        validation-failed? get
 -    ] with-form ;
 -
 -: validate-form ( form -- )
 -    (validate-form) [ validation-failed ] when ;
 +: render-view ( component -- )
 +    [ id>> value ] [ component-string ] [ renderer>> ] tri
 +    render-view* ;
  
 -: blank-values H{ } clone values set ;
 +<PRIVATE
  
 -: from-tuple <mirror> values set ;
 +: render-edit-string ( string component -- )
 +    [ id>> ] [ renderer>> ] bi render-edit* ;
  
 -: values-tuple values get mirror-object ;
 +: render-edit-error ( component -- )
 +    [ id>> value ] keep
 +    [ [ value>> ] dip render-edit-string ]
 +    [ drop reason>> render-error ] 2bi ;
  
 -! ! !
 -! Canned components: for simple applications and prototyping
 -! ! !
 +: value-or-default ( component -- value )
 +    [ id>> value ] [ default>> ] bi or ;
  
 -: render-input ( value component type -- )
 -    <input
 -    =type
 -    id>> [ =id ] [ =name ] bi
 -    =value
 -    input/> ;
 +: render-edit-value ( component -- )
 +    [ value-or-default ]
 +    [ component-string ]
 +    [ render-edit-string ]
 +    tri ;
  
 -! Hidden fields
 -TUPLE: hidden ;
 +PRIVATE>
  
 -: <hidden> ( component -- component )
 -    hidden construct-delegate ;
 +: render-edit ( component -- )
 +    dup id>> value validation-error?
 +    [ render-edit-error ] [ render-edit-value ] if ;
  
 -M: hidden render-view*
 -    2drop ;
 +: validate ( value component -- result )
 +    '[
 +        ,
 +        over empty? [
 +            [ default>> [ v-default ] when* ]
 +            [ required>> [ v-required ] when ]
 +            bi
 +        ] [ validate* ] if
 +    ] with-validator ;
  
 -M: hidden render-edit*
 -    >r dup number? [ number>string ] when r>
 -    "hidden" render-input ;
 +: new-component ( id class renderer -- component )
-     swap construct-empty
++    swap new
 +        swap >>renderer
 +        swap >>id
 +        init ; inline
  
  ! String input fields
 -TUPLE: string min-length max-length ;
 -
 -: <string> ( id -- component ) string <component> ;
 +TUPLE: string < component one-line min-length max-length ;
  
 -M: string validate*
 -    [ v-one-line ] [
 -        [ min-length>> [ v-min-length ] when* ]
 -        [ max-length>> [ v-max-length ] when* ]
 -        bi
 -    ] bi* ;
 +: new-string ( id class -- component )
 +    "text" <field> new-component
 +        t >>one-line ; inline
  
 -M: string render-view*
 -    drop write ;
 +: <string> ( id -- component )
 +    string new-string ;
  
 -M: string render-edit*
 -    "text" render-input ;
 +M: string validate*
 +    [   one-line>> [ v-one-line   ] when  ]
 +    [ min-length>> [ v-min-length ] when* ]
 +    [ max-length>> [ v-max-length ] when* ]
 +    tri ;
  
 -M: string render-error*
 -    "text" render-input render-error ;
 +M: string component-string
 +    drop ;
  
  ! Username fields
 -TUPLE: username ;
 +TUPLE: username < string ;
 +
 +M: username init
 +    2 >>min-length
 +    20 >>max-length ;
  
  : <username> ( id -- component )
 -    <string> username construct-delegate
 -        2 >>min-length
 -        20 >>max-length ;
 +    username new-string ;
  
  M: username validate*
 -    delegate validate* v-one-word ;
 +    call-next-method v-one-word ;
  
  ! E-mail fields
 -TUPLE: email ;
 +TUPLE: email < string ;
  
  : <email> ( id -- component )
 -    <string> email construct-delegate
 +    email new-string
          5 >>min-length
          60 >>max-length ;
  
index 8b3d6b8db10b106904d3b9251f90a7bc7e0a65d7,e59ca5c174736e4aa2335e82b79a3c717a75be9b..db03645a24f78b3fb0c7bb903c0f5cc120493b92
@@@ -105,13 -105,8 +105,13 @@@ SYMBOL: form-hoo
  
  TUPLE: dispatcher default responders ;
  
-     construct-empty
 +: new-dispatcher ( class -- dispatcher )
++    new
 +        404-responder get >>default
 +        H{ } clone >>responders ; inline
 +
  : <dispatcher> ( -- dispatcher )
 -    404-responder get H{ } clone dispatcher boa ;
 +    dispatcher new-dispatcher ;
  
  : split-path ( path -- rest first )
      [ CHAR: / = ] left-trim "/" split1 swap ;
index 0d875d255bb77b8326e41964687bdbdab6c67ed1,d41b54e156e2ec97a6f5dcc84d568b6aaf59e713..5df08888199e05d34cc4a4f26f9b7e11ad6259da
@@@ -17,10 -17,9 +17,10 @@@ M: object init-session* drop 
  
  TUPLE: session-manager responder sessions ;
  
 -: <session-manager> ( responder class -- responder' )
 -    >r <sessions-in-memory> session-manager boa
 -    r> construct-delegate ; inline
 +: construct-session-manager ( responder class -- responder' )
-     construct-empty
++    new
 +        <sessions-in-memory> >>sessions
 +        swap >>responder ; inline
  
  SYMBOLS: session session-id session-changed? ;