diff --git a/core/assocs/assocs.factor b/core/assocs/assocs.factor index ca49b550b0..f56ac810d9 100755 --- a/core/assocs/assocs.factor +++ b/core/assocs/assocs.factor @@ -20,26 +20,25 @@ GENERIC: assoc-clone-like ( assoc exemplar -- newassoc ) GENERIC: >alist ( assoc -- newassoc ) +: (assoc-each) ( assoc quot -- seq quot' ) + >r >alist r> [ first2 ] prepose ; inline + : assoc-find ( assoc quot -- key value ? ) - >r >alist r> [ first2 ] prepose find swap - [ first2 t ] [ drop f f f ] if ; inline + (assoc-each) find swap [ first2 t ] [ drop f f f ] if ; inline : key? ( key assoc -- ? ) at* nip ; inline : assoc-each ( assoc quot -- ) - [ f ] compose assoc-find 3drop ; inline - -: (assoc>map) ( quot accum -- quot' ) - [ push ] curry compose ; inline + (assoc-each) each ; inline : assoc>map ( assoc quot exemplar -- seq ) - >r over assoc-size - [ (assoc>map) assoc-each ] keep - r> like ; inline + >r accumulator >r assoc-each r> r> like ; inline + +: assoc-map-as ( assoc quot exemplar -- newassoc ) + >r [ 2array ] compose V{ } assoc>map r> assoc-like ; inline : assoc-map ( assoc quot -- newassoc ) - over >r [ 2array ] compose V{ } assoc>map r> assoc-like ; - inline + over assoc-map-as ; inline : assoc-push-if ( key value quot accum -- ) >r 2keep r> roll @@ -150,6 +149,9 @@ M: assoc assoc-clone-like ( assoc exemplar -- newassoc ) : value-at ( value assoc -- key/f ) swap [ = nip ] curry assoc-find 2drop ; +: push-at ( value key assoc -- ) + [ ?push ] change-at ; + : zip ( keys values -- alist ) 2array flip ; inline diff --git a/core/bit-arrays/bit-arrays-tests.factor b/core/bit-arrays/bit-arrays-tests.factor index 03961c2db6..b41cf9c4a5 100755 --- a/core/bit-arrays/bit-arrays-tests.factor +++ b/core/bit-arrays/bit-arrays-tests.factor @@ -38,7 +38,7 @@ IN: bit-arrays.tests [ t ] [ 100 [ - drop 100 [ drop 2 random zero? ] map + drop 100 [ 2 random zero? ] replicate dup >bit-array >array = ] all? ] unit-test diff --git a/core/classes/algebra/algebra-tests.factor b/core/classes/algebra/algebra-tests.factor index 28e899d08b..05c254f225 100755 --- a/core/classes/algebra/algebra-tests.factor +++ b/core/classes/algebra/algebra-tests.factor @@ -204,7 +204,7 @@ UNION: z1 b1 c1 ; 10 [ [ ] [ - 20 [ drop random-op ] map >quotation + 20 [ random-op ] [ ] replicate-as [ infer effect-in [ random-class ] times ] keep call drop @@ -238,8 +238,8 @@ UNION: z1 b1 c1 ; 20 [ [ t ] [ - 20 [ drop random-boolean-op ] [ ] map-as dup . - [ infer effect-in [ drop random-boolean ] map dup . ] keep + 20 [ random-boolean-op ] [ ] replicate-as dup . + [ infer effect-in [ random-boolean ] replicate dup . ] keep [ >r [ ] each r> call ] 2keep diff --git a/core/grouping/grouping-tests.factor b/core/grouping/grouping-tests.factor index dcf62e1117..dc3d970fbf 100644 --- a/core/grouping/grouping-tests.factor +++ b/core/grouping/grouping-tests.factor @@ -10,3 +10,5 @@ IN: grouping.tests 2 over set-length >array ] unit-test + +[ { { 1 2 } { 2 3 } } ] [ { 1 2 3 } 2 [ >array ] map ] unit-test diff --git a/core/grouping/grouping.factor b/core/grouping/grouping.factor index c12d43160c..caf46e5480 100644 --- a/core/grouping/grouping.factor +++ b/core/grouping/grouping.factor @@ -56,7 +56,7 @@ M: clumps set-length M: clumps group@ [ n>> over + ] [ seq>> ] bi ; -TUPLE: sliced-clumps < groups ; +TUPLE: sliced-clumps < clumps ; : ( seq n -- clumps ) sliced-clumps new-groups ; inline diff --git a/core/inference/backend/backend.factor b/core/inference/backend/backend.factor index 8966a38496..f8b071e803 100755 --- a/core/inference/backend/backend.factor +++ b/core/inference/backend/backend.factor @@ -80,7 +80,7 @@ M: object value-literal \ literal-expected inference-warning ; 1 #drop node, pop-d dup value-literal >r value-recursion r> ; -: value-vector ( n -- vector ) [ drop ] V{ } map-as ; +: value-vector ( n -- vector ) [ ] V{ } replicate-as ; : add-inputs ( seq stack -- n stack ) tuck [ length ] bi@ - dup 0 > @@ -162,7 +162,7 @@ TUPLE: too-many-r> ; dup ensure-values #>r over 0 pick node-inputs - over [ drop pop-d ] map reverse [ push-r ] each + over [ pop-d ] replicate reverse [ push-r ] each 0 pick pick node-outputs node, drop ; @@ -171,7 +171,7 @@ TUPLE: too-many-r> ; dup check-r> #r> 0 pick pick node-inputs - over [ drop pop-r ] map reverse [ push-d ] each + over [ pop-r ] replicate reverse [ push-d ] each over 0 pick node-outputs node, drop ; diff --git a/core/inference/inference-docs.factor b/core/inference/inference-docs.factor index 5900e5a844..7d43187f54 100755 --- a/core/inference/inference-docs.factor +++ b/core/inference/inference-docs.factor @@ -92,7 +92,7 @@ ARTICLE: "inference-errors" "Inference errors" { $subsection missing-effect } ; ARTICLE: "inference" "Stack effect inference" -"The stack effect inference tool is used to check correctness of code before it is run. It is also used by the compiler to build a dataflow graph on which optimizations can be performed. Only words for which a stack effect can be inferred will compile." +"The stack effect inference tool is used to check correctness of code before it is run. It is also used by the optimizing compiler to build a dataflow graph on which optimizations can be performed. Only words for which a stack effect can be inferred will compile with the optimizing compiler; all other words will be compiled with the non-optimizing compiler (see " { $link "compiler" } ")." $nl "The main entry point is a single word which takes a quotation and prints its stack effect and variable usage:" { $subsection infer. } diff --git a/core/io/encodings/encodings.factor b/core/io/encodings/encodings.factor index 4a9f90cb32..942476616f 100755 --- a/core/io/encodings/encodings.factor +++ b/core/io/encodings/encodings.factor @@ -28,23 +28,62 @@ ERROR: encode-error ; ! Decoding - f decoder boa ; +>cr drop ; inline + +: cr- f >>cr drop ; inline + : >decoder< ( decoder -- stream encoding ) - [ stream>> ] [ code>> ] bi ; + [ stream>> ] [ code>> ] bi ; inline -: cr+ t swap set-decoder-cr ; inline +: fix-read1 ( stream char -- char ) + over cr>> [ + over cr- + dup CHAR: \n = [ + drop dup stream-read1 + ] when + ] when nip ; inline -: cr- f swap set-decoder-cr ; inline +M: decoder stream-read1 + dup >decoder< decode-char fix-read1 ; + +: fix-read ( stream string -- string ) + over cr>> [ + over cr- + "\n" ?head [ + over stream-read1 [ suffix ] when* + ] when + ] when nip ; inline + +: (read) ( n quot -- n string ) + over 0 [ + [ + >r call dup + [ swap r> set-nth-unsafe f ] [ r> 3drop t ] if + ] 2curry find-integer + ] keep ; inline + +: finish-read ( n string -- string/f ) + { + { [ over 0 = ] [ 2drop f ] } + { [ over not ] [ nip ] } + [ swap head ] + } cond ; inline + +M: decoder stream-read + tuck >decoder< [ decode-char ] 2curry (read) finish-read fix-read ; + +M: decoder stream-read-partial stream-read ; : line-ends/eof ( stream str -- str ) f like swap cr- ; inline : line-ends\r ( stream str -- str ) swap cr+ ; inline : line-ends\n ( stream str -- str ) - over decoder-cr over empty? and + over cr>> over empty? and [ drop dup cr- stream-readln ] [ swap cr- ] if ; inline : handle-readln ( stream str ch -- str ) @@ -52,61 +91,30 @@ M: object f decoder boa ; { f [ line-ends/eof ] } { CHAR: \r [ line-ends\r ] } { CHAR: \n [ line-ends\n ] } - } case ; + } case ; inline -: fix-read ( stream string -- string ) - over decoder-cr [ - over cr- - "\n" ?head [ - over stream-read1 [ suffix ] when* - ] when - ] when nip ; - -: read-loop ( n stream -- string ) - SBUF" " clone [ - [ - >r nip stream-read1 dup - [ r> push f ] [ r> 2drop t ] if - ] 2curry find-integer drop - ] keep "" like f like ; - -M: decoder stream-read - tuck read-loop fix-read ; - -M: decoder stream-read-partial stream-read ; - -: (read-until) ( buf quot -- string/f sep/f ) +: ((read-until)) ( buf quot -- string/f sep/f ) ! quot: -- char stop? dup call [ >r drop "" like r> ] - [ pick push (read-until) ] if ; inline + [ pick push ((read-until)) ] if ; inline -M: decoder stream-read-until +: (read-until) ( seps stream -- string/f sep/f ) SBUF" " clone -rot >decoder< - [ decode-char [ dup rot memq? ] [ drop f t ] if* ] 3curry - (read-until) ; + [ decode-char dup [ dup rot member? ] [ 2drop f t ] if ] 3curry + ((read-until)) ; inline -: fix-read1 ( stream char -- char ) - over decoder-cr [ - over cr- - dup CHAR: \n = [ - drop dup stream-read1 - ] when - ] when nip ; +M: decoder stream-read-until (read-until) ; -M: decoder stream-read1 - dup >decoder< decode-char fix-read1 ; +M: decoder stream-readln "\r\n" over (read-until) handle-readln ; -M: decoder stream-readln ( stream -- str ) - "\r\n" over stream-read-until handle-readln ; - -M: decoder dispose decoder-stream dispose ; +M: decoder dispose stream>> dispose ; ! Encoding M: object encoder boa ; : >encoder< ( encoder -- stream encoding ) - [ stream>> ] [ code>> ] bi ; + [ stream>> ] [ code>> ] bi ; inline M: encoder stream-write1 >encoder< encode-char ; diff --git a/core/optimizer/def-use/def-use.factor b/core/optimizer/def-use/def-use.factor index a2e9f88135..d4905a1718 100755 --- a/core/optimizer/def-use/def-use.factor +++ b/core/optimizer/def-use/def-use.factor @@ -13,7 +13,7 @@ SYMBOL: def-use used-by empty? ; : uses-values ( node seq -- ) - [ def-use get [ ?push ] change-at ] with each ; + [ def-use get push-at ] with each ; : defs-values ( seq -- ) #! If there is no value, set it to a new empty vector, @@ -132,5 +132,4 @@ M: #r> kill-node* #! degree of accuracy; the new values should be marked as #! having _some_ usage, so that flushing doesn't erronously #! flush them away. - nest-def-use keys - def-use get [ [ t swap ?push ] change-at ] curry each ; + nest-def-use keys def-use get [ t -rot push-at ] curry each ; diff --git a/core/optimizer/known-words/known-words.factor b/core/optimizer/known-words/known-words.factor index d1dbefe26b..d69a2f94bc 100755 --- a/core/optimizer/known-words/known-words.factor +++ b/core/optimizer/known-words/known-words.factor @@ -2,14 +2,14 @@ ! See http://factorcode.org/license.txt for BSD license. IN: optimizer.known-words USING: alien arrays generic hashtables inference.dataflow -inference.class kernel assocs math math.private kernel.private -sequences words parser vectors strings sbufs io namespaces -assocs quotations sequences.private io.binary +inference.class kernel assocs math math.order math.private +kernel.private sequences words parser vectors strings sbufs io +namespaces assocs quotations sequences.private io.binary io.streams.string layouts splitting math.intervals math.floats.private classes.tuple classes.tuple.private classes classes.algebra optimizer.def-use optimizer.backend optimizer.pattern-match optimizer.inlining float-arrays -sequences.private combinators ; +sequences.private combinators byte-arrays byte-vectors ; { } [ [ @@ -59,15 +59,59 @@ sequences.private combinators ; node-in-d peek dup value? [ value-literal sequence? ] [ drop f ] if ; -: member-quot ( seq -- newquot ) - [ literalize [ t ] ] { } map>assoc - [ drop f ] suffix [ nip case ] curry ; +: expand-member ( #call quot -- ) + >r dup node-in-d peek value-literal r> call f splice-quot ; -: expand-member ( #call -- ) - dup node-in-d peek value-literal member-quot f splice-quot ; +: bit-member-n 256 ; inline + +: bit-member? ( seq -- ? ) + #! Can we use a fast byte array test here? + { + { [ dup length 8 < ] [ f ] } + { [ dup [ integer? not ] contains? ] [ f ] } + { [ dup [ 0 < ] contains? ] [ f ] } + { [ dup [ bit-member-n >= ] contains? ] [ f ] } + [ t ] + } cond nip ; + +: bit-member-seq ( seq -- flags ) + bit-member-n swap [ member? 1 0 ? ] curry B{ } map-as ; + +: exact-float? ( f -- ? ) + dup float? [ dup >integer >float = ] [ drop f ] if ; inline + +: bit-member-quot ( seq -- newquot ) + [ + [ drop ] % ! drop the sequence itself; we don't use it at run time + bit-member-seq , + [ + { + { [ over fixnum? ] [ ?nth 1 eq? ] } + { [ over bignum? ] [ ?nth 1 eq? ] } + { [ over exact-float? ] [ ?nth 1 eq? ] } + [ 2drop f ] + } cond + ] % + ] [ ] make ; + +: member-quot ( seq -- newquot ) + dup bit-member? [ + bit-member-quot + ] [ + [ literalize [ t ] ] { } map>assoc + [ drop f ] suffix [ nip case ] curry + ] if ; \ member? { - { [ dup literal-member? ] [ expand-member ] } + { [ dup literal-member? ] [ [ member-quot ] expand-member ] } +} define-optimizers + +: memq-quot ( seq -- newquot ) + [ [ dupd eq? ] curry [ drop t ] ] { } map>assoc + [ drop f ] suffix [ nip cond ] curry ; + +\ memq? { + { [ dup literal-member? ] [ [ memq-quot ] expand-member ] } } define-optimizers ! if the result of eq? is t and the second input is a literal, @@ -97,7 +141,7 @@ sequences.private combinators ; ] each \ push-all -{ { string sbuf } { array vector } } +{ { string sbuf } { array vector } { byte-array byte-vector } } "specializer" set-word-prop \ append diff --git a/core/parser/parser-docs.factor b/core/parser/parser-docs.factor index 1dc47432d3..2ec9f2de54 100755 --- a/core/parser/parser-docs.factor +++ b/core/parser/parser-docs.factor @@ -117,14 +117,18 @@ $nl { $subsection parse-tokens } ; ARTICLE: "parsing-words" "Parsing words" -"The Factor parser is follows a simple recursive-descent design. The parser reads successive tokens from the input; if the token identifies a number or an ordinary word, it is added to an accumulator vector. Otherwise if the token identifies a parsing word, the parsing word is executed immediately." +"The Factor parser follows a simple recursive-descent design. The parser reads successive tokens from the input; if the token identifies a number or an ordinary word, it is added to an accumulator vector. Otherwise if the token identifies a parsing word, the parsing word is executed immediately." $nl "Parsing words are marked by suffixing the definition with a " { $link POSTPONE: parsing } " declaration. Here is the simplest possible parsing word; it prints a greeting at parse time:" { $code ": hello \"Hello world\" print ; parsing" } -"Parsing words must have stack effect " { $snippet "( accum -- accum )" } ", where " { $snippet "accum" } " is the accumulator vector supplied by the parser. Parsing words can read input, add word definitions to the dictionary, and do anything an ordinary word can." +"Parsing words must not pop or push items from the stack; however, they are permitted to access the accumulator vector supplied by the parser at the top of the stack. That is, parsing words must have stack effect " { $snippet "( accum -- accum )" } ", where " { $snippet "accum" } " is the accumulator vector supplied by the parser." +$nl +"Parsing words can read input, add word definitions to the dictionary, and do anything an ordinary word can." +$nl +"Because of the stack restriction, parsing words cannot pass data to other words by leaving values on the stack; instead, use " { $link parsed } " to add the data to the parse tree so that it can be evaluated later." $nl "Parsing words cannot be called from the same source file where they are defined, because new definitions are only compiled at the end of the source file. An attempt to use a parsing word in its own source file raises an error:" -{ $link staging-violation } +{ $subsection staging-violation } "Tools for implementing parsing words:" { $subsection "reading-ahead" } { $subsection "parsing-word-nest" } diff --git a/core/sequences/sequences.factor b/core/sequences/sequences.factor index 4854ff8001..02a7191f0a 100755 --- a/core/sequences/sequences.factor +++ b/core/sequences/sequences.factor @@ -361,6 +361,12 @@ PRIVATE> : map ( seq quot -- newseq ) over map-as ; inline +: replicate ( seq quot -- newseq ) + [ drop ] prepose map ; inline + +: replicate-as ( seq quot exemplar -- newseq ) + >r [ drop ] prepose r> map-as ; inline + : change-each ( seq quot -- ) over map-into ; inline @@ -413,10 +419,11 @@ PRIVATE> : interleave ( seq between quot -- ) [ (interleave) ] 2curry >r dup length swap r> 2each ; inline +: accumulator ( quot -- quot' vec ) + V{ } clone [ [ push ] curry compose ] keep ; inline + : unfold ( pred quot tail -- seq ) - V{ } clone [ - swap >r [ push ] curry compose r> while - ] keep { } like ; inline + swap accumulator >r swap while r> { } like ; inline : follow ( obj quot -- seq ) >r [ dup ] r> [ keep ] curry [ ] unfold nip ; inline diff --git a/core/sorting/sorting-tests.factor b/core/sorting/sorting-tests.factor index a56c41b620..17ec2d7cd1 100755 --- a/core/sorting/sorting-tests.factor +++ b/core/sorting/sorting-tests.factor @@ -11,7 +11,7 @@ unit-test [ t ] [ 100 [ drop - 100 [ drop 20 random [ drop 1000 random ] map ] map natural-sort [ before=? ] monotonic? + 100 [ 20 random [ 1000 random ] replicate ] replicate natural-sort [ before=? ] monotonic? ] all? ] unit-test diff --git a/core/strings/strings-tests.factor b/core/strings/strings-tests.factor index 44e1d8859f..d10f1603f1 100755 --- a/core/strings/strings-tests.factor +++ b/core/strings/strings-tests.factor @@ -98,7 +98,7 @@ unit-test [ ] [ [ 4 [ - 100 [ drop "obdurak" clone ] map + 100 [ "obdurak" clone ] replicate gc dup [ 1234 0 rot set-string-nth diff --git a/core/vectors/vectors-tests.factor b/core/vectors/vectors-tests.factor index 8f64265771..3b2c94b2e5 100755 --- a/core/vectors/vectors-tests.factor +++ b/core/vectors/vectors-tests.factor @@ -26,7 +26,7 @@ IN: vectors.tests [ V{ 1 2 } ] [ [ 1 2 ] >vector ] unit-test [ t ] [ - 100 [ drop 100 random ] map >vector + 100 [ 100 random ] V{ } replicate-as dup >array >vector = ] unit-test diff --git a/extra/assocs/lib/lib-tests.factor b/extra/assocs/lib/lib-tests.factor new file mode 100644 index 0000000000..0bf8270088 --- /dev/null +++ b/extra/assocs/lib/lib-tests.factor @@ -0,0 +1,4 @@ +IN: assocs.lib.tests +USING: assocs.lib tools.test vectors ; + +{ 1 1 } [ [ ?push ] histogram ] must-infer-as diff --git a/extra/assocs/lib/lib.factor b/extra/assocs/lib/lib.factor index c3e487a9fc..14632df771 100755 --- a/extra/assocs/lib/lib.factor +++ b/extra/assocs/lib/lib.factor @@ -17,9 +17,6 @@ IN: assocs.lib : replace-at ( assoc value key -- assoc ) >r >r dup r> 1vector r> rot set-at ; -: insert-at ( value key assoc -- ) - [ ?push ] change-at ; - : peek-at* ( assoc key -- obj ? ) swap at* dup [ >r peek r> ] when ; @@ -32,7 +29,7 @@ IN: assocs.lib : multi-assoc-each ( assoc quot -- ) [ with each ] curry assoc-each ; inline -: insert ( value variable -- ) namespace insert-at ; +: insert ( value variable -- ) namespace push-at ; : generate-key ( assoc -- str ) >r 32 random-bits >hex r> @@ -44,4 +41,4 @@ IN: assocs.lib : histogram ( assoc quot -- assoc' ) H{ } clone [ swap [ change-at ] 2curry assoc-each - ] keep ; + ] keep ; inline diff --git a/extra/base64/base64-tests.factor b/extra/base64/base64-tests.factor index d867351f8b..86c58af505 100644 --- a/extra/base64/base64-tests.factor +++ b/extra/base64/base64-tests.factor @@ -1,8 +1,18 @@ USING: kernel tools.test base64 strings ; -[ "abcdefghijklmnopqrstuvwxyz" ] [ "abcdefghijklmnopqrstuvwxyz" >base64 base64> +[ "abcdefghijklmnopqrstuvwxyz" ] [ "abcdefghijklmnopqrstuvwxyz" >base64 base64> >string ] unit-test -[ "" ] [ "" >base64 base64> ] unit-test -[ "a" ] [ "a" >base64 base64> ] unit-test -[ "ab" ] [ "ab" >base64 base64> ] unit-test -[ "abc" ] [ "abc" >base64 base64> ] unit-test +[ "" ] [ "" >base64 base64> >string ] unit-test +[ "a" ] [ "a" >base64 base64> >string ] unit-test +[ "ab" ] [ "ab" >base64 base64> >string ] unit-test +[ "abc" ] [ "abc" >base64 base64> >string ] unit-test + +! From http://en.wikipedia.org/wiki/Base64 +[ "TWFuIGlzIGRpc3Rpbmd1aXNoZWQsIG5vdCBvbmx5IGJ5IGhpcyByZWFzb24sIGJ1dCBieSB0aGlzIHNpbmd1bGFyIHBhc3Npb24gZnJvbSBvdGhlciBhbmltYWxzLCB3aGljaCBpcyBhIGx1c3Qgb2YgdGhlIG1pbmQsIHRoYXQgYnkgYSBwZXJzZXZlcmFuY2Ugb2YgZGVsaWdodCBpbiB0aGUgY29udGludWVkIGFuZCBpbmRlZmF0aWdhYmxlIGdlbmVyYXRpb24gb2Yga25vd2xlZGdlLCBleGNlZWRzIHRoZSBzaG9ydCB2ZWhlbWVuY2Ugb2YgYW55IGNhcm5hbCBwbGVhc3VyZS4=" ] +[ + "Man is distinguished, not only by his reason, but by this singular passion from other animals, which is a lust of the mind, that by a perseverance of delight in the continued and indefatigable generation of knowledge, exceeds the short vehemence of any carnal pleasure." + >base64 >string +] unit-test + +\ >base64 must-infer +\ base64> must-infer diff --git a/extra/base64/base64.factor b/extra/base64/base64.factor index 600a8f4c3d..d48abc2014 100644 --- a/extra/base64/base64.factor +++ b/extra/base64/base64.factor @@ -1,11 +1,10 @@ -USING: kernel math sequences namespaces io.binary splitting -grouping strings hashtables ; +USING: kernel math sequences io.binary splitting grouping ; IN: base64 r [ length ] keep r> find-last drop dup [ - 1- ] [ 2drop 0 ] if ; + >r [ length ] keep r> find-last drop dup [ - 1- ] [ 2drop 0 ] if ; inline : ch>base64 ( ch -- ch ) "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/" nth ; @@ -20,28 +19,26 @@ IN: base64 } nth ; : encode3 ( seq -- seq ) - be> 4 [ 3 swap - -6 * shift HEX: 3f bitand ch>base64 ] with map ; + be> 4 [ -6 * shift HEX: 3f bitand ch>base64 ] with B{ } map-as ; : decode4 ( str -- str ) - [ base64>ch ] map 0 [ swap 6 shift bitor ] reduce 3 >be ; + 0 [ base64>ch swap 6 shift bitor ] reduce 3 >be ; : >base64-rem ( str -- str ) - [ 3 0 pad-right encode3 ] keep length 1+ head 4 CHAR: = pad-right ; + [ 3 0 pad-right encode3 ] [ length 1+ ] bi head 4 CHAR: = pad-right ; PRIVATE> : >base64 ( seq -- base64 ) #! cut string into two pieces, convert 3 bytes at a time #! pad string with = when not enough bits - dup length dup 3 mod - cut swap - [ - 3 [ encode3 % ] each - dup empty? [ drop ] [ >base64-rem % ] if - ] "" make ; + dup length dup 3 mod - cut + [ 3 [ encode3 ] map concat ] + [ dup empty? [ drop "" ] [ >base64-rem ] if ] + bi* append ; : base64> ( base64 -- str ) #! input length must be a multiple of 4 - [ - [ 4 [ decode4 % ] each ] keep [ CHAR: = = not ] count-end - ] SBUF" " make swap [ dup pop* ] times >string ; - + [ 4 [ decode4 ] map concat ] + [ [ CHAR: = = not ] count-end ] + bi head* ; diff --git a/extra/color-picker/color-picker.factor b/extra/color-picker/color-picker.factor index 0480235dfe..c64d1e4872 100755 --- a/extra/color-picker/color-picker.factor +++ b/extra/color-picker/color-picker.factor @@ -24,7 +24,7 @@ M: color-preview model-changed [ [ 256 /f ] map 1 suffix ] ; : ( -- model gadget ) - 3 [ drop 0 0 0 255 ] map + 3 [ 0 0 0 255 ] replicate dup [ range-model ] map swap [ [ gadget, ] each ] make-filled-pile ; diff --git a/extra/combinators/lib/lib.factor b/extra/combinators/lib/lib.factor index da13901ab7..fe6b68638b 100755 --- a/extra/combinators/lib/lib.factor +++ b/extra/combinators/lib/lib.factor @@ -66,32 +66,6 @@ MACRO: napply ( n -- ) : short-circuit ( quots quot default -- quot ) 1quotation -rot { } map>assoc alist>quot ; -! MACRO: && ( quots -- ? ) -! [ [ not ] append [ f ] ] t short-circuit ; - -! MACRO: <-&& ( quots -- ) -! [ [ dup ] prepend [ not ] append [ f ] ] t short-circuit -! [ nip ] append ; - -! MACRO: <--&& ( quots -- ) -! [ [ 2dup ] prepend [ not ] append [ f ] ] t short-circuit -! [ 2nip ] append ; - -! or - -! MACRO: || ( quots -- ? ) [ [ t ] ] f short-circuit ; - -! MACRO: 0|| ( quots -- ? ) [ [ t ] ] f short-circuit ; - -! MACRO: 1|| ( quots -- ? ) -! [ [ dup ] prepend [ t ] ] f short-circuit [ nip ] append ; - -! MACRO: 2|| ( quots -- ? ) -! [ [ 2dup ] prepend [ t ] ] f short-circuit [ 2nip ] append ; - -! MACRO: 3|| ( quots -- ? ) -! [ [ 3dup ] prepend [ t ] ] f short-circuit [ 3nip ] append ; - ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! MACRO: 0&& ( quots -- quot ) diff --git a/extra/concurrency/distributed/distributed-tests.factor b/extra/concurrency/distributed/distributed-tests.factor index ca1da0deaa..dc20e7ad5c 100755 --- a/extra/concurrency/distributed/distributed-tests.factor +++ b/extra/concurrency/distributed/distributed-tests.factor @@ -1,9 +1,9 @@ IN: concurrency.distributed.tests USING: tools.test concurrency.distributed kernel io.files arrays io.sockets system combinators threads math sequences -concurrency.messaging continuations ; +concurrency.messaging continuations accessors prettyprint ; -: test-node +: test-node ( -- addrspec ) { { [ os unix? ] [ "distributed-concurrency-test" temp-file ] } { [ os windows? ] [ "127.0.0.1" 1238 ] } @@ -11,9 +11,9 @@ concurrency.messaging continuations ; [ ] [ [ "distributed-concurrency-test" temp-file delete-file ] ignore-errors ] unit-test -[ ] [ test-node dup 1array swap (start-node) ] unit-test +[ ] [ test-node dup (start-node) ] unit-test -[ ] [ 100 sleep ] unit-test +[ ] [ 1000 sleep ] unit-test [ ] [ [ @@ -30,4 +30,6 @@ concurrency.messaging continuations ; receive ] unit-test +[ ] [ 1000 sleep ] unit-test + [ ] [ test-node stop-node ] unit-test diff --git a/extra/concurrency/distributed/distributed.factor b/extra/concurrency/distributed/distributed.factor index c637f4baa3..9ae2627505 100755 --- a/extra/concurrency/distributed/distributed.factor +++ b/extra/concurrency/distributed/distributed.factor @@ -1,8 +1,8 @@ ! Copyright (C) 2005 Chris Double. All Rights Reserved. ! See http://factorcode.org/license.txt for BSD license. USING: serialize sequences concurrency.messaging threads io -io.server qualified arrays namespaces kernel io.encodings.binary -accessors ; +io.servers.connection io.encodings.binary +qualified arrays namespaces kernel accessors ; FROM: io.sockets => host-name with-client ; IN: concurrency.distributed @@ -10,21 +10,21 @@ SYMBOL: local-node : handle-node-client ( -- ) deserialize - [ first2 get-process send ] - [ stop-server ] if* ; + [ first2 get-process send ] [ stop-server ] if* ; -: (start-node) ( addrspecs addrspec -- ) +: (start-node) ( addrspec addrspec -- ) local-node set-global [ - "concurrency.distributed" - binary - [ handle-node-client ] with-server + + swap >>insecure + binary >>encoding + "concurrency.distributed" >>name + [ handle-node-client ] >>handler + start-server ] curry "Distributed concurrency server" spawn drop ; : start-node ( port -- ) - [ internet-server ] - [ host-name swap ] bi - (start-node) ; + host-name over (start-node) ; TUPLE: remote-process id node ; diff --git a/extra/cords/cords.factor b/extra/cords/cords.factor index f5cc89f8d5..a7f4246826 100644 --- a/extra/cords/cords.factor +++ b/extra/cords/cords.factor @@ -1,4 +1,4 @@ -! Copysecond (C) 2008 Slava Pestov. +! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: accessors assocs sequences sorting math math.order arrays combinators kernel ; diff --git a/extra/db/queries/queries.factor b/extra/db/queries/queries.factor index 807aeda74a..5c3f3e13e6 100644 --- a/extra/db/queries/queries.factor +++ b/extra/db/queries/queries.factor @@ -195,3 +195,12 @@ M: db ( tuple class groups -- statement ) ] { { } { } { } } nmake >r >r parse-sql 4drop r> r> maybe-make-retryable do-select ; + +: create-index ( index-name table-name columns -- ) + [ + >r >r "create index " % % r> " on " % % r> "(" % + "," join % ")" % + ] "" make sql-command ; + +: drop-index ( index-name -- ) + [ "drop index " % % ] "" make sql-command ; diff --git a/extra/db/sqlite/sqlite.factor b/extra/db/sqlite/sqlite.factor index c7c9065b43..38a3899fc4 100755 --- a/extra/db/sqlite/sqlite.factor +++ b/extra/db/sqlite/sqlite.factor @@ -53,7 +53,7 @@ M: sqlite-result-set dispose ( result-set -- ) M: sqlite-statement low-level-bind ( statement -- ) [ statement-bind-params ] [ statement-handle ] bi - swap [ [ key>> ] [ value>> ] [ type>> ] tri sqlite-bind-type ] with each ; + [ swap [ key>> ] [ value>> ] [ type>> ] tri sqlite-bind-type ] curry each ; M: sqlite-statement bind-statement* ( statement -- ) sqlite-maybe-prepare diff --git a/extra/db/tuples/tuples.factor b/extra/db/tuples/tuples.factor index 4903adff5c..e02e21cbe6 100755 --- a/extra/db/tuples/tuples.factor +++ b/extra/db/tuples/tuples.factor @@ -122,6 +122,9 @@ M: retryable execute-statement* ( statement type -- ) : ensure-table ( class -- ) [ create-table ] curry ignore-errors ; +: ensure-tables ( classes -- ) + [ ensure-table ] each ; + : insert-db-assigned-statement ( tuple -- ) dup class db get db-insert-statements [ ] cache diff --git a/extra/delegate/delegate.factor b/extra/delegate/delegate.factor index c375dcf874..4f1e950b01 100755 --- a/extra/delegate/delegate.factor +++ b/extra/delegate/delegate.factor @@ -1,8 +1,8 @@ ! Copyright (C) 2007 Daniel Ehrenberg ! See http://factorcode.org/license.txt for BSD license. USING: parser generic kernel classes words slots assocs -sequences arrays vectors definitions prettyprint combinators.lib -math hashtables sets ; +sequences arrays vectors definitions prettyprint +math hashtables sets macros namespaces ; IN: delegate : protocol-words ( protocol -- words ) @@ -23,7 +23,15 @@ M: tuple-class group-words : consult-method ( word class quot -- ) [ drop swap first create-method ] - [ nip swap first2 swapd [ ndip ] 2curry swap suffix ] 3bi + [ + nip + [ + over second saver % + % + dup second restorer % + first , + ] [ ] make + ] 3bi define ; : change-word-prop ( word prop quot -- ) diff --git a/extra/dns/dns.factor b/extra/dns/dns.factor index 48380a0d57..214b45ce0c 100644 --- a/extra/dns/dns.factor +++ b/extra/dns/dns.factor @@ -424,6 +424,10 @@ SYMBOLS: NO-ERROR FORMAT-ERROR SERVER-FAILURE NAME-ERROR NOT-IMPLEMENTED } 2cleave message boa ; +: ba->message ( ba -- message ) parse-message ; + +: with-message-bytes ( ba quot -- ) >r ba->message r> call message->ba ; inline + ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! : send-receive-udp ( ba server -- ba ) diff --git a/extra/dns/server/server.factor b/extra/dns/server/server.factor index de36d661aa..04b3ecfbee 100644 --- a/extra/dns/server/server.factor +++ b/extra/dns/server/server.factor @@ -1,15 +1,17 @@ -USING: kernel combinators sequences sets math - io.sockets unicode.case accessors +USING: kernel combinators sequences sets math threads namespaces continuations + debugger io io.sockets unicode.case accessors destructors combinators.cleave combinators.lib - newfx + newfx fry dns dns.util dns.misc ; IN: dns.server ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -: records ( -- vector ) V{ } ; +SYMBOL: records-var + +: records ( -- records ) records-var get ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -50,9 +52,10 @@ IN: dns.server : rr->rdata-names ( rr -- names/f ) { - { [ dup type>> NS = ] [ rdata>> {1} ] } - { [ dup type>> MX = ] [ rdata>> exchange>> {1} ] } - { [ t ] [ drop f ] } + { [ dup type>> NS = ] [ rdata>> {1} ] } + { [ dup type>> MX = ] [ rdata>> exchange>> {1} ] } + { [ dup type>> CNAME = ] [ rdata>> {1} ] } + { [ t ] [ drop f ] } } cond ; @@ -192,31 +195,14 @@ DEFER: query->rrs ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -: (socket) ( -- vec ) V{ f } ; +: (handle-request) ( packet -- ) + [ [ find-answer ] with-message-bytes ] change-data respond ; -: socket ( -- socket ) (socket) 1st ; +: handle-request ( packet -- ) [ (handle-request) ] curry in-thread ; -: init-socket-on-port ( port -- ) - f swap 0 (socket) as-mutate ; +: receive-loop ( socket -- ) + [ receive-packet handle-request ] [ receive-loop ] bi ; -: init-socket ( -- ) 53 init-socket-on-port ; +: loop ( addr-spec -- ) + [ '[ , [ receive-loop ] with-disposal ] try ] [ loop ] bi ; -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -: loop ( -- ) - socket receive - swap - parse-message - find-answer - message->ba - swap - socket send - loop ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -: start ( -- ) init-socket loop ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -MAIN: start diff --git a/extra/dns/util/util.factor b/extra/dns/util/util.factor index 5933216a3c..35af74b92a 100644 --- a/extra/dns/util/util.factor +++ b/extra/dns/util/util.factor @@ -16,4 +16,15 @@ MACRO: 1if ( test then else -- ) '[ dup @ , , if ] ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -: longer? ( seq seq -- ? ) [ length ] bi@ > ; \ No newline at end of file +: longer? ( seq seq -- ? ) [ length ] bi@ > ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +USING: io.sockets accessors ; + +TUPLE: packet data addr socket ; + +: receive-packet ( socket -- packet ) [ receive ] keep packet boa ; + +: respond ( packet -- ) [ data>> ] [ addr>> ] [ socket>> ] tri send ; + diff --git a/extra/editors/gvim/gvim.factor b/extra/editors/gvim/gvim.factor index 62150bdf49..041f3db675 100755 --- a/extra/editors/gvim/gvim.factor +++ b/extra/editors/gvim/gvim.factor @@ -3,14 +3,12 @@ namespaces sequences system combinators editors.vim editors.gvim.backend vocabs.loader ; IN: editors.gvim -TUPLE: gvim ; +SINGLETON: gvim M: gvim vim-command ( file line -- string ) - [ "\"" % gvim-path % "\" \"" % swap % "\" +" % # ] "" make ; + [ gvim-path , swap , "+" swap number>string append , ] { } make ; -t vim-detach set-global ! don't block the ui - -T{ gvim } vim-editor set-global +gvim vim-editor set-global { { [ os unix? ] [ "editors.gvim.unix" ] } diff --git a/extra/editors/vim/vim-docs.factor b/extra/editors/vim/vim-docs.factor index 020117564d..cf42884084 100644 --- a/extra/editors/vim/vim-docs.factor +++ b/extra/editors/vim/vim-docs.factor @@ -11,7 +11,5 @@ $nl "USE: vim" "\"c:\\\\program files\\\\vim\\\\vim70\\\\gvim\" vim-path set-global" } -"On Unix, you may omit the last line if " { $snippet "\"vim\"" } " is in your " { $snippet "$PATH" } "." -$nl -"If you are running the terminal version of Vim, you want it to block Factor until exiting, but for GVim the opposite is desired, so that one can work in Factor and GVim concurrently. The " { $link vim-detach } " global variable can be set to " { $link t } " to detach the Vim process. The default is " { $link f } "." ; +"On Unix, you may omit the last line if " { $snippet "\"vim\"" } " is in your " { $snippet "$PATH" } "." ; diff --git a/extra/editors/vim/vim.factor b/extra/editors/vim/vim.factor index 9ce256868b..bfbb8f15a5 100755 --- a/extra/editors/vim/vim.factor +++ b/extra/editors/vim/vim.factor @@ -3,24 +3,20 @@ namespaces parser prettyprint sequences editors accessors ; IN: editors.vim SYMBOL: vim-path -SYMBOL: vim-detach SYMBOL: vim-editor -HOOK: vim-command vim-editor +HOOK: vim-command vim-editor ( file line -- array ) -TUPLE: vim ; +SINGLETON: vim -M: vim vim-command ( file line -- array ) +M: vim vim-command [ vim-path get , swap , "+" swap number>string append , ] { } make ; : vim-location ( file line -- ) - vim-command - swap >>command - vim-detach get-global [ t >>detached ] when - try-process ; + vim-command try-process ; "vim" vim-path set-global [ vim-location ] edit-hook set-global -T{ vim } vim-editor set-global +vim vim-editor set-global diff --git a/extra/eval-server/eval-server.factor b/extra/eval-server/eval-server.factor deleted file mode 100644 index 3bfae616a2..0000000000 --- a/extra/eval-server/eval-server.factor +++ /dev/null @@ -1,11 +0,0 @@ -! Copyright (C) 2007 Slava Pestov. -! See http://factorcode.org/license.txt for BSD license. -USING: listener io.server strings parser byte-arrays ; -IN: eval-server - -: eval-server ( -- ) - 9998 local-server "eval-server" [ - >string eval>string >byte-array - ] with-datagrams ; - -MAIN: eval-server diff --git a/extra/eval-server/summary.txt b/extra/eval-server/summary.txt deleted file mode 100644 index b75930ac9f..0000000000 --- a/extra/eval-server/summary.txt +++ /dev/null @@ -1 +0,0 @@ -Listens for UDP packets on localhost:9998, evaluates them and sends back result diff --git a/extra/eval-server/tags.txt b/extra/eval-server/tags.txt deleted file mode 100644 index f628c95985..0000000000 --- a/extra/eval-server/tags.txt +++ /dev/null @@ -1,4 +0,0 @@ -demos -network -tools -applications diff --git a/extra/farkup/farkup.factor b/extra/farkup/farkup.factor index 1b51bb5752..321648136a 100755 --- a/extra/farkup/farkup.factor +++ b/extra/farkup/farkup.factor @@ -1,12 +1,13 @@ ! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: arrays io io.styles kernel memoize namespaces peg -sequences strings html.elements xml.entities xmode.code2html -splitting io.streams.string peg.parsers +USING: arrays io io.styles kernel memoize namespaces peg math +combinators sequences strings html.elements xml.entities +xmode.code2html splitting io.streams.string peg.parsers sequences.deep unicode.categories ; IN: farkup SYMBOL: relative-link-prefix +SYMBOL: disable-images? SYMBOL: link-no-follow? ] with-string-writer ; +: invalid-url "javascript:alert('Invalid URL in farkup');" ; + : check-url ( href -- href' ) - CHAR: : over member? [ - dup { "http://" "https://" "ftp://" } [ head? ] with contains? - [ drop "/" ] unless - ] [ - relative-link-prefix get prepend - ] if ; + { + { [ dup empty? ] [ drop invalid-url ] } + { [ dup [ 127 > ] contains? ] [ drop invalid-url ] } + { [ dup first "/\\" member? ] [ drop invalid-url ] } + { [ CHAR: : over member? ] [ + dup { "http://" "https://" "ftp://" } [ head? ] with contains? + [ drop invalid-url ] unless + ] } + [ relative-link-prefix get prepend ] + } cond ; : escape-link ( href text -- href-esc text-esc ) >r check-url escape-quoted-string r> escape-string ; @@ -82,18 +89,22 @@ MEMO: eq ( -- parser ) escape-link [ "r , r> + " href=\"" , >r , r> "\"" , link-no-follow? get [ " nofollow=\"true\"" , ] when - "\">" , , "" , + ">" , , "" , ] { } make ; : make-image-link ( href alt -- seq ) - escape-link - [ - "\""" , ] - { } make ; + disable-images? get [ + 2drop "Images are not allowed" + ] [ + escape-link + [ + "\""" , + ] { } make + ] if ; MEMO: image-link ( -- parser ) [ diff --git a/extra/ftp/server/server.factor b/extra/ftp/server/server.factor index cce69dde0f..c71eadb72f 100644 --- a/extra/ftp/server/server.factor +++ b/extra/ftp/server/server.factor @@ -2,9 +2,9 @@ ! See http://factorcode.org/license.txt for BSD license. USING: accessors combinators io io.encodings.8-bit io.encodings io.encodings.binary io.encodings.utf8 io.files -io.server io.sockets kernel math.parser namespaces sequences +io.sockets kernel math.parser namespaces sequences ftp io.unix.launcher.parser unicode.case splitting assocs -classes io.server destructors calendar io.timeouts +classes io.servers.connection destructors calendar io.timeouts io.streams.duplex threads continuations math concurrency.promises byte-arrays ; IN: ftp.server @@ -305,7 +305,10 @@ ERROR: not-a-directory ; [ drop unrecognized-command t ] } case [ handle-client-loop ] when ; -: handle-client ( -- ) +TUPLE: ftp-server < threaded-server ; + +M: ftp-server handle-client* ( server -- ) + drop [ "" [ host-name client set @@ -313,9 +316,14 @@ ERROR: not-a-directory ; ] with-directory ] with-destructors ; +: ( port -- server ) + ftp-server new-threaded-server + swap >>insecure + "ftp.server" >>name + latin1 >>encoding ; + : ftpd ( port -- ) - internet-server "ftp.server" - latin1 [ handle-client ] with-server ; + start-server ; : ftpd-main ( -- ) 2100 ftpd ; diff --git a/extra/furnace/actions/actions.factor b/extra/furnace/actions/actions.factor index 1cef8e24e5..4b431c83bc 100755 --- a/extra/furnace/actions/actions.factor +++ b/extra/furnace/actions/actions.factor @@ -8,6 +8,7 @@ http.server http.server.responses furnace furnace.flash +html.forms html.elements html.components html.components @@ -20,75 +21,83 @@ SYMBOL: params SYMBOL: rest : render-validation-messages ( -- ) - validation-messages get + form get errors>> dup empty? [ drop ] [
    - [
  • message>> escape-string write
    • ] each + [
  • escape-string write
    • ] each
] if ; CHLOE: validation-messages drop render-validation-messages ; -TUPLE: action rest init display validate submit ; +TUPLE: action rest authorize init display validate submit ; : new-action ( class -- action ) - new - [ ] >>init - [ <400> ] >>display - [ ] >>validate - [ <400> ] >>submit ; + new [ ] >>init [ ] >>validate [ ] >>authorize ; inline : ( -- action ) action new-action ; -: flashed-variables ( -- seq ) - { validation-messages named-validation-messages } ; +: set-nested-form ( form name -- ) + dup empty? [ + drop form set + ] [ + dup length 1 = [ + first set-value + ] [ + unclip [ set-nested-form ] nest-form + ] if + ] if ; + +: restore-validation-errors ( -- ) + form fget [ + nested-forms fget set-nested-form + ] when* ; : handle-get ( action -- response ) '[ - , - [ init>> call ] - [ drop flashed-variables restore-flash ] - [ display>> call ] - tri + , dup display>> [ + { + [ init>> call ] + [ authorize>> call ] + [ drop restore-validation-errors ] + [ display>> call ] + } cleave + ] [ drop <400> ] if ] with-exit-continuation ; -: validation-failed ( -- * ) - request get method>> "POST" = [ f ] [ <400> ] if exit-with ; - -: (handle-post) ( action -- response ) - [ validate>> call ] [ submit>> call ] bi ; - : param ( name -- value ) params get at ; : revalidate-url-key "__u" ; -: check-url ( url -- ? ) - request get url>> - [ [ protocol>> ] [ host>> ] [ port>> ] tri 3array ] bi@ = ; - : revalidate-url ( -- url/f ) - revalidate-url-key param dup [ >url dup check-url swap and ] when ; + revalidate-url-key param + dup [ >url [ same-host? ] keep and ] when ; + +: validation-failed ( -- * ) + post-request? revalidate-url and + [ + nested-forms-key param " " split harvest nested-forms set + { form nested-forms } + ] [ <400> ] if* + exit-with ; : handle-post ( action -- response ) '[ - form-nesting-key params get at " " split - [ , (handle-post) ] - [ swap '[ , , nest-values ] ] reduce - call - ] with-exit-continuation - [ - revalidate-url - [ flashed-variables ] [ <403> ] if* - ] unless* ; + , dup submit>> [ + [ validate>> call ] + [ authorize>> call ] + [ submit>> call ] + tri + ] [ drop <400> ] if + ] with-exit-continuation ; : handle-rest ( path action -- assoc ) rest>> dup [ [ "/" join ] dip associate ] [ 2drop f ] if ; : init-action ( path action -- ) - blank-values - init-validation + begin-form handle-rest request get request-params assoc-union params set ; @@ -107,8 +116,7 @@ M: action modify-form validation-failed? [ validation-failed ] when ; : validate-params ( validators -- ) - params get swap validate-values from-object - check-validation ; + params get swap validate-values check-validation ; : validate-integer-id ( -- ) { { "id" [ v-number ] } } validate-params ; diff --git a/extra/furnace/alloy/alloy.factor b/extra/furnace/alloy/alloy.factor new file mode 100644 index 0000000000..28c34e6715 --- /dev/null +++ b/extra/furnace/alloy/alloy.factor @@ -0,0 +1,32 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: kernel sequences db.tuples alarms calendar db fry +furnace.cache +furnace.asides +furnace.flash +furnace.sessions +furnace.referrer +furnace.db +furnace.auth.providers +furnace.auth.login.permits ; +IN: furnace.alloy + +: ( responder db params -- responder' ) + '[ + + + + , , + + ] call ; + +: state-classes { session flash-scope aside permit } ; inline + +: init-furnace-tables ( -- ) + state-classes ensure-tables + user ensure-table ; + +: start-expiring ( db params -- ) + '[ + , , [ state-classes [ expire-state ] each ] with-db + ] 5 minutes every drop ; diff --git a/extra/furnace/asides/asides.factor b/extra/furnace/asides/asides.factor index f6b4e2c15f..9f1411188c 100644 --- a/extra/furnace/asides/asides.factor +++ b/extra/furnace/asides/asides.factor @@ -2,37 +2,60 @@ ! See http://factorcode.org/license.txt for BSD license. USING: accessors namespaces sequences arrays kernel assocs assocs.lib hashtables math.parser urls combinators -furnace http http.server http.server.filters furnace.sessions -html.elements html.templates.chloe.syntax ; +html.elements html.templates.chloe.syntax db.types db.tuples +http http.server http.server.filters +furnace furnace.cache furnace.sessions furnace.redirection ; IN: furnace.asides -TUPLE: asides < filter-responder ; +TUPLE: aside < server-state session method url post-data ; -C: asides +: