diff --git a/core/assocs/assocs-tests.factor b/core/assocs/assocs-tests.factor index 30f2ec23c4..43a1bac82d 100755 --- a/core/assocs/assocs-tests.factor +++ b/core/assocs/assocs-tests.factor @@ -104,3 +104,17 @@ unit-test 2drop ] { } make ] unit-test + +[ + H{ + { "bangers" "mash" } + { "fries" "onion rings" } + } +] [ + { "bangers" "fries" } H{ + { "fish" "chips" } + { "bangers" "mash" } + { "fries" "onion rings" } + { "nachos" "cheese" } + } extract-keys +] unit-test diff --git a/core/assocs/assocs.factor b/core/assocs/assocs.factor index 92db38573a..6b0798f2e3 100755 --- a/core/assocs/assocs.factor +++ b/core/assocs/assocs.factor @@ -150,6 +150,9 @@ M: assoc assoc-clone-like ( assoc exemplar -- newassoc ) : map>assoc ( seq quot exemplar -- assoc ) >r [ 2array ] compose { } map-as r> assoc-like ; inline +: extract-keys ( seq assoc -- subassoc ) + [ [ dupd at ] curry ] keep map>assoc ; + M: assoc >alist [ 2array ] { } assoc>map ; : value-at ( value assoc -- key/f ) diff --git a/core/classes/classes-tests.factor b/core/classes/classes-tests.factor index bb9fbd0167..eb55b5fccd 100755 --- a/core/classes/classes-tests.factor +++ b/core/classes/classes-tests.factor @@ -160,3 +160,12 @@ TUPLE: flat-mx-2-1 ; INSTANCE: flat-mx-2-1 flat-mx-2 [ t ] [ 3 number instance? ] unit-test [ f ] [ 3 null instance? ] unit-test [ t ] [ "hi" \ hi-tag instance? ] unit-test + +! Regression +GENERIC: method-forget-test +TUPLE: method-forget-class ; +M: method-forget-class method-forget-test ; + +[ f ] [ \ method-forget-test "methods" word-prop assoc-empty? ] unit-test +[ ] [ [ \ method-forget-class forget ] with-compilation-unit ] unit-test +[ t ] [ \ method-forget-test "methods" word-prop assoc-empty? ] unit-test diff --git a/core/classes/tuple/tuple-tests.factor b/core/classes/tuple/tuple-tests.factor index 0cf7ea3510..ab6c139f7b 100755 --- a/core/classes/tuple/tuple-tests.factor +++ b/core/classes/tuple/tuple-tests.factor @@ -4,7 +4,7 @@ namespaces quotations sequences.private classes continuations generic.standard effects classes.tuple classes.tuple.private arrays vectors strings compiler.units accessors classes.algebra calendar prettyprint io.streams.string splitting inspector -columns math.order ; +columns math.order classes.private ; IN: classes.tuple.tests TUPLE: rect x y w h ; @@ -543,6 +543,7 @@ TUPLE: another-forget-accessors-test ; ! Missing error check [ "IN: classes.tuple.tests USE: words TUPLE: wrong-superclass < word ;" eval ] must-fail +! Class forget messyness TUPLE: subclass-forget-test ; TUPLE: subclass-forget-test-1 < subclass-forget-test ; @@ -551,6 +552,14 @@ TUPLE: subclass-forget-test-3 < subclass-forget-test-2 ; [ ] [ "IN: classes.tuple.tests FORGET: subclass-forget-test" eval ] unit-test +[ H{ { subclass-forget-test-2 subclass-forget-test-2 } } ] +[ subclass-forget-test-2 class-usages ] +unit-test + +[ H{ { subclass-forget-test-3 subclass-forget-test-3 } } ] +[ subclass-forget-test-3 class-usages ] +unit-test + [ f ] [ subclass-forget-test-1 tuple-class? ] unit-test [ f ] [ subclass-forget-test-2 tuple-class? ] unit-test [ subclass-forget-test-3 new ] must-fail diff --git a/core/classes/tuple/tuple.factor b/core/classes/tuple/tuple.factor index f4054c8468..4e6ce0d2bb 100755 --- a/core/classes/tuple/tuple.factor +++ b/core/classes/tuple/tuple.factor @@ -226,12 +226,6 @@ M: tuple-class reset-class } reset-props ] bi ; -: reset-tuple-class ( class -- ) - [ [ reset-class ] [ update-map- ] bi ] each-subclass ; - -M: tuple-class forget* - [ reset-tuple-class ] [ call-next-method ] bi ; - M: tuple-class rank-class drop 0 ; M: tuple clone diff --git a/core/combinators/combinators.factor b/core/combinators/combinators.factor index d33edfab30..f6873429fe 100755 --- a/core/combinators/combinators.factor +++ b/core/combinators/combinators.factor @@ -95,10 +95,10 @@ M: hashtable hashcode* : (distribute-buckets) ( buckets pair keys -- ) dup t eq? [ - drop [ swap push-new ] curry each + drop [ swap adjoin ] curry each ] [ [ - >r 2dup r> hashcode pick length rem rot nth push-new + >r 2dup r> hashcode pick length rem rot nth adjoin ] each 2drop ] if ; diff --git a/core/compiler/units/units.factor b/core/compiler/units/units.factor index a31cd8de16..c2e84429cf 100755 --- a/core/compiler/units/units.factor +++ b/core/compiler/units/units.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: kernel continuations assocs namespaces sequences words -vocabs definitions hashtables init ; +vocabs definitions hashtables init sets ; IN: compiler.units SYMBOL: old-definitions @@ -14,7 +14,7 @@ TUPLE: redefine-error def ; { { "Continue" t } } throw-restarts drop ; : add-once ( key assoc -- ) - 2dup key? [ over redefine-error ] when dupd set-at ; + 2dup key? [ over redefine-error ] when conjoin ; : (remember-definition) ( definition loc assoc -- ) >r over set-where r> add-once ; @@ -83,7 +83,14 @@ SYMBOL: update-tuples-hook call-recompile-hook call-update-tuples-hook dup [ drop compiled-crossref? ] assoc-contains? modify-code-heap - updated-definitions notify-definition-observers ; + ; + +: with-nested-compilation-unit ( quot -- ) + [ + H{ } clone changed-definitions set + H{ } clone outdated-tuples set + [ finish-compilation-unit ] [ ] cleanup + ] with-scope ; inline : with-compilation-unit ( quot -- ) [ @@ -92,8 +99,11 @@ SYMBOL: update-tuples-hook H{ } clone outdated-tuples set new-definitions set old-definitions set - [ finish-compilation-unit ] - [ ] cleanup + [ + finish-compilation-unit + updated-definitions + notify-definition-observers + ] [ ] cleanup ] with-scope ; inline : compile-call ( quot -- ) diff --git a/core/generator/fixup/fixup.factor b/core/generator/fixup/fixup.factor index 06895cd8ac..b38d70fb80 100755 --- a/core/generator/fixup/fixup.factor +++ b/core/generator/fixup/fixup.factor @@ -102,13 +102,13 @@ M: frame-required fixup* drop ; M: integer fixup* , ; -: push-new* ( obj table -- n ) +: adjoin* ( obj table -- n ) 2dup swap [ eq? ] curry find drop [ 2nip ] [ dup length >r push r> ] if* ; SYMBOL: literal-table -: add-literal ( obj -- n ) literal-table get push-new* ; +: add-literal ( obj -- n ) literal-table get adjoin* ; : add-dlsym-literals ( symbol dll -- ) >r string>symbol r> 2array literal-table get push-all ; diff --git a/core/generic/generic.factor b/core/generic/generic.factor index e446689303..b9a556e316 100755 --- a/core/generic/generic.factor +++ b/core/generic/generic.factor @@ -147,12 +147,16 @@ M: method-body forget* [ implementors ] [ [ swap 2array ] curry ] bi map forget-all ; M: class forget* ( class -- ) - { - [ forget-methods ] - [ update-map- ] - [ reset-class ] - [ call-next-method ] - } cleave ; + [ + class-usages [ + drop + [ forget-methods ] + [ update-map- ] + [ reset-class ] + tri + ] assoc-each + ] + [ call-next-method ] bi ; M: assoc update-methods ( assoc -- ) implementors* [ make-generic ] each ; diff --git a/core/generic/standard/engines/predicate/predicate.factor b/core/generic/standard/engines/predicate/predicate.factor index b1bfc659df..9c810592a0 100644 --- a/core/generic/standard/engines/predicate/predicate.factor +++ b/core/generic/standard/engines/predicate/predicate.factor @@ -22,8 +22,7 @@ C: predicate-dispatch-engine } cond ; : sort-methods ( assoc -- assoc' ) - [ keys sort-classes ] - [ [ dupd at ] curry ] bi { } map>assoc ; + >alist [ keys sort-classes ] keep extract-keys ; M: predicate-dispatch-engine engine>quot methods>> clone diff --git a/core/inference/class/class.factor b/core/inference/class/class.factor index 933710aaca..dc632425fe 100755 --- a/core/inference/class/class.factor +++ b/core/inference/class/class.factor @@ -152,16 +152,16 @@ M: pair apply-constraint M: pair constraint-satisfied? first constraint-satisfied? ; -: extract-keys ( seq assoc -- newassoc ) - [ dupd at ] curry H{ } map>assoc [ nip ] assoc-filter f assoc-like ; +: valid-keys ( seq assoc -- newassoc ) + extract-keys [ nip ] assoc-filter f assoc-like ; : annotate-node ( node -- ) #! Annotate the node with the currently-inferred set of #! value classes. dup node-values { - [ value-intervals get extract-keys >>intervals ] - [ value-classes get extract-keys >>classes ] - [ value-literals get extract-keys >>literals ] + [ value-intervals get valid-keys >>intervals ] + [ value-classes get valid-keys >>classes ] + [ value-literals get valid-keys >>literals ] [ 2drop ] } cleave ; @@ -330,7 +330,7 @@ M: #return infer-classes-around [ ] [ node-input-classes ] [ in-d>> [ value-class* ] map ] tri classes= not [ fixed-point? off - [ in-d>> value-classes get extract-keys ] keep + [ in-d>> value-classes get valid-keys ] keep set-node-classes ] [ drop ] if ] [ call-next-method ] if diff --git a/core/parser/parser-tests.factor b/core/parser/parser-tests.factor index 3df9dc9cb2..df6c9dadc5 100755 --- a/core/parser/parser-tests.factor +++ b/core/parser/parser-tests.factor @@ -460,3 +460,30 @@ must-fail-with "change-combination" "parser.tests" lookup "methods" word-prop assoc-size ] unit-test + +[ ] [ + 2 [ + "IN: parser.tests DEFER: twice-fails FORGET: twice-fails MIXIN: twice-fails" + "twice-fails-test" parse-stream drop + ] times +] unit-test + +[ [ ] ] [ + "IN: parser.tests : staging-problem-test-1 1 ; : staging-problem-test-2 staging-problem-test-1 ;" + "staging-problem-test" parse-stream +] unit-test + +[ t ] [ "staging-problem-test-1" "parser.tests" lookup >boolean ] unit-test + +[ t ] [ "staging-problem-test-2" "parser.tests" lookup >boolean ] unit-test + +[ [ ] ] [ + "IN: parser.tests << : staging-problem-test-1 1 ; >> : staging-problem-test-2 staging-problem-test-1 ;" + "staging-problem-test" parse-stream +] unit-test + +[ t ] [ "staging-problem-test-1" "parser.tests" lookup >boolean ] unit-test + +[ t ] [ "staging-problem-test-2" "parser.tests" lookup >boolean ] unit-test + +[ "DEFER: blah" eval ] [ error>> no-current-vocab? ] must-fail-with diff --git a/core/parser/parser.factor b/core/parser/parser.factor index f08ba8fbc2..46e93753b5 100755 --- a/core/parser/parser.factor +++ b/core/parser/parser.factor @@ -236,7 +236,7 @@ PREDICATE: unexpected-eof < unexpected ERROR: no-current-vocab ; M: no-current-vocab summary ( obj -- ) - drop "Current vocabulary is f, use IN:" ; + drop "Not in a vocabulary; IN: form required" ; : current-vocab ( -- str ) in get [ no-current-vocab ] unless* ; @@ -357,10 +357,9 @@ M: staging-violation summary "A parsing word cannot be used in the same file it is defined in." ; : execute-parsing ( word -- ) - new-definitions get [ - dupd first key? [ staging-violation ] when - ] when* - execute ; + [ changed-definitions get key? [ staging-violation ] when ] + [ execute ] + bi ; : parse-step ( accum end -- accum ? ) scan-word { diff --git a/core/prettyprint/prettyprint-tests.factor b/core/prettyprint/prettyprint-tests.factor index ed6b2f3c3c..f5ec263f11 100755 --- a/core/prettyprint/prettyprint-tests.factor +++ b/core/prettyprint/prettyprint-tests.factor @@ -342,3 +342,5 @@ INTERSECTION: intersection-see-test sequence number ; [ ] [ \ compose see ] unit-test [ ] [ \ curry see ] unit-test + +[ "POSTPONE: [" ] [ \ [ unparse ] unit-test diff --git a/core/sequences/sequences-docs.factor b/core/sequences/sequences-docs.factor index 351ba89692..2c1a3b8ab9 100755 --- a/core/sequences/sequences-docs.factor +++ b/core/sequences/sequences-docs.factor @@ -191,7 +191,6 @@ $nl "Other destructive words:" { $subsection move } { $subsection exchange } -{ $subsection push-new } { $subsection copy } { $subsection replace-slice } { $see-also set-nth push pop "sequences-stacks" } ; @@ -624,22 +623,7 @@ HELP: replace-slice { $errors "Throws an error if " { $snippet "new" } " contains elements whose types are not permissible in " { $snippet "seq" } "." } { $side-effects "seq" } ; -HELP: push-new -{ $values { "elt" object } { "seq" "a resizable mutable sequence" } } -{ $description "Removes all elements equal to " { $snippet "elt" } ", and adds " { $snippet "elt" } " at the end of the sequence." } -{ $examples - { $example - "USING: namespaces prettyprint sequences ;" - "V{ \"beans\" \"salsa\" \"cheese\" } \"v\" set" - "\"nachos\" \"v\" get push-new" - "\"salsa\" \"v\" get push-new" - "\"v\" get ." - "V{ \"beans\" \"cheese\" \"nachos\" \"salsa\" }" - } -} -{ $side-effects "seq" } ; - -{ push push-new prefix suffix } related-words +{ push prefix suffix } related-words HELP: suffix { $values { "seq" sequence } { "elt" object } { "newseq" sequence } } diff --git a/core/sequences/sequences-tests.factor b/core/sequences/sequences-tests.factor index 2479c125a2..81384a40c4 100755 --- a/core/sequences/sequences-tests.factor +++ b/core/sequences/sequences-tests.factor @@ -215,12 +215,6 @@ unit-test 3 V{ 1 2 3 4 5 6 } clone [ delete-nth ] keep ] unit-test -[ V{ 1 2 3 } ] -[ 3 V{ 1 2 } clone [ push-new ] keep ] unit-test - -[ V{ 1 2 3 } ] -[ 3 V{ 1 3 2 } clone [ push-new ] keep ] unit-test - ! erg's random tester found this one [ SBUF" 12341234" ] [ 9 dup "1234" swap push-all dup dup swap push-all diff --git a/core/sequences/sequences.factor b/core/sequences/sequences.factor index cbddfa7d28..4854ff8001 100755 --- a/core/sequences/sequences.factor +++ b/core/sequences/sequences.factor @@ -499,8 +499,6 @@ M: slice equal? over slice? [ sequence= ] [ 2drop f ] if ; : delete ( elt seq -- ) 0 0 rot (delete) nip set-length drop ; -: push-new ( elt seq -- ) [ delete ] 2keep push ; - : prefix ( seq elt -- newseq ) over >r over length 1+ r> [ [ 0 swap set-nth-unsafe ] keep @@ -680,7 +678,7 @@ PRIVATE> : unclip ( seq -- rest first ) [ rest ] [ first ] bi ; -: unclip-last ( seq -- butfirst last ) +: unclip-last ( seq -- butlast last ) [ but-last ] [ peek ] bi ; : unclip-slice ( seq -- rest first ) diff --git a/core/sets/sets-docs.factor b/core/sets/sets-docs.factor index f4e2557a71..205d4d34bf 100644 --- a/core/sets/sets-docs.factor +++ b/core/sets/sets-docs.factor @@ -16,10 +16,28 @@ $nl { $subsection set= } "A word used to implement the above:" { $subsection unique } +"Adding elements to sets:" +{ $subsection adjoin } +{ $subsection conjoin } { $see-also member? memq? contains? all? "assocs-sets" } ; ABOUT: "sets" +HELP: adjoin +{ $values { "elt" object } { "seq" "a resizable mutable sequence" } } +{ $description "Removes all elements equal to " { $snippet "elt" } ", and adds " { $snippet "elt" } " at the end of the sequence." } +{ $examples + { $example + "USING: namespaces prettyprint sets ;" + "V{ \"beans\" \"salsa\" \"cheese\" } \"v\" set" + "\"nachos\" \"v\" get adjoin" + "\"salsa\" \"v\" get adjoin" + "\"v\" get ." + "V{ \"beans\" \"cheese\" \"nachos\" \"salsa\" }" + } +} +{ $side-effects "seq" } ; + HELP: unique { $values { "seq" "a sequence" } { "assoc" "an assoc" } } { $description "Outputs a new assoc where the keys and values are equal." } diff --git a/core/sets/sets-tests.factor b/core/sets/sets-tests.factor index 86ee100da5..b6e6443afa 100644 --- a/core/sets/sets-tests.factor +++ b/core/sets/sets-tests.factor @@ -15,3 +15,9 @@ IN: sets.tests [ V{ } ] [ { } { } union ] unit-test [ V{ 1 2 3 4 } ] [ { 1 2 3 } { 2 3 4 } union ] unit-test + +[ V{ 1 2 3 } ] +[ 3 V{ 1 2 } clone [ adjoin ] keep ] unit-test + +[ V{ 1 2 3 } ] +[ 3 V{ 1 3 2 } clone [ adjoin ] keep ] unit-test diff --git a/core/sets/sets.factor b/core/sets/sets.factor index b0d26e0f30..5fbec9a7c8 100644 --- a/core/sets/sets.factor +++ b/core/sets/sets.factor @@ -3,10 +3,14 @@ USING: assocs hashtables kernel sequences vectors ; IN: sets +: adjoin ( elt seq -- ) [ delete ] [ push ] 2bi ; + +: conjoin ( elt assoc -- ) dupd set-at ; + : (prune) ( elt hash vec -- ) - 3dup drop key? - [ [ drop dupd set-at ] [ nip push ] [ ] 3tri ] unless - 3drop ; inline + 3dup drop key? [ 3drop ] [ + [ drop conjoin ] [ nip push ] 3bi + ] if ; inline : prune ( seq -- newseq ) [ ] [ length ] [ length ] tri @@ -16,7 +20,7 @@ IN: sets [ dup ] H{ } map>assoc ; : (all-unique?) ( elt hash -- ? ) - 2dup key? [ 2drop f ] [ dupd set-at t ] if ; + 2dup key? [ 2drop f ] [ conjoin t ] if ; : all-unique? ( seq -- ? ) dup length [ (all-unique?) ] curry all? ; diff --git a/core/splitting/splitting-docs.factor b/core/splitting/splitting-docs.factor index 5000dbf5fd..1beafc710a 100644 --- a/core/splitting/splitting-docs.factor +++ b/core/splitting/splitting-docs.factor @@ -1,6 +1,25 @@ USING: help.markup help.syntax sequences strings ; IN: splitting +ARTICLE: "groups-clumps" "Groups and clumps" +"A virtual sequence for splitting a sequence into disjoint, fixed-length subsequences:" +{ $subsection groups } +{ $subsection } +{ $subsection } +"A virtual sequence for splitting a sequence into overlapping, fixed-length subsequences:" +{ $subsection clumps } +{ $subsection } +{ $subsection } +"The difference can be summarized as the following:" +{ $list + { "With groups, the subsequences form the original sequence when concatenated:" + { $unchecked-example "dup n groups concat sequence= ." "t" } + } + { "With clumps, collecting the first element of each subsequence but the last one, together with the last subseqence, yields the original sequence:" + { $unchecked-example "dup n clumps unclip-last >r [ first ] map r> append sequence= ." "t" } + } +} ; + ARTICLE: "sequences-split" "Splitting sequences" "Splitting sequences at occurrences of subsequences:" { $subsection ?head } @@ -9,14 +28,9 @@ ARTICLE: "sequences-split" "Splitting sequences" { $subsection ?tail-slice } { $subsection split1 } { $subsection split } -"Grouping elements:" -{ $subsection group } -"A virtual sequence for grouping elements:" -{ $subsection groups } -{ $subsection } -{ $subsection } "Splitting a string into lines:" -{ $subsection string-lines } ; +{ $subsection string-lines } +{ $subsection "groups-clumps" } ; ABOUT: "sequences-split" @@ -36,19 +50,22 @@ HELP: split { $examples { $example "USING: prettyprint splitting ;" "\"hello world-how are you?\" \" -\" split ." "{ \"hello\" \"world\" \"how\" \"are\" \"you?\" }" } } ; HELP: groups -{ $class-description "Instances are virtual sequences whose elements are fixed-length subsequences or slices of an underlying sequence. Groups are mutable and resizable if the underlying sequence is mutable and resizable, respectively." +{ $class-description "Instances are virtual sequences whose elements are disjoint fixed-length subsequences of an underlying sequence. Groups are mutable and resizable if the underlying sequence is mutable and resizable, respectively." $nl "New groups are created by calling " { $link } " and " { $link } "." } { $see-also group } ; HELP: group { $values { "seq" "a sequence" } { "n" "a non-negative integer" } { "array" "a sequence of sequences" } } -{ $description "Splits the sequence into groups of " { $snippet "n" } " elements and collects the groups into a new array." } -{ $notes "If the sequence length is not a multiple of " { $snippet "n" } ", the final subsequence in the list will be shorter than " { $snippet "n" } " elements." } ; +{ $description "Splits the sequence into disjoint groups of " { $snippet "n" } " elements and collects the groups into a new array." } +{ $notes "If the sequence length is not a multiple of " { $snippet "n" } ", the final subsequence in the list will be shorter than " { $snippet "n" } " elements." } +{ $examples + { $example "USING: splitting prettyprint ;" "{ 3 1 3 3 7 } 2 group ." "{ { 3 1 } { 3 3 } { 7 } }" } +} ; HELP: { $values { "seq" "a sequence" } { "n" "a non-negative integer" } { "groups" groups } } -{ $description "Outputs a virtual sequence whose elements are subsequences consisting of groups of " { $snippet "n" } " elements from the underlying sequence." } +{ $description "Outputs a virtual sequence whose elements are disjoint subsequences of " { $snippet "n" } " elements from the underlying sequence." } { $examples { $example "USING: arrays kernel prettyprint sequences splitting ;" @@ -58,7 +75,7 @@ HELP: HELP: { $values { "seq" "a sequence" } { "n" "a non-negative integer" } { "groups" groups } } -{ $description "Outputs a virtual sequence whose elements are slices consisting of groups of " { $snippet "n" } " elements from the underlying sequence." } +{ $description "Outputs a virtual sequence whose elements are overlapping subsequences of " { $snippet "n" } " elements from the underlying sequence." } { $examples { $example "USING: arrays kernel prettyprint sequences splitting ;" @@ -68,7 +85,46 @@ HELP: } } ; -{ group } related-words +HELP: clumps +{ $class-description "Instances are virtual sequences whose elements are overlapping fixed-length subsequences o an underlying sequence. Clumps are mutable and resizable if the underlying sequence is mutable and resizable, respectively." +$nl +"New clumps are created by calling " { $link } " and " { $link } "." } ; + +HELP: clump +{ $values { "seq" "a sequence" } { "n" "a non-negative integer" } { "array" "a sequence of sequences" } } +{ $description "Splits the sequence into overlapping clumps of " { $snippet "n" } " elements and collects the clumps into a new array." } +{ $errors "Throws an error if " { $snippet "n" } " is smaller than the length of the sequence." } +{ $examples + { $example "USING: splitting prettyprint ;" "{ 3 1 3 3 7 } 2 clump ." "{ { 3 1 } { 1 3 } { 3 3 } { 3 7 } }" } +} ; + +HELP: +{ $values { "seq" "a sequence" } { "n" "a non-negative integer" } { "clumps" clumps } } +{ $description "Outputs a virtual sequence whose elements are overlapping subsequences of " { $snippet "n" } " elements from the underlying sequence." } +{ $examples + "Running averages:" + { $example + "USING: splitting sequences math prettyprint kernel ;" + "IN: scratchpad" + ": share-price" + " { 13/50 51/100 13/50 1/10 4/5 17/20 33/50 3/25 19/100 3/100 } ;" + "" + "share-price 4 [ [ sum ] [ length ] bi / ] map ." + "{ 113/400 167/400 201/400 241/400 243/400 91/200 1/4 }" + } +} ; + +HELP: +{ $values { "seq" "a sequence" } { "n" "a non-negative integer" } { "clumps" clumps } } +{ $description "Outputs a virtual sequence whose elements are overlapping slices of " { $snippet "n" } " elements from the underlying sequence." } ; + +{ clumps groups } related-words + +{ clump group } related-words + +{ } related-words + +{ } related-words HELP: ?head { $values { "seq" "a sequence" } { "begin" "a sequence" } { "newseq" "a new sequence" } { "?" "a boolean" } } diff --git a/core/splitting/splitting.factor b/core/splitting/splitting.factor index 9f6ae75d32..62e7ef3782 100755 --- a/core/splitting/splitting.factor +++ b/core/splitting/splitting.factor @@ -44,7 +44,7 @@ M: sliced-groups nth group@ ; TUPLE: clumps < abstract-groups ; -: ( seq n -- groups ) +: ( seq n -- clumps ) clumps construct-groups ; inline M: clumps length @@ -58,7 +58,7 @@ M: clumps group@ TUPLE: sliced-clumps < groups ; -: ( seq n -- groups ) +: ( seq n -- clumps ) sliced-clumps construct-groups ; inline M: sliced-clumps nth group@ ; diff --git a/core/syntax/syntax.factor b/core/syntax/syntax.factor index 2410185b18..27c8609a99 100755 --- a/core/syntax/syntax.factor +++ b/core/syntax/syntax.factor @@ -100,8 +100,8 @@ IN: bootstrap.syntax ] define-syntax "DEFER:" [ - scan in get create - dup old-definitions get first delete-at + scan current-vocab create + dup old-definitions get [ delete-at ] with each set-word ] define-syntax @@ -189,8 +189,9 @@ IN: bootstrap.syntax "MAIN:" [ scan-word in get vocab set-vocab-main ] define-syntax "<<" [ - [ \ >> parse-until >quotation ] with-compilation-unit - call + [ + \ >> parse-until >quotation + ] with-nested-compilation-unit call ] define-syntax "call-next-method" [ diff --git a/core/words/words.factor b/core/words/words.factor index 5812516912..5549f98010 100755 --- a/core/words/words.factor +++ b/core/words/words.factor @@ -175,7 +175,9 @@ PRIVATE> : define-symbol ( word -- ) dup [ ] curry define-inline ; -: reset-word ( word -- ) +GENERIC: reset-word ( word -- ) + +M: word reset-word { "unannotated-def" "parsing" "inline" "foldable" "flushable" diff --git a/extra/assocs/lib/lib.factor b/extra/assocs/lib/lib.factor index 7c274edb2e..c3e487a9fc 100755 --- a/extra/assocs/lib/lib.factor +++ b/extra/assocs/lib/lib.factor @@ -1,5 +1,5 @@ USING: arrays assocs kernel vectors sequences namespaces -random math.parser ; +random math.parser math fry ; IN: assocs.lib : ref-at ( table key -- value ) swap at ; @@ -40,3 +40,8 @@ IN: assocs.lib : set-at-unique ( value assoc -- key ) dup generate-key [ swap set-at ] keep ; + +: histogram ( assoc quot -- assoc' ) + H{ } clone [ + swap [ change-at ] 2curry assoc-each + ] keep ; diff --git a/extra/cairo/pango/gadgets/gadgets.factor b/extra/cairo/pango/gadgets/gadgets.factor new file mode 100644 index 0000000000..780881e872 --- /dev/null +++ b/extra/cairo/pango/gadgets/gadgets.factor @@ -0,0 +1,20 @@ +USING: cairo.pango cairo cairo.ffi cairo.gadgets +alien.c-types kernel math ; +IN: cairo.pango.gadgets + +: (pango-gadget) ( setup show -- gadget ) + [ drop layout-size ] + [ compose [ with-pango ] curry ] 2bi ; + +: ( quot -- gadget ) + [ cr layout pango_cairo_show_layout ] (pango-gadget) ; + +USING: prettyprint sequences ui.gadgets.panes ; +: hello-pango ( -- ) + 50 [ 6 + ] map [ + "Sans Bold " swap unparse append + [ layout-font "Hello, Pango!" layout-text ] curry + gadget. + ] each ; + +MAIN: hello-pango diff --git a/extra/cairo/pango/pango.factor b/extra/cairo/pango/pango.factor new file mode 100644 index 0000000000..789044f6e1 --- /dev/null +++ b/extra/cairo/pango/pango.factor @@ -0,0 +1,175 @@ +! Copyright (C) 2008 Matthew Willis. +! See http://factorcode.org/license.txt for BSD license. +! +! pangocairo bindings, from pango/pangocairo.h + +USING: cairo.ffi alien.c-types math +alien.syntax system combinators alien ; +IN: cairo.pango + +<< "pangocairo" { +! { [ os winnt? ] [ "libpangocairo-1.dll" ] } +! { [ os macosx? ] [ "libpangocairo.dylib" ] } + { [ os unix? ] [ "libpangocairo-1.0.so" ] } +} cond "cdecl" add-library >> + +LIBRARY: pangocairo + +TYPEDEF: void* PangoCairoFont +TYPEDEF: void* PangoCairoFontMap +TYPEDEF: void* PangoFontMap + +FUNCTION: PangoFontMap* +pango_cairo_font_map_new ( ) ; + +FUNCTION: PangoFontMap* +pango_cairo_font_map_new_for_font_type ( cairo_font_type_t fonttype ) ; + +FUNCTION: PangoFontMap* +pango_cairo_font_map_get_default ( ) ; + +FUNCTION: cairo_font_type_t +pango_cairo_font_map_get_font_type ( PangoCairoFontMap* fontmap ) ; + +FUNCTION: void +pango_cairo_font_map_set_resolution ( PangoCairoFontMap* fontmap, double dpi ) ; + +FUNCTION: double +pango_cairo_font_map_get_resolution ( PangoCairoFontMap* fontmap ) ; + +FUNCTION: PangoContext* +pango_cairo_font_map_create_context ( PangoCairoFontMap* fontmap ) ; + +FUNCTION: cairo_scaled_font_t* +pango_cairo_font_get_scaled_font ( PangoCairoFont* font ) ; + +! Update a Pango context for the current state of a cairo context +FUNCTION: void +pango_cairo_update_context ( cairo_t* cr, PangoContext* context ) ; + +FUNCTION: void +pango_cairo_context_set_font_options ( PangoContext* context, cairo_font_options_t* options ) ; + +FUNCTION: cairo_font_options_t* +pango_cairo_context_get_font_options ( PangoContext* context ) ; + +FUNCTION: void +pango_cairo_context_set_resolution ( PangoContext* context, double dpi ) ; + +FUNCTION: double +pango_cairo_context_get_resolution ( PangoContext* context ) ; + +! Convenience +FUNCTION: PangoLayout* +pango_cairo_create_layout ( cairo_t* cr ) ; + +FUNCTION: void +pango_cairo_update_layout ( cairo_t* cr, PangoLayout* layout ) ; + +! Rendering +FUNCTION: void +pango_cairo_show_glyph_string ( cairo_t* cr, PangoFont* font, PangoGlyphString* glyphs ) ; + +FUNCTION: void +pango_cairo_show_layout_line ( cairo_t* cr, PangoLayoutLine* line ) ; + +FUNCTION: void +pango_cairo_show_layout ( cairo_t* cr, PangoLayout* layout ) ; + +FUNCTION: void +pango_cairo_show_error_underline ( cairo_t* cr, double x, double y, double width, double height ) ; + +! Rendering to a path +FUNCTION: void +pango_cairo_glyph_string_path ( cairo_t* cr, PangoFont* font, PangoGlyphString* glyphs ) ; + +FUNCTION: void +pango_cairo_layout_line_path ( cairo_t* cr, PangoLayoutLine* line ) ; + +FUNCTION: void +pango_cairo_layout_path ( cairo_t* cr, PangoLayout* layout ) ; + +FUNCTION: void +pango_cairo_error_underline_path ( cairo_t* cr, double x, double y, double width, double height ) ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! Helpful functions from other parts of pango +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: PANGO_SCALE 1024 ; + +FUNCTION: void +pango_layout_set_text ( PangoLayout* layout, char* text, int length ) ; + +FUNCTION: char* +pango_layout_get_text ( PangoLayout* layout ) ; + +FUNCTION: void +pango_layout_get_size ( PangoLayout* layout, int* width, int* height ) ; + +TYPEDEF: void* PangoFontDescription + +FUNCTION: PangoFontDescription* +pango_font_description_from_string ( char* str ) ; + +FUNCTION: char* +pango_font_description_to_string ( PangoFontDescription* desc ) ; + +FUNCTION: char* +pango_font_description_to_filename ( PangoFontDescription* desc ) ; + +FUNCTION: void +pango_layout_set_font_description ( PangoLayout* layout, PangoFontDescription* desc ) ; + +FUNCTION: PangoFontDescription* +pango_layout_get_font_description ( PangoLayout* layout ) ; + +FUNCTION: void +pango_layout_get_pixel_size ( PangoLayout* layout, int* width, int* height ) ; + +FUNCTION: void +pango_font_description_free ( PangoFontDescription* desc ) ; + +TYPEDEF: void* gpointer + +FUNCTION: void +g_object_unref ( gpointer object ) ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! Higher level words and combinators +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +USING: destructors accessors namespaces kernel cairo ; + +TUPLE: pango-layout alien ; +C: pango-layout +M: pango-layout dispose ( alien -- ) alien>> g_object_unref ; + +: layout ( -- pango-layout ) pango-layout get ; + +: (with-pango) ( layout quot -- ) + >r alien>> pango-layout r> with-variable ; inline + +: with-pango ( quot -- ) + cr pango_cairo_create_layout swap + [ (with-pango) ] curry with-disposal ; inline + +: pango-layout-get-pixel-size ( layout -- width height ) + 0 0 [ pango_layout_get_pixel_size ] 2keep + [ *int ] bi@ ; + +: dummy-pango ( quot -- ) + >r CAIRO_FORMAT_ARGB32 0 0 cairo_image_surface_create + r> [ with-pango ] curry with-cairo-from-surface ; inline + +: layout-size ( quot -- width height ) + [ layout pango-layout-get-pixel-size ] compose dummy-pango ; inline + +: layout-font ( str -- ) + pango_font_description_from_string + dup zero? [ "pango: not a valid font." throw ] when + layout over pango_layout_set_font_description + pango_font_description_free ; + +: layout-text ( str -- ) + layout swap -1 pango_layout_set_text ; diff --git a/extra/cairo/samples/samples.factor b/extra/cairo/samples/samples.factor index 402c3881f4..3cc63922f8 100644 --- a/extra/cairo/samples/samples.factor +++ b/extra/cairo/samples/samples.factor @@ -116,11 +116,11 @@ IN: cairo.samples cr cairo_fill ; : utf8 ( -- ) - cr "Serif" CAIRO_FONT_SLANT_NORMAL CAIRO_FONT_WEIGHT_NORMAL + cr "Sans" CAIRO_FONT_SLANT_NORMAL CAIRO_FONT_WEIGHT_NORMAL cairo_select_font_face cr 50 cairo_set_font_size "cairo_text_extents_t" malloc-object - cr B{ 230 151 165 230 156 172 232 170 158 } pick cairo_text_extents + cr "日本語" pick cairo_text_extents cr over [ cairo_text_extents_t-width 2 / ] [ cairo_text_extents_t-x_bearing ] bi + @@ -129,7 +129,7 @@ IN: cairo.samples [ cairo_text_extents_t-y_bearing ] bi + 128 swap - cairo_move_to free - cr B{ 230 151 165 230 156 172 232 170 158 } cairo_show_text + cr "日本語" cairo_show_text cr 1 0.2 0.2 0.6 cairo_set_source_rgba cr 6 cairo_set_line_width diff --git a/extra/calendar/format/format-tests.factor b/extra/calendar/format/format-tests.factor index f4e1669178..3efe33e265 100755 --- a/extra/calendar/format/format-tests.factor +++ b/extra/calendar/format/format-tests.factor @@ -50,3 +50,15 @@ IN: calendar.format.tests "Sun May 04 07:00:00 2008 GMT" cookie-string>timestamp timestamp>string ] unit-test + +[ + T{ timestamp f + 2008 + 5 + 26 + 0 + 37 + 42.12345 + T{ duration f 0 0 0 -5 0 0 } + } +] [ "2008-05-26T00:37:42.12345-05:00" rfc3339>timestamp ] unit-test diff --git a/extra/calendar/format/format.factor b/extra/calendar/format/format.factor index 91a034f8bd..ff1811e9d5 100755 --- a/extra/calendar/format/format.factor +++ b/extra/calendar/format/format.factor @@ -1,4 +1,4 @@ -USING: math math.order math.parser kernel sequences io +USING: math math.order math.parser math.functions kernel sequences io accessors arrays io.streams.string splitting combinators accessors debugger calendar calendar.format.macros ; @@ -151,11 +151,15 @@ M: timestamp year. ( timestamp -- ) : read-hms ( -- h m s ) read-00 ":" expect read-00 ":" expect read-00 ; +: read-rfc3339-seconds ( s -- s' ch ) + "+-Z" read-until >r + [ string>number ] [ length 10 swap ^ ] bi / + r> ; + : (rfc3339>timestamp) ( -- timestamp ) read-ymd "Tt" expect read-hms - read1 { { CHAR: . [ read-000 1000 / + read1 ] } [ ] } case + read1 { { CHAR: . [ read-rfc3339-seconds ] } [ ] } case read-rfc3339-gmt-offset ; diff --git a/extra/combinators/lib/lib.factor b/extra/combinators/lib/lib.factor index 4c4a988935..2c7f2bbb03 100755 --- a/extra/combinators/lib/lib.factor +++ b/extra/combinators/lib/lib.factor @@ -77,8 +77,21 @@ 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 -- ? ) + [ [ 2dup ] prepend [ t ] ] f short-circuit [ 2nip ] append ; + ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! ifte ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! diff --git a/extra/db/db.factor b/extra/db/db.factor index 9514f62cf0..4b98612069 100755 --- a/extra/db/db.factor +++ b/extra/db/db.factor @@ -127,7 +127,7 @@ M: nonthrowable execute-statement* ( statement type -- ) : query-map ( statement quot -- seq ) accumulator >r query-each r> { } like ; inline -: with-db ( db seq quot -- ) +: with-db ( seq class quot -- ) >r make-db db-open db r> [ db get swap [ drop ] prepose with-disposal ] curry with-variable ; inline diff --git a/extra/db/pools/pools.factor b/extra/db/pools/pools.factor index 4d201c2edf..63153c451e 100644 --- a/extra/db/pools/pools.factor +++ b/extra/db/pools/pools.factor @@ -6,16 +6,16 @@ IN: db.pools TUPLE: db-pool < pool db params ; -: ( db params -- pool ) +: ( params db -- pool ) db-pool - swap >>params - swap >>db ; + swap >>db + swap >>params ; : with-db-pool ( db params quot -- ) >r r> with-pool ; inline M: db-pool make-connection ( pool -- ) - [ db>> ] [ params>> ] bi make-db db-open ; + [ params>> ] [ db>> ] bi make-db db-open ; : with-pooled-db ( pool quot -- ) [ db swap with-variable ] curry with-pooled-connection ; inline diff --git a/extra/db/tuples/tuples-tests.factor b/extra/db/tuples/tuples-tests.factor index 4da82d92d6..b7c6fce933 100755 --- a/extra/db/tuples/tuples-tests.factor +++ b/extra/db/tuples/tuples-tests.factor @@ -414,6 +414,25 @@ TUPLE: does-not-persist ; [ class \ not-persistent = ] must-fail-with ] test-postgresql + +TUPLE: suparclass a ; + +suparclass f { + { "id" "ID" +db-assigned-id+ } + { "a" "A" INTEGER } +} define-persistent + +TUPLE: subbclass < suparclass b ; + +subbclass "SUBCLASS" { + { "b" "B" TEXT } +} define-persistent + +: test-db-inheritance ( -- ) + [ ] [ subbclass ensure-table ] unit-test ; + +[ test-db-inheritance ] test-sqlite + ! Don't comment these out. These words must infer \ bind-tuple must-infer \ insert-tuple must-infer diff --git a/extra/db/tuples/tuples.factor b/extra/db/tuples/tuples.factor index c940d121bb..0ffbd5bd47 100755 --- a/extra/db/tuples/tuples.factor +++ b/extra/db/tuples/tuples.factor @@ -19,7 +19,7 @@ ERROR: not-persistent ; "db-table" word-prop [ not-persistent ] unless* ; : db-columns ( class -- obj ) - "db-columns" word-prop ; + superclasses [ "db-columns" word-prop ] map concat ; : db-relations ( class -- obj ) "db-relations" word-prop ; diff --git a/extra/dns/cache/cache.factor b/extra/dns/cache/cache.factor index 75bbf9de9d..4167c7b16e 100644 --- a/extra/dns/cache/cache.factor +++ b/extra/dns/cache/cache.factor @@ -68,7 +68,7 @@ SYMBOL: NX : expired? ( entry -- ? ) time>> time->ttl 0 <= ; -: cache-get ( query -- result ) +: cache-get* ( query -- rrs/NX/f ) dup table-get ! query result { { [ dup f = ] [ 2drop f ] } ! not in the cache @@ -80,6 +80,15 @@ SYMBOL: NX ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +ERROR: name-error name ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: cache-get ( query -- rrs/f ) + dup cache-get* dup NX = [ drop name>> name-error ] [ nip ] if ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + : rr->entry ( rr -- entry ) [ ttl>> ttl->time ] [ rdata>> {1} >vector ] bi entry boa ; @@ -110,3 +119,31 @@ SYMBOL: NX : cache-add-rr ( rr -- ) [ rr->query ] [ ] bi cache-add ; : cache-add-rrs ( rrs -- ) [ cache-add-rr ] each ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! cache-name-error +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: message-soa ( message -- rr/soa ) + authority-section>> [ type>> SOA = ] filter 1st ; + +: cache-name-error ( message -- message ) + dup + [ message-query ] [ message-soa ttl>> ] bi + cache-nx ; + +: cache-message-records ( message -- message ) + dup + { + [ answer-section>> cache-add-rrs ] + [ authority-section>> cache-add-rrs ] + [ additional-section>> cache-add-rrs ] + } + cleave ; + +: cache-message ( message -- message ) + dup rcode>> NAME-ERROR = [ cache-name-error ] when + cache-message-records ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + diff --git a/extra/dns/dns.factor b/extra/dns/dns.factor index 560db69bb2..9404ccdad1 100644 --- a/extra/dns/dns.factor +++ b/extra/dns/dns.factor @@ -38,7 +38,7 @@ TUPLE: message ! TYPE ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -SYMBOLS: A NS MD MF CNAME SOA MB MG MR NULL WKS PTR HINFO MINFO MX TXT ; +SYMBOLS: A NS MD MF CNAME SOA MB MG MR NULL WKS PTR HINFO MINFO MX TXT AAAA ; : type-table ( -- table ) { @@ -58,6 +58,7 @@ SYMBOLS: A NS MD MF CNAME SOA MB MG MR NULL WKS PTR HINFO MINFO MX TXT ; { MINFO 14 } { MX 15 } { TXT 16 } + { AAAA 28 } } ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -126,6 +127,8 @@ SYMBOLS: NO-ERROR FORMAT-ERROR SERVER-FAILURE NAME-ERROR NOT-IMPLEMENTED : ip->ba ( ip -- ba ) "." split [ string>number ] map >byte-array ; +: ipv6->ba ( ip -- ba ) ":" split [ 16 base> ] map [ 2 >be ] map concat ; + : label->ba ( label -- ba ) [ >byte-array ] [ length ] bi prefix ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -330,6 +333,13 @@ SYMBOLS: NO-ERROR FORMAT-ERROR SERVER-FAILURE NAME-ERROR NOT-IMPLEMENTED : get-ip ( ba i -- ip ) dup 4 + subseq >array [ number>string ] map "." join ; +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: get-ipv6 ( ba i -- ip ) + dup 16 + subseq 2 group [ be> 16 >base ] map ":" join ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + : get-rdata ( ba i type -- rdata ) { { CNAME [ get-name ] } @@ -338,6 +348,7 @@ SYMBOLS: NO-ERROR FORMAT-ERROR SERVER-FAILURE NAME-ERROR NOT-IMPLEMENTED { MX [ get-mx ] } { SOA [ get-soa ] } { A [ get-ip ] } + { AAAA [ get-ipv6 ] } } case ; @@ -459,4 +470,9 @@ SYMBOLS: NO-ERROR FORMAT-ERROR SERVER-FAILURE NAME-ERROR NOT-IMPLEMENTED : ask ( message -- message ) dns-server ask-server ; -: ( query -- message ) swap {1} >>question-section ; \ No newline at end of file +: query->message ( query -- message ) swap {1} >>question-section ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: message-query ( message -- query ) question-section>> 1st ; + diff --git a/extra/dns/recursive/recursive.factor b/extra/dns/recursive/recursive.factor new file mode 100644 index 0000000000..3a74667845 --- /dev/null +++ b/extra/dns/recursive/recursive.factor @@ -0,0 +1,185 @@ + +USING: kernel continuations + combinators + sequences + math + random + unicode.case + accessors symbols + combinators.lib combinators.cleave + newfx + dns dns.cache ; + +IN: dns.recursive + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: root-dns-servers ( -- servers ) + { + "192.5.5.241" + "192.112.36.4" + "128.63.2.53" + "192.36.148.17" + "192.58.128.30" + "193.0.14.129" + "199.7.83.42" + "202.12.27.33" + "198.41.0.4" + } ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: {name-type-class} ( obj -- seq ) + [ name>> >lower ] [ type>> ] [ class>> ] tri {3} ; + +: rr=query? ( rr query -- ? ) [ {name-type-class} ] bi@ = ; + +: rr-filter ( rrs query -- rrs ) [ rr=query? ] curry filter ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: answer-hits ( message -- rrs ) + [ answer-section>> ] [ message-query ] bi rr-filter ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: name-hits ( message -- rrs ) + [ answer-section>> ] [ message-query clone A >>type ] bi rr-filter ; + +: cname-hits ( message -- rrs ) + [ answer-section>> ] [ message-query clone CNAME >>type ] bi rr-filter ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: authority-hits ( message -- rrs ) + authority-section>> [ type>> NS = ] filter ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +SYMBOLS: ANSWERED NO-NAME-SERVERS UNCLASSIFIED ; + +: classify-message ( message -- symbol ) + { + { [ dup rcode>> NAME-ERROR = ] [ drop NAME-ERROR ] } + { [ dup rcode>> SERVER-FAILURE = ] [ drop SERVER-FAILURE ] } + { [ dup answer-hits empty? not ] [ drop ANSWERED ] } + { [ dup cname-hits empty? not ] [ drop CNAME ] } + { [ dup authority-hits empty? ] [ drop NO-NAME-SERVERS ] } + { [ t ] [ drop UNCLASSIFIED ] } + } + cond ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +DEFER: name->ip + +! : name->ip/f ( name -- ip/f ) [ name->ip ] [ drop f ] recover ; + +! : extract-ns-ips ( message -- ips ) +! authority-hits [ rdata>> name->ip/f ] map [ ] filter ; + +: extract-ns-ips ( message -- ips ) + authority-hits [ rdata>> name->ip ] map [ ] filter ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: (recursive-query) ( query servers -- message ) + dup random ! query servers server + pick query->message 0 >>rd ! query servers server message + over ask-server ! query servers server message + cache-message ! query servers server message + dup classify-message ! query servers server message sym + { + { NAME-ERROR [ -roll 3drop ] } + { ANSWERED [ -roll 3drop ] } + { CNAME [ -roll 3drop ] } + { NO-NAME-SERVERS [ -roll 3drop ] } + { + SERVER-FAILURE + [ + -roll ! message query servers server + remove ! message query servers + dup empty? + [ 2drop ] + [ rot drop (recursive-query) ] + if + ] + } + [ ! query servers server message sym + drop nip nip ! query message + extract-ns-ips ! query ips + (recursive-query) + ] + } + case ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: cdr-name ( name -- name ) dup CHAR: . index 1+ tail ; + +: cache-get-ns ( name -- seq/f ) NS IN query boa cache-get ; + +: name->servers ( name -- servers ) + { + { [ dup "" = ] [ drop root-dns-servers ] } + { [ dup cache-get-ns ] [ cache-get-ns [ rdata>> name->ip ] map ] } + { [ t ] [ cdr-name name->servers ] } + } + cond ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: recursive-query ( query -- message ) + dup name>> name->servers (recursive-query) ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: canonical/cache ( name -- name ) + dup CNAME IN query boa cache-get dup [ nip 1st rdata>> ] [ drop ] if ; + +: name->ip/cache ( name -- ip/f ) + canonical/cache + A IN query boa cache-get dup [ random rdata>> ] [ ] if ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: name-hits? ( message -- message ? ) dup name-hits empty? not ; +: cname-hits? ( message -- message ? ) dup cname-hits empty? not ; + +! : name->ip/server ( name -- ip-or-f ) +! A IN query boa root-dns-servers recursive-query ! message +! { +! { [ name-hits? ] [ name-hits random rdata>> ] } +! { [ cname-hits? ] [ cname-hits random rdata>> name->ip ] } +! { [ t ] [ drop f ] } +! } +! cond ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: name->ip/server ( name -- ip-or-f ) + A IN query boa recursive-query ! message + { + { [ name-hits? ] [ name-hits random rdata>> ] } + { [ cname-hits? ] [ cname-hits random rdata>> name->ip ] } + { [ t ] [ drop f ] } + } + cond ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +! : name->ip ( name -- ip ) +! { [ name->ip/cache ] [ name->ip/server ] [ name-error ] } 1|| ; + +: name->ip ( name -- ip ) + dup name->ip/cache dup + [ nip ] + [ + drop dup name->ip/server dup + [ nip ] + [ drop name-error ] + if + ] + if ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! diff --git a/extra/dns/resolver/resolver.factor b/extra/dns/resolver/resolver.factor index c8a9f22d08..38fe59dc41 100644 --- a/extra/dns/resolver/resolver.factor +++ b/extra/dns/resolver/resolver.factor @@ -62,7 +62,7 @@ IN: dns.resolver ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! : canonical/server ( name -- name ) - dup CNAME IN query boa ask* answer-section>> + dup CNAME IN query boa query->message ask* answer-section>> [ type>> CNAME = ] filter dup empty? not [ nip 1st rdata>> ] [ drop ] @@ -70,7 +70,7 @@ IN: dns.resolver : name->ip/server ( name -- ip ) canonical/server - dup A IN query boa ask* answer-section>> + dup A IN query boa query->message ask* answer-section>> [ type>> A = ] filter dup empty? not [ nip random rdata>> ] [ 2drop f ] diff --git a/extra/farkup/farkup-tests.factor b/extra/farkup/farkup-tests.factor index 9a3862d097..17d286252e 100755 --- a/extra/farkup/farkup-tests.factor +++ b/extra/farkup/farkup-tests.factor @@ -62,12 +62,23 @@ IN: farkup.tests [ "

=

foo

" ] [ "===foo==" convert-farkup ] unit-test [ "

foo

=

" ] [ "=foo==" convert-farkup ] unit-test -[ "
int main()
" ] +[ "
int main()\n
" ] [ "[c{int main()}]" convert-farkup ] unit-test [ "

" ] [ "[[image:lol.jpg]]" convert-farkup ] unit-test [ "

\"teh

" ] [ "[[image:lol.jpg|teh lol]]" convert-farkup ] unit-test -[ "

" ] [ "[[lol.com]]" convert-farkup ] unit-test +[ "

lol.com

" ] [ "[[lol.com]]" convert-farkup ] unit-test [ "

haha

" ] [ "[[lol.com|haha]]" convert-farkup ] unit-test [ ] [ "[{}]" convert-farkup drop ] unit-test + +[ + "

Feature comparison:\n
aFactorJavaLisp
CoolnessYesNoNo
BadassYesNoNo
EnterpriseYesYesNo
KosherYesNoYes

" +] [ "Feature comparison:\n|a|Factor|Java|Lisp|\n|Coolness|Yes|No|No|\n|Badass|Yes|No|No|\n|Enterprise|Yes|Yes|No|\n|Kosher|Yes|No|Yes|\n" convert-farkup ] unit-test + +[ + "

Feature comparison:\n\n
aFactorJavaLisp
CoolnessYesNoNo
BadassYesNoNo
EnterpriseYesYesNo
KosherYesNoYes

" +] [ "Feature comparison:\n\n|a|Factor|Java|Lisp|\n|Coolness|Yes|No|No|\n|Badass|Yes|No|No|\n|Enterprise|Yes|Yes|No|\n|Kosher|Yes|No|Yes|\n" convert-farkup ] unit-test + +[ "

a-b

" ] [ "a-b" convert-farkup ] unit-test +[ "
  • a-b
" ] [ "-a-b" convert-farkup ] unit-test diff --git a/extra/farkup/farkup.factor b/extra/farkup/farkup.factor index 98f0d0245f..1b51bb5752 100755 --- a/extra/farkup/farkup.factor +++ b/extra/farkup/farkup.factor @@ -2,10 +2,13 @@ ! 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 html peg.parsers html.elements +splitting io.streams.string peg.parsers sequences.deep unicode.categories ; IN: farkup +SYMBOL: relative-link-prefix +SYMBOL: link-no-follow? + r string-lines r> [ - [ - H{ { wrap-margin f } } [ - htmlize-lines - ] with-nesting - ] with-html-stream + 
+            htmlize-lines
+
] with-string-writer ; : check-url ( href -- href' ) CHAR: : over member? [ dup { "http://" "https://" "ftp://" } [ head? ] with contains? [ drop "/" ] unless - ] when ; + ] [ + relative-link-prefix get prepend + ] if ; : escape-link ( href text -- href-esc text-esc ) >r check-url escape-quoted-string r> escape-string ; : make-link ( href text -- seq ) escape-link - [ "r , r> "\">" , [ , ] when* "" , ] { } make ; + [ + "r , r> + link-no-follow? get [ " nofollow=\"true\"" , ] when + "\">" , , "" , + ] { } make ; : make-image-link ( href alt -- seq ) escape-link @@ -102,7 +110,7 @@ MEMO: simple-link ( -- parser ) "[[" token hide , [ "|]" member? not ] satisfy repeat1 , "]]" token hide , - ] seq* [ first f make-link ] action ; + ] seq* [ first dup make-link ] action ; MEMO: labelled-link ( -- parser ) [ @@ -113,12 +121,14 @@ MEMO: labelled-link ( -- parser ) "]]" token hide , ] seq* [ first2 make-link ] action ; -MEMO: link ( -- parser ) [ image-link , simple-link , labelled-link , ] choice* ; +MEMO: link ( -- parser ) + [ image-link , simple-link , labelled-link , ] choice* ; DEFER: line MEMO: list-item ( -- parser ) [ - "-" token hide , line , + "-" token hide , ! text , + [ "\r\n" member? not ] satisfy repeat1 [ >string escape-string ] action , ] seq* [ "li" surround-with-foo ] action ; MEMO: list ( -- parser ) @@ -149,6 +159,8 @@ MEMO: code ( -- parser ) MEMO: line ( -- parser ) [ + nl table 2seq , + nl list 2seq , text , strong , emphasis , link , superscript , subscript , inline-code , escaped-char , delimiter , eq , diff --git a/extra/fry/fry-tests.factor b/extra/fry/fry-tests.factor index eb59ffae4e..6d6abba23c 100755 --- a/extra/fry/fry-tests.factor +++ b/extra/fry/fry-tests.factor @@ -52,3 +52,13 @@ sequences ; [ { 1 { 2 { 3 } } } ] [ 1 2 3 '[ , [ , [ , 1array ] call 2array ] call 2array ] call ] unit-test + +{ 1 1 } [ '[ [ [ , ] ] ] ] must-infer-as + +[ { { { 3 } } } ] [ + 3 '[ [ [ , 1array ] call 1array ] call 1array ] call +] unit-test + +[ { { { 3 } } } ] [ + 3 '[ [ [ , 1array ] call 1array ] call 1array ] call +] unit-test diff --git a/extra/fry/fry.factor b/extra/fry/fry.factor index 27a321ed92..4581c048fd 100755 --- a/extra/fry/fry.factor +++ b/extra/fry/fry.factor @@ -46,15 +46,22 @@ DEFER: (shallow-fry) shallow-fry ] if* ; +: fry-specifier? ( obj -- ? ) { , namespaces:, @ } member? ; + +: count-inputs ( quot -- n ) + [ + { + { [ dup callable? ] [ count-inputs ] } + { [ dup fry-specifier? ] [ drop 1 ] } + [ drop 0 ] + } cond + ] map sum ; + : fry ( quot -- quot' ) [ [ dup callable? [ - [ - [ { , namespaces:, @ } member? ] filter length - \ , % - ] - [ fry % ] bi + [ count-inputs \ , % ] [ fry % ] bi ] [ namespaces:, ] if ] each ] [ ] make deep-fry ; diff --git a/extra/html/components/components-tests.factor b/extra/html/components/components-tests.factor new file mode 100644 index 0000000000..1a0f849a8f --- /dev/null +++ b/extra/html/components/components-tests.factor @@ -0,0 +1,180 @@ +IN: html.components.tests +USING: tools.test kernel io.streams.string +io.streams.null accessors inspector html.streams +html.components namespaces ; + +[ ] [ blank-values ] unit-test + +[ ] [ 3 "hi" set-value ] unit-test + +[ 3 ] [ "hi" value ] unit-test + +TUPLE: color red green blue ; + +[ ] [ 1 2 3 color boa from-tuple ] unit-test + +[ 1 ] [ "red" value ] unit-test + +[ ] [ "jimmy" "red" set-value ] unit-test + +[ "123.5" ] [ 123.5 object>string ] unit-test + +[ "jimmy" ] [ + [ + "red" label render + ] with-string-writer +] unit-test + +[ ] [ "" "red" set-value ] unit-test + +[ "<jimmy>" ] [ + [ + "red" label render + ] with-string-writer +] unit-test + +[ "" ] [ + [ + "red" hidden render + ] with-string-writer +] unit-test + +[ ] [ "'jimmy'" "red" set-value ] unit-test + +[ "" ] [ + [ + "red" 5 >>size render + ] with-string-writer +] unit-test + +[ "" ] [ + [ + "red" 5 >>size render + ] with-string-writer +] unit-test + +[ ] [ + [ + "green" ; + +! Choice +TUPLE: choice size multiple choices ; + +: ( -- choice ) + choice new ; + +: render-option ( text selected? -- ) + ; + +: render-options ( options selected -- ) + '[ dup , member? render-option ] each ; + +M: choice render* + ; + +! Checkboxes +TUPLE: checkbox label ; + +: ( -- checkbox ) + checkbox new ; + +M: checkbox render* + + label>> escape-string write + ; + +! Link components +GENERIC: link-title ( obj -- string ) +GENERIC: link-href ( obj -- url ) + +SINGLETON: link + +M: link render* + 2drop + + link-title object>string escape-string write + ; + +! XMode code component +TUPLE: code mode ; + +: ( -- code ) + code new ; + +M: code render* + [ string-lines ] [ drop ] [ mode>> value ] tri* htmlize-lines ; + +! Farkup component +SINGLETON: farkup + +M: farkup render* + 2drop string-lines "\n" join convert-farkup write ; + +! Inspector component +SINGLETON: inspector + +M: inspector render* + 2drop [ describe ] with-html-stream ; + +! Diff component +SINGLETON: comparison + +M: comparison render* + 2drop htmlize-diff ; + +! HTML component +SINGLETON: html + +M: html render* 2drop write ; diff --git a/extra/html/elements/elements-tests.factor b/extra/html/elements/elements-tests.factor index aa6a017540..1178deab38 100644 --- a/extra/html/elements/elements-tests.factor +++ b/extra/html/elements/elements-tests.factor @@ -1,8 +1,5 @@ IN: html.elements.tests -USING: tools.test html html.elements io.streams.string ; - -: make-html-string - [ with-html-stream ] with-string-writer ; +USING: tools.test html.elements io.streams.string ; [ "" ] -[ [ ] make-html-string ] unit-test +[ [ ] with-string-writer ] unit-test diff --git a/extra/html/elements/elements.factor b/extra/html/elements/elements.factor index 49782fa305..e5377cedf8 100644 --- a/extra/html/elements/elements.factor +++ b/extra/html/elements/elements.factor @@ -57,6 +57,8 @@ SYMBOL: html : print-html ( str -- ) write-html "\n" write-html ; +<< + : html-word ( name def effect -- ) #! Define 'word creating' word to allow #! dynamically creating words. @@ -137,30 +139,46 @@ SYMBOL: html dup "=" prepend swap [ write-attr ] curry attribute-effect html-word ; +! Define some closed HTML tags [ - ! Define some closed HTML tags - [ - "h1" "h2" "h3" "h4" "h5" "h6" "h7" "h8" "h9" - "ol" "li" "form" "a" "p" "html" "head" "body" "title" - "b" "i" "ul" "table" "tbody" "tr" "td" "th" "pre" "textarea" - "script" "div" "span" "select" "option" "style" "input" - ] [ define-closed-html-word ] each + "h1" "h2" "h3" "h4" "h5" "h6" "h7" "h8" "h9" + "ol" "li" "form" "a" "p" "html" "head" "body" "title" + "b" "i" "ul" "table" "tbody" "tr" "td" "th" "pre" "textarea" + "script" "div" "span" "select" "option" "style" "input" +] [ define-closed-html-word ] each - ! Define some open HTML tags - [ - "input" - "br" - "link" - "img" - ] [ define-open-html-word ] each +! Define some open HTML tags +[ + "input" + "br" + "link" + "img" +] [ define-open-html-word ] each - ! Define some attributes - [ - "method" "action" "type" "value" "name" - "size" "href" "class" "border" "rows" "cols" - "id" "onclick" "style" "valign" "accesskey" - "src" "language" "colspan" "onchange" "rel" - "width" "selected" "onsubmit" "xmlns" "lang" "xml:lang" - "media" "title" "multiple" - ] [ define-attribute-word ] each -] with-compilation-unit +! Define some attributes +[ + "method" "action" "type" "value" "name" + "size" "href" "class" "border" "rows" "cols" + "id" "onclick" "style" "valign" "accesskey" + "src" "language" "colspan" "onchange" "rel" + "width" "selected" "onsubmit" "xmlns" "lang" "xml:lang" + "media" "title" "multiple" +] [ define-attribute-word ] each + +>> + +: xhtml-preamble ( -- ) + "" write-html + "" write-html ; + +: simple-page ( title quot -- ) + #! Call the quotation, with all output going to the + #! body of an html page with the given title. + xhtml-preamble + + swap write + call + ; + +: render-error ( message -- ) + escape-string write ; diff --git a/extra/html/html.factor b/extra/html/html.factor deleted file mode 100755 index 71862b0d01..0000000000 --- a/extra/html/html.factor +++ /dev/null @@ -1,267 +0,0 @@ -! Copyright (C) 2004, 2006 Slava Pestov. -! See http://factorcode.org/license.txt for BSD license. -USING: generic assocs help http io io.styles io.files continuations -io.streams.string kernel math math.order math.parser namespaces -quotations assocs sequences strings words html.elements -xml.entities sbufs continuations destructors ; -IN: html - -GENERIC: browser-link-href ( presented -- href ) - -M: object browser-link-href drop f ; - -TUPLE: html-stream last-div? ; - -! A hack: stream-nl after with-nesting or tabular-output is -! ignored, so that HTML stream output looks like UI pane output -: test-last-div? ( stream -- ? ) - dup html-stream-last-div? - f rot set-html-stream-last-div? ; - -: not-a-div ( stream -- stream ) - dup test-last-div? drop ; inline - -: a-div ( stream -- straem ) - t over set-html-stream-last-div? ; inline - -: ( stream -- stream ) - html-stream construct-delegate ; - - over set-delegate ; - -: ( style stream class -- stream ) - >r (html-sub-stream) r> construct-delegate ; inline - -: end-sub-stream ( substream -- string style stream ) - dup delegate >string - over html-sub-stream-style - rot html-sub-stream-stream ; - -: delegate-write ( string -- ) - output-stream get delegate stream-write ; - -: object-link-tag ( style quot -- ) - presented pick at [ - browser-link-href [ - call - ] [ call ] if* - ] [ call ] if* ; inline - -: hex-color, ( triplet -- ) - 3 head-slice - [ 255 * >fixnum >hex 2 CHAR: 0 pad-left % ] each ; - -: fg-css, ( color -- ) - "color: #" % hex-color, "; " % ; - -: bg-css, ( color -- ) - "background-color: #" % hex-color, "; " % ; - -: style-css, ( flag -- ) - dup - { italic bold-italic } member? - "font-style: " % "italic" "normal" ? % "; " % - { bold bold-italic } member? - "font-weight: " % "bold" "normal" ? % "; " % ; - -: size-css, ( size -- ) - "font-size: " % # "pt; " % ; - -: font-css, ( font -- ) - "font-family: " % % "; " % ; - -: apply-style ( style key quot -- style gadget ) - >r over at r> when* ; inline - -: make-css ( style quot -- str ) - "" make nip ; inline - -: span-css-style ( style -- str ) - [ - foreground [ fg-css, ] apply-style - background [ bg-css, ] apply-style - font [ font-css, ] apply-style - font-style [ style-css, ] apply-style - font-size [ size-css, ] apply-style - ] make-css ; - -: span-tag ( style quot -- ) - over span-css-style dup empty? [ - drop call - ] [ - call - ] if ; inline - -: format-html-span ( string style stream -- ) - [ - [ [ drop delegate-write ] span-tag ] object-link-tag - ] with-output-stream* ; - -TUPLE: html-span-stream ; - -M: html-span-stream dispose - end-sub-stream not-a-div format-html-span ; - -: border-css, ( border -- ) - "border: 1px solid #" % hex-color, "; " % ; - -: padding-css, ( padding -- ) "padding: " % # "px; " % ; - -: pre-css, ( margin -- ) - [ "white-space: pre; font-family: monospace; " % ] unless ; - -: div-css-style ( style -- str ) - [ - page-color [ bg-css, ] apply-style - border-color [ border-css, ] apply-style - border-width [ padding-css, ] apply-style - wrap-margin over at pre-css, - ] make-css ; - -: div-tag ( style quot -- ) - swap div-css-style dup empty? [ - drop call - ] [ -
call
- ] if ; inline - -: format-html-div ( string style stream -- ) - [ - [ [ delegate-write ] div-tag ] object-link-tag - ] with-output-stream* ; - -TUPLE: html-block-stream ; - -M: html-block-stream dispose ( quot style stream -- ) - end-sub-stream a-div format-html-div ; - -: border-spacing-css, - "padding: " % first2 max 2 /i # "px; " % ; - -: table-style ( style -- str ) - [ - table-border [ border-css, ] apply-style - table-gap [ border-spacing-css, ] apply-style - ] make-css ; - -: table-attrs ( style -- ) - table-style " border-collapse: collapse;" append =style ; - -: do-escaping ( string style -- string ) - html swap at [ escape-string ] unless ; - -PRIVATE> - -! Stream protocol -M: html-stream stream-write1 ( char stream -- ) - >r 1string r> stream-write ; - -M: html-stream stream-write ( str stream -- ) - not-a-div >r escape-string r> delegate stream-write ; - -M: html-stream make-span-stream ( style stream -- stream' ) - html-span-stream ; - -M: html-stream stream-format ( str style stream -- ) - >r html over at [ >r escape-string r> ] unless r> - format-html-span ; - -M: html-stream make-block-stream ( style stream -- stream' ) - html-block-stream ; - -M: html-stream stream-write-table ( grid style stream -- ) - a-div [ - swap [ - [ - - ] with each - ] with each
- >string write-html -
- ] with-output-stream* ; - -M: html-stream make-cell-stream ( style stream -- stream' ) - (html-sub-stream) ; - -M: html-stream stream-nl ( stream -- ) - dup test-last-div? [ drop ] [ [
] with-output-stream* ] if ; - -! Utilities -: with-html-stream ( quot -- ) - output-stream get swap with-output-stream* ; inline - -: xhtml-preamble - "" write-html - "" write-html ; - -: html-document ( body-quot head-quot -- ) - #! head-quot is called to produce output to go - #! in the html head portion of the document. - #! body-quot is called to produce output to go - #! in the html body portion of the document. - xhtml-preamble - - call - call - ; - -: default-css ( -- ) - ; - -: simple-html-document ( title quot -- ) - swap [ - write - default-css - ] html-document ; - -: vertical-layout ( list -- ) - #! Given a list of HTML components, arrange them vertically. - - [ ] each -
call
; - -: horizontal-layout ( list -- ) - #! Given a list of HTML components, arrange them horizontally. - - [ ] each -
call
; - -: button ( label -- ) - #! Output an HTML submit button with the given label. - ; - -: paragraph ( str -- ) - #! Output the string as an html paragraph -

write

; - -: simple-page ( title quot -- ) - #! Call the quotation, with all output going to the - #! body of an html page with the given title. - - swap write - call - ; - -: styled-page ( title stylesheet-quot quot -- ) - #! Call the quotation, with all output going to the - #! body of an html page with the given title. stylesheet-quot - #! is called to generate the required stylesheet. - - - rot write - swap call - - call - ; - -: render-error ( message -- ) - escape-string write ; diff --git a/extra/html/authors.txt b/extra/html/streams/authors.txt similarity index 100% rename from extra/html/authors.txt rename to extra/html/streams/authors.txt diff --git a/extra/html/html-tests.factor b/extra/html/streams/streams-tests.factor similarity index 86% rename from extra/html/html-tests.factor rename to extra/html/streams/streams-tests.factor index 9f1ce6b689..14f1621346 100644 --- a/extra/html/html-tests.factor +++ b/extra/html/streams/streams-tests.factor @@ -1,6 +1,7 @@ -USING: html http io io.streams.string io.styles kernel -namespaces tools.test xml.writer sbufs sequences html.private ; -IN: html.tests +USING: html.streams html.streams.private +io io.streams.string io.styles kernel +namespaces tools.test xml.writer sbufs sequences inspector ; +IN: html.streams.tests : make-html-string [ with-html-stream ] with-string-writer ; inline @@ -69,3 +70,5 @@ M: funky browser-link-href ] [ [ H{ } [ ] with-nesting nl ] make-html-string ] unit-test + +[ ] [ [ { 1 2 3 } describe ] with-html-stream ] unit-test diff --git a/extra/html/streams/streams.factor b/extra/html/streams/streams.factor new file mode 100755 index 0000000000..e3f45e4c25 --- /dev/null +++ b/extra/html/streams/streams.factor @@ -0,0 +1,195 @@ +! Copyright (C) 2004, 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: generic assocs help http io io.styles io.files continuations +io.streams.string kernel math math.order math.parser namespaces +quotations assocs sequences strings words html.elements +xml.entities sbufs continuations destructors accessors ; +IN: html.streams + +GENERIC: browser-link-href ( presented -- href ) + +M: object browser-link-href drop f ; + +TUPLE: html-stream stream last-div ; + +! stream-nl after with-nesting or tabular-output is +! ignored, so that HTML stream output looks like +! UI pane output +: last-div? ( stream -- ? ) + [ f ] change-last-div drop ; + +: not-a-div ( stream -- stream ) + f >>last-div ; inline + +: a-div ( stream -- straem ) + t >>last-div ; inline + +: ( stream -- stream ) + f html-stream boa ; + + >>stream + swap >>parent + swap >>style ; inline + +: end-sub-stream ( substream -- string style stream ) + [ stream>> >string ] [ style>> ] [ parent>> ] tri ; + +: object-link-tag ( style quot -- ) + presented pick at [ + browser-link-href [ + call + ] [ call ] if* + ] [ call ] if* ; inline + +: hex-color, ( triplet -- ) + 3 head-slice + [ 255 * >fixnum >hex 2 CHAR: 0 pad-left % ] each ; + +: fg-css, ( color -- ) + "color: #" % hex-color, "; " % ; + +: bg-css, ( color -- ) + "background-color: #" % hex-color, "; " % ; + +: style-css, ( flag -- ) + dup + { italic bold-italic } member? + "font-style: " % "italic" "normal" ? % "; " % + { bold bold-italic } member? + "font-weight: " % "bold" "normal" ? % "; " % ; + +: size-css, ( size -- ) + "font-size: " % # "pt; " % ; + +: font-css, ( font -- ) + "font-family: " % % "; " % ; + +: apply-style ( style key quot -- style gadget ) + >r over at r> when* ; inline + +: make-css ( style quot -- str ) + "" make nip ; inline + +: span-css-style ( style -- str ) + [ + foreground [ fg-css, ] apply-style + background [ bg-css, ] apply-style + font [ font-css, ] apply-style + font-style [ style-css, ] apply-style + font-size [ size-css, ] apply-style + ] make-css ; + +: span-tag ( style quot -- ) + over span-css-style dup empty? [ + drop call + ] [ + call + ] if ; inline + +: format-html-span ( string style stream -- ) + stream>> [ + [ [ drop write ] span-tag ] object-link-tag + ] with-output-stream* ; + +TUPLE: html-span-stream < html-sub-stream ; + +M: html-span-stream dispose + end-sub-stream not-a-div format-html-span ; + +: border-css, ( border -- ) + "border: 1px solid #" % hex-color, "; " % ; + +: padding-css, ( padding -- ) "padding: " % # "px; " % ; + +: pre-css, ( margin -- ) + [ "white-space: pre; font-family: monospace; " % ] unless ; + +: div-css-style ( style -- str ) + [ + page-color [ bg-css, ] apply-style + border-color [ border-css, ] apply-style + border-width [ padding-css, ] apply-style + wrap-margin over at pre-css, + ] make-css ; + +: div-tag ( style quot -- ) + swap div-css-style dup empty? [ + drop call + ] [ +
call
+ ] if ; inline + +: format-html-div ( string style stream -- ) + stream>> [ + [ [ write ] div-tag ] object-link-tag + ] with-output-stream* ; + +TUPLE: html-block-stream < html-sub-stream ; + +M: html-block-stream dispose ( quot style stream -- ) + end-sub-stream a-div format-html-div ; + +: border-spacing-css, + "padding: " % first2 max 2 /i # "px; " % ; + +: table-style ( style -- str ) + [ + table-border [ border-css, ] apply-style + table-gap [ border-spacing-css, ] apply-style + ] make-css ; + +: table-attrs ( style -- ) + table-style " border-collapse: collapse;" append =style ; + +: do-escaping ( string style -- string ) + html swap at [ escape-string ] unless ; + +PRIVATE> + +! Stream protocol +M: html-stream stream-flush + stream>> stream-flush ; + +M: html-stream stream-write1 + >r 1string r> stream-write ; + +M: html-stream stream-write + not-a-div >r escape-string r> stream>> stream-write ; + +M: html-stream stream-format + >r html over at [ >r escape-string r> ] unless r> + format-html-span ; + +M: html-stream stream-nl + dup last-div? [ drop ] [ [
] with-output-stream* ] if ; + +M: html-stream make-span-stream + html-span-stream new-html-sub-stream ; + +M: html-stream make-block-stream + html-block-stream new-html-sub-stream ; + +M: html-stream make-cell-stream + html-sub-stream new-html-sub-stream ; + +M: html-stream stream-write-table + a-div stream>> [ + swap [ + [ + + ] with each + ] with each
+ stream>> >string write +
+ ] with-output-stream* ; + +M: html-stream dispose stream>> dispose ; + +: with-html-stream ( quot -- ) + output-stream get swap with-output-stream* ; inline diff --git a/extra/html/summary.txt b/extra/html/streams/summary.txt similarity index 100% rename from extra/html/summary.txt rename to extra/html/streams/summary.txt diff --git a/extra/html/tags.txt b/extra/html/streams/tags.txt similarity index 100% rename from extra/html/tags.txt rename to extra/html/streams/tags.txt diff --git a/extra/html/stylesheet.css b/extra/html/stylesheet.css deleted file mode 100644 index a1afce7c9f..0000000000 --- a/extra/html/stylesheet.css +++ /dev/null @@ -1,4 +0,0 @@ -a:link { text-decoration: none; color: black; } -a:visited { text-decoration: none; color: black; } -a:active { text-decoration: none; color: black; } -a:hover { text-decoration: underline; color: black; } diff --git a/extra/html/templates/chloe/chloe-tests.factor b/extra/html/templates/chloe/chloe-tests.factor new file mode 100644 index 0000000000..eaa0f0dc3d --- /dev/null +++ b/extra/html/templates/chloe/chloe-tests.factor @@ -0,0 +1,161 @@ +USING: html.templates html.templates.chloe +tools.test io.streams.string kernel sequences ascii boxes +namespaces xml html.components +splitting unicode.categories ; +IN: html.templates.chloe.tests + +[ f ] [ f parse-query-attr ] unit-test + +[ f ] [ "" parse-query-attr ] unit-test + +[ H{ { "a" "b" } } ] [ + blank-values + "b" "a" set-value + "a" parse-query-attr +] unit-test + +[ H{ { "a" "b" } { "c" "d" } } ] [ + blank-values + "b" "a" set-value + "d" "c" set-value + "a,c" parse-query-attr +] unit-test + +: run-template + with-string-writer [ "\r\n\t" member? not ] filter + "?>" split1 nip ; inline + +: test-template ( name -- template ) + "resource:extra/html/templates/chloe/test/" + swap + ".xml" 3append ; + +[ "Hello world" ] [ + [ + "test1" test-template call-template + ] run-template +] unit-test + +[ "Blah blah" "Hello world" ] [ + [ + title set + [ + "test2" test-template call-template + ] run-template + title get box> + ] with-scope +] unit-test + +[ "Hello worldBlah blah" ] [ + [ + [ + "test2" test-template call-template + ] "test3" test-template with-boilerplate + ] run-template +] unit-test + +: test4-aux? t ; + +[ "True" ] [ + [ + "test4" test-template call-template + ] run-template +] unit-test + +: test5-aux? f ; + +[ "" ] [ + [ + "test5" test-template call-template + ] run-template +] unit-test + +SYMBOL: test6-aux? + +[ "True" ] [ + [ + test6-aux? on + "test6" test-template call-template + ] run-template +] unit-test + +SYMBOL: test7-aux? + +[ "" ] [ + [ + test7-aux? off + "test7" test-template call-template + ] run-template +] unit-test + +[ ] [ blank-values ] unit-test + +[ ] [ "A label" "label" set-value ] unit-test + +SINGLETON: link-test + +M: link-test link-title drop "" ; + +M: link-test link-href drop "http://www.apple.com/foo&bar" ; + +[ ] [ link-test "link" set-value ] unit-test + +[ ] [ "int x = 5;" "code" set-value ] unit-test + +[ ] [ "c" "mode" set-value ] unit-test + +[ ] [ { 1 2 3 } "inspector" set-value ] unit-test + +[ ] [ "

a paragraph

" "html" set-value ] unit-test + +[ ] [ "sheeple" "field" set-value ] unit-test + +[ ] [ "a password" "password" set-value ] unit-test + +[ ] [ "a\nb\nc" "textarea" set-value ] unit-test + +[ ] [ "new york" "choice" set-value ] unit-test + +[ ] [ { "new york" "detroit" "minneapolis" } "choices" set-value ] unit-test + +[ ] [ + [ + "test8" test-template call-template + ] run-template drop +] unit-test + +[ ] [ { 1 2 3 } "numbers" set-value ] unit-test + +[ "
  • 1
  • 2
  • 3
" ] [ + [ + "test9" test-template call-template + ] run-template [ blank? not ] filter +] unit-test + +TUPLE: person first-name last-name ; + +[ ] [ + { + T{ person f "RBaxter" "Unknown" } + T{ person f "Doug" "Coleman" } + } "people" set-value +] unit-test + +[ "
RBaxterUnknown
DougColeman
" ] [ + [ + "test10" test-template call-template + ] run-template [ blank? not ] filter +] unit-test + +[ ] [ + { + H{ { "first-name" "RBaxter" } { "last-name" "Unknown" } } + H{ { "first-name" "Doug" } { "last-name" "Coleman" } } + } "people" set-value +] unit-test + +[ "
RBaxterUnknown
DougColeman
" ] [ + [ + "test11" test-template call-template + ] run-template [ blank? not ] filter +] unit-test diff --git a/extra/http/server/templating/chloe/chloe.factor b/extra/html/templates/chloe/chloe.factor similarity index 67% rename from extra/http/server/templating/chloe/chloe.factor rename to extra/html/templates/chloe/chloe.factor index c3d93f5909..092f79bb36 100644 --- a/extra/http/server/templating/chloe/chloe.factor +++ b/extra/html/templates/chloe/chloe.factor @@ -3,17 +3,17 @@ USING: accessors kernel sequences combinators kernel namespaces classes.tuple assocs splitting words arrays memoize io io.files io.encodings.utf8 io.streams.string -unicode.case tuple-syntax html html.elements +unicode.case tuple-syntax mirrors fry math multiline xml xml.data xml.writer xml.utilities +html.elements +html.components +html.templates http.server http.server.auth http.server.flows http.server.actions -http.server.components -http.server.sessions -http.server.templating -http.server.boilerplate ; -IN: http.server.templating.chloe +http.server.sessions ; +IN: html.templates.chloe ! Chloe is Ed's favorite web designer @@ -52,8 +52,11 @@ MEMO: chloe-name ( string -- name ) : optional-attr ( tag name -- value ) chloe-name swap at ; +: process-tag-children ( tag -- ) + [ process-template ] each ; + : children>string ( tag -- string ) - [ [ process-template ] each ] with-string-writer ; + [ process-tag-children ] with-string-writer ; : title-tag ( tag -- ) children>string set-title ; @@ -89,18 +92,6 @@ MEMO: chloe-name ( string -- name ) atom-feed get value>> second write ] if ; -: component-attr ( tag -- name ) - "component" required-attr ; - -: view-tag ( tag -- ) - component-attr component render-view ; - -: edit-tag ( tag -- ) - component-attr component render-edit ; - -: summary-tag ( tag -- ) - component-attr component render-summary ; - : parse-query-attr ( string -- assoc ) dup empty? [ drop f ] [ "," split [ dup value ] H{ } map>assoc ] if ; @@ -133,9 +124,6 @@ MEMO: chloe-name ( string -- name ) a> ] with-scope ; -: process-tag-children ( tag -- ) - [ process-template ] each ; - : a-tag ( tag -- ) [ a-start-tag ] [ process-tag-children ] @@ -156,7 +144,7 @@ MEMO: chloe-name ( string -- name ) form> ] [ hidden-form-field - "for" optional-attr [ component render-edit ] when* + "for" optional-attr [ hidden render ] when* ] bi ] with-scope ; @@ -180,9 +168,9 @@ STRING: button-tag-markup : button-tag ( tag -- ) button-tag-markup string>xml delegate { - [ >r tag-attrs chloe-attrs-only r> add-tag-attrs ] - [ >r tag-attrs non-chloe-attrs-only r> "button" tag-named add-tag-attrs ] - [ >r children>string 1array r> "button" tag-named set-tag-children ] + [ [ tag-attrs chloe-attrs-only ] dip add-tag-attrs ] + [ [ tag-attrs non-chloe-attrs-only ] dip "button" tag-named add-tag-attrs ] + [ [ children>string 1array ] dip "button" tag-named set-tag-children ] [ nip ] } 2cleave process-chloe-tag ; @@ -208,30 +196,109 @@ STRING: button-tag-markup : if-tag ( tag -- ) dup if-satisfied? [ process-tag-children ] [ drop ] if ; +: even-tag ( tag -- ) + "index" value even? [ process-tag-children ] [ drop ] if ; + +: odd-tag ( tag -- ) + "index" value odd? [ process-tag-children ] [ drop ] if ; + +: (each-tag) ( tag quot -- ) + [ + [ "values" required-attr value ] keep + '[ , process-tag-children ] + ] dip call ; inline + +: each-tag ( tag -- ) + [ with-each-value ] (each-tag) ; + +: each-tuple-tag ( tag -- ) + [ with-each-tuple ] (each-tag) ; + +: each-assoc-tag ( tag -- ) + [ with-each-assoc ] (each-tag) ; + +: (bind-tag) ( tag quot -- ) + [ + [ "name" required-attr value ] keep + '[ , process-tag-children ] + ] dip call ; inline + +: bind-tuple-tag ( tag -- ) + [ with-tuple-values ] (bind-tag) ; + +: bind-assoc-tag ( tag -- ) + [ with-assoc-values ] (bind-tag) ; + : error-message-tag ( tag -- ) children>string render-error ; +: validation-messages-tag ( tag -- ) + drop render-validation-messages ; + +: singleton-component-tag ( tag class -- ) + [ "name" required-attr ] dip render ; + +: attrs>slots ( tag tuple -- ) + [ attrs>> ] [ ] bi* + '[ + swap tag>> dup "name" = + [ 2drop ] [ , set-at ] if + ] assoc-each ; + +: tuple-component-tag ( tag class -- ) + [ drop "name" required-attr ] + [ new [ attrs>slots ] keep ] + 2bi render ; + : process-chloe-tag ( tag -- ) dup name-tag { - { "chloe" [ [ process-template ] each ] } + { "chloe" [ process-tag-children ] } + + ! HTML head { "title" [ title-tag ] } { "write-title" [ write-title-tag ] } { "style" [ style-tag ] } { "write-style" [ write-style-tag ] } { "atom" [ atom-tag ] } { "write-atom" [ write-atom-tag ] } - { "view" [ view-tag ] } - { "edit" [ edit-tag ] } - { "summary" [ summary-tag ] } + + ! HTML elements { "a" [ a-tag ] } - { "form" [ form-tag ] } { "button" [ button-tag ] } + + ! Components + { "label" [ label singleton-component-tag ] } + { "link" [ link singleton-component-tag ] } + { "code" [ code tuple-component-tag ] } + { "farkup" [ farkup singleton-component-tag ] } + { "inspector" [ inspector singleton-component-tag ] } + { "comparison" [ comparison singleton-component-tag ] } + { "html" [ html singleton-component-tag ] } + + ! Forms + { "form" [ form-tag ] } { "error-message" [ error-message-tag ] } - { "validation-message" [ drop render-validation-message ] } + { "validation-messages" [ validation-messages-tag ] } + { "hidden" [ hidden singleton-component-tag ] } + { "field" [ field tuple-component-tag ] } + { "password" [ password tuple-component-tag ] } + { "textarea" [ textarea tuple-component-tag ] } + { "choice" [ choice tuple-component-tag ] } + { "checkbox" [ checkbox tuple-component-tag ] } + + ! Control flow { "if" [ if-tag ] } + { "even" [ even-tag ] } + { "odd" [ odd-tag ] } + { "each" [ each-tag ] } + { "each-assoc" [ each-assoc-tag ] } + { "each-tuple" [ each-tuple-tag ] } + { "bind-assoc" [ bind-assoc-tag ] } + { "bind-tuple" [ bind-tuple-tag ] } { "comment" [ drop ] } { "call-next-template" [ drop call-next-template ] } - [ "Unknown chloe tag: " swap append throw ] + + [ "Unknown chloe tag: " prepend throw ] } case ; : process-tag ( tag -- ) diff --git a/extra/http/server/templating/chloe/test/test1.xml b/extra/html/templates/chloe/test/test1.xml similarity index 100% rename from extra/http/server/templating/chloe/test/test1.xml rename to extra/html/templates/chloe/test/test1.xml diff --git a/extra/html/templates/chloe/test/test10.xml b/extra/html/templates/chloe/test/test10.xml new file mode 100644 index 0000000000..afded9366f --- /dev/null +++ b/extra/html/templates/chloe/test/test10.xml @@ -0,0 +1,14 @@ + + + + + + + + + + + +
+ + diff --git a/extra/html/templates/chloe/test/test11.xml b/extra/html/templates/chloe/test/test11.xml new file mode 100644 index 0000000000..17e31b1a59 --- /dev/null +++ b/extra/html/templates/chloe/test/test11.xml @@ -0,0 +1,14 @@ + + + + + + + + + + + +
+ + diff --git a/extra/http/server/templating/chloe/test/test2.xml b/extra/html/templates/chloe/test/test2.xml similarity index 100% rename from extra/http/server/templating/chloe/test/test2.xml rename to extra/html/templates/chloe/test/test2.xml diff --git a/extra/http/server/templating/chloe/test/test3-aux.xml b/extra/html/templates/chloe/test/test3-aux.xml similarity index 100% rename from extra/http/server/templating/chloe/test/test3-aux.xml rename to extra/html/templates/chloe/test/test3-aux.xml diff --git a/extra/http/server/templating/chloe/test/test3.xml b/extra/html/templates/chloe/test/test3.xml similarity index 100% rename from extra/http/server/templating/chloe/test/test3.xml rename to extra/html/templates/chloe/test/test3.xml diff --git a/extra/http/server/templating/chloe/test/test4.xml b/extra/html/templates/chloe/test/test4.xml similarity index 62% rename from extra/http/server/templating/chloe/test/test4.xml rename to extra/html/templates/chloe/test/test4.xml index dd9b232d73..55612360a5 100644 --- a/extra/http/server/templating/chloe/test/test4.xml +++ b/extra/html/templates/chloe/test/test4.xml @@ -2,7 +2,7 @@ - + True diff --git a/extra/http/server/templating/chloe/test/test5.xml b/extra/html/templates/chloe/test/test5.xml similarity index 62% rename from extra/http/server/templating/chloe/test/test5.xml rename to extra/html/templates/chloe/test/test5.xml index 3bd39e45bd..edcbe8f3b1 100644 --- a/extra/http/server/templating/chloe/test/test5.xml +++ b/extra/html/templates/chloe/test/test5.xml @@ -2,7 +2,7 @@ - + True diff --git a/extra/http/server/templating/chloe/test/test6.xml b/extra/html/templates/chloe/test/test6.xml similarity index 62% rename from extra/http/server/templating/chloe/test/test6.xml rename to extra/html/templates/chloe/test/test6.xml index 56234a5f0d..b3f649333f 100644 --- a/extra/http/server/templating/chloe/test/test6.xml +++ b/extra/html/templates/chloe/test/test6.xml @@ -2,7 +2,7 @@ - + True diff --git a/extra/http/server/templating/chloe/test/test7.xml b/extra/html/templates/chloe/test/test7.xml similarity index 62% rename from extra/http/server/templating/chloe/test/test7.xml rename to extra/html/templates/chloe/test/test7.xml index a4f8e06e7d..338595e556 100644 --- a/extra/http/server/templating/chloe/test/test7.xml +++ b/extra/html/templates/chloe/test/test7.xml @@ -2,7 +2,7 @@ - + True diff --git a/extra/html/templates/chloe/test/test8.xml b/extra/html/templates/chloe/test/test8.xml new file mode 100644 index 0000000000..8e2ff2e8ad --- /dev/null +++ b/extra/html/templates/chloe/test/test8.xml @@ -0,0 +1,27 @@ + + + + + + + + + + + + + + + + + + + + + + + + + Checkbox + + diff --git a/extra/html/templates/chloe/test/test9.xml b/extra/html/templates/chloe/test/test9.xml new file mode 100644 index 0000000000..bcfc468738 --- /dev/null +++ b/extra/html/templates/chloe/test/test9.xml @@ -0,0 +1,11 @@ + + + + +
    + +
    • +     +
+ + diff --git a/extra/http/server/templating/fhtml/authors.txt b/extra/html/templates/fhtml/authors.txt similarity index 100% rename from extra/http/server/templating/fhtml/authors.txt rename to extra/html/templates/fhtml/authors.txt diff --git a/extra/http/server/templating/fhtml/fhtml-tests.factor b/extra/html/templates/fhtml/fhtml-tests.factor similarity index 74% rename from extra/http/server/templating/fhtml/fhtml-tests.factor rename to extra/html/templates/fhtml/fhtml-tests.factor index 42bec43570..43ea28fa55 100755 --- a/extra/http/server/templating/fhtml/fhtml-tests.factor +++ b/extra/html/templates/fhtml/fhtml-tests.factor @@ -1,10 +1,10 @@ USING: io io.files io.streams.string io.encodings.utf8 -http.server.templating http.server.templating.fhtml kernel +html.templates html.templates.fhtml kernel tools.test sequences parser ; -IN: http.server.templating.fhtml.tests +IN: html.templates.fhtml.tests : test-template ( path -- ? ) - "resource:extra/http/server/templating/fhtml/test/" + "resource:extra/html/templates/fhtml/test/" prepend [ ".fhtml" append [ call-template ] with-string-writer diff --git a/extra/http/server/templating/fhtml/fhtml.factor b/extra/html/templates/fhtml/fhtml.factor similarity index 62% rename from extra/http/server/templating/fhtml/fhtml.factor rename to extra/html/templates/fhtml/fhtml.factor index 2cc053a0ca..74e5c37ef1 100755 --- a/extra/http/server/templating/fhtml/fhtml.factor +++ b/extra/html/templates/fhtml/fhtml.factor @@ -4,12 +4,10 @@ USING: continuations sequences kernel namespaces debugger combinators math quotations generic strings splitting accessors assocs fry -parser io io.files io.streams.string io.encodings.utf8 source-files -html html.elements -http.server.static http.server http.server.templating ; -IN: http.server.templating.fhtml - -: templating-vocab ( -- vocab-name ) "http.server.templating.fhtml" ; +parser io io.files io.streams.string io.encodings.utf8 +html.elements +html.templates ; +IN: html.templates.fhtml ! We use a custom lexer so that %> ends a token even if not ! followed by whitespace @@ -35,7 +33,7 @@ DEFER: <% delimiter : found-<% ( accum lexer col -- accum ) [ over line-text>> - >r >r column>> r> r> subseq parsed + [ column>> ] 2dip subseq parsed \ write-html parsed ] 2keep 2 + >>column drop ; @@ -62,37 +60,20 @@ DEFER: <% delimiter : parse-template ( string -- quot ) [ - use [ clone ] change - templating-vocab use+ + "quiet" on + parser-notes off + "html.templates.fhtml" use+ string-lines parse-template-lines - ] with-scope ; + ] with-file-vocabs ; -: eval-template ( string -- ) parse-template call ; - -: html-error. ( error -- ) - 
 error.
; +: eval-template ( string -- ) + parse-template call ; TUPLE: fhtml path ; C: fhtml M: fhtml call-template* ( filename -- ) - '[ - , path>> [ - "quiet" on - parser-notes off - templating-vocab use+ - ! so that reload works properly - dup source-file file set - utf8 file-contents - [ eval-template ] [ html-error. drop ] recover - ] with-file-vocabs - ] assert-depth ; - -! file responder integration -: enable-fhtml ( responder -- responder ) - [ serve-template ] - "application/x-factor-server-page" - pick special>> set-at ; + '[ , path>> utf8 file-contents eval-template ] assert-depth ; INSTANCE: fhtml template diff --git a/extra/http/server/templating/fhtml/test/bug.fhtml b/extra/html/templates/fhtml/test/bug.fhtml similarity index 100% rename from extra/http/server/templating/fhtml/test/bug.fhtml rename to extra/html/templates/fhtml/test/bug.fhtml diff --git a/extra/http/server/templating/fhtml/test/bug.html b/extra/html/templates/fhtml/test/bug.html similarity index 100% rename from extra/http/server/templating/fhtml/test/bug.html rename to extra/html/templates/fhtml/test/bug.html diff --git a/extra/http/server/templating/fhtml/test/example.fhtml b/extra/html/templates/fhtml/test/example.fhtml similarity index 100% rename from extra/http/server/templating/fhtml/test/example.fhtml rename to extra/html/templates/fhtml/test/example.fhtml diff --git a/extra/http/server/templating/fhtml/test/example.html b/extra/html/templates/fhtml/test/example.html similarity index 100% rename from extra/http/server/templating/fhtml/test/example.html rename to extra/html/templates/fhtml/test/example.html diff --git a/extra/http/server/templating/fhtml/test/stack.fhtml b/extra/html/templates/fhtml/test/stack.fhtml similarity index 100% rename from extra/http/server/templating/fhtml/test/stack.fhtml rename to extra/html/templates/fhtml/test/stack.fhtml diff --git a/extra/http/server/templating/fhtml/test/stack.html b/extra/html/templates/fhtml/test/stack.html similarity index 100% rename from extra/http/server/templating/fhtml/test/stack.html rename to extra/html/templates/fhtml/test/stack.html diff --git a/extra/html/templates/templates.factor b/extra/html/templates/templates.factor new file mode 100644 index 0000000000..580af58ecc --- /dev/null +++ b/extra/html/templates/templates.factor @@ -0,0 +1,85 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors kernel fry io io.encodings.utf8 io.files +debugger prettyprint continuations namespaces boxes sequences +arrays strings html.elements io.streams.string quotations ; +IN: html.templates + +MIXIN: template + +GENERIC: call-template* ( template -- ) + +M: string call-template* write ; + +M: callable call-template* call ; + +M: object call-template* output-stream get stream-copy ; + +ERROR: template-error template error ; + +M: template-error error. + "Error while processing template " write + [ template>> short. ":" print nl ] + [ error>> error. ] + bi ; + +: call-template ( template -- ) + [ call-template* ] [ \ template-error boa rethrow ] recover ; + +SYMBOL: title + +: set-title ( string -- ) + title get >box ; + +: write-title ( -- ) + title get value>> write ; + +SYMBOL: style + +: add-style ( string -- ) + "\n" style get push-all + style get push-all ; + +: write-style ( -- ) + style get >string write ; + +SYMBOL: atom-feed + +: set-atom-feed ( title url -- ) + 2array atom-feed get >box ; + +: write-atom-feed ( -- ) + atom-feed get value>> [ + + ] when* ; + +SYMBOL: nested-template? + +SYMBOL: next-template + +: call-next-template ( -- ) + next-template get write-html ; + +M: f call-template* drop call-next-template ; + +: with-boilerplate ( body template -- ) + [ + title get [ title set ] unless + atom-feed get [ atom-feed set ] unless + style get [ SBUF" " clone style set ] unless + + [ + [ + nested-template? on + call-template + ] with-string-writer + next-template set + ] + [ call-template ] + bi* + ] with-scope ; inline + +: template-convert ( template output -- ) + utf8 [ call-template ] with-file-writer ; diff --git a/extra/http/client/client.factor b/extra/http/client/client.factor index c455c8c5f1..7b156a4b9b 100755 --- a/extra/http/client/client.factor +++ b/extra/http/client/client.factor @@ -93,7 +93,7 @@ M: download-failed error. : download-to ( url file -- ) #! Downloads the contents of a URL to a file. - >r http-get r> latin1 [ write ] with-file-writer ; + [ http-get ] dip latin1 [ write ] with-file-writer ; : download ( url -- ) dup download-name download-to ; diff --git a/extra/http/http-tests.factor b/extra/http/http-tests.factor index 89480b43ba..151d1ce84f 100755 --- a/extra/http/http-tests.factor +++ b/extra/http/http-tests.factor @@ -237,7 +237,7 @@ test-db [ [ ] [ [ - [ "text/plain" [ "Hi" write ] >>body ] >>display + [ [ "Hi" write ] ] >>display "" add-responder diff --git a/extra/http/http.factor b/extra/http/http.factor index 7587cb0fe9..89c8f62d5c 100755 --- a/extra/http/http.factor +++ b/extra/http/http.factor @@ -9,7 +9,9 @@ math.parser calendar calendar.format io io.streams.string io.encodings.utf8 io.encodings.string io.sockets io.sockets.secure -unicode.case unicode.categories qualified ; +unicode.case unicode.categories qualified + +html.templates ; EXCLUDE: fry => , ; @@ -65,14 +67,14 @@ M: https protocol>string drop "https" ; 2dup length 2 - >= [ 2drop ] [ - >r 1+ dup 2 + r> subseq hex> [ , ] when* + [ 1+ dup 2 + ] dip subseq hex> [ , ] when* ] if ; : url-decode-% ( index str -- index str ) - 2dup url-decode-hex >r 3 + r> ; + 2dup url-decode-hex [ 3 + ] dip ; : url-decode-+-or-other ( index str ch -- index str ) - dup CHAR: + = [ drop CHAR: \s ] when , >r 1+ r> ; + dup CHAR: + = [ drop CHAR: \s ] when , [ 1+ ] dip ; : url-decode-iter ( index str -- ) 2dup length >= [ @@ -158,7 +160,7 @@ M: https protocol>string drop "https" ; dup [ "&" split H{ } clone [ [ - >r "=" split1 [ dup [ url-decode ] when ] bi@ swap r> + [ "=" split1 [ dup [ url-decode ] when ] bi@ swap ] dip add-query-param ] curry each ] keep @@ -174,7 +176,7 @@ M: https protocol>string drop "https" ; ] assoc-map [ [ - >r url-encode r> + [ url-encode ] dip [ url-encode "=" swap 3append , ] with each ] assoc-each ] { } make "&" join ; @@ -342,7 +344,7 @@ SYMBOL: max-post-request dup "cookie" header [ parse-cookies >>cookies ] when* ; : parse-content-type-attributes ( string -- attributes ) - " " split harvest [ "=" split1 >r >lower r> ] { } map>assoc ; + " " split harvest [ "=" split1 [ >lower ] dip ] { } map>assoc ; : parse-content-type ( content-type -- type encoding ) ";" split1 parse-content-type-attributes "charset" swap at ; @@ -521,18 +523,8 @@ body ; over unparse-content-type "content-type" pick set-at write-header ; -GENERIC: write-response-body* ( body -- ) - -M: f write-response-body* drop ; - -M: string write-response-body* write ; - -M: callable write-response-body* call ; - -M: object write-response-body* output-stream get stream-copy ; - : write-response-body ( response -- response ) - dup body>> write-response-body* ; + dup body>> call-template ; M: response write-response ( respose -- ) write-response-version @@ -547,10 +539,10 @@ M: response write-full-response ( request response -- ) swap method>> "HEAD" = [ write-response-body ] unless ; : get-cookie ( request/response name -- cookie/f ) - >r cookies>> r> '[ , _ name>> = ] find nip ; + [ cookies>> ] dip '[ , _ name>> = ] find nip ; : delete-cookie ( request/response name -- ) - over cookies>> >r get-cookie r> delete ; + over cookies>> [ get-cookie ] dip delete ; : put-cookie ( request/response cookie -- request/response ) [ name>> dupd get-cookie [ dupd delete-cookie ] when* ] keep diff --git a/extra/http/server/actions/actions-tests.factor b/extra/http/server/actions/actions-tests.factor index 5aa761603f..480cbc8e96 100755 --- a/extra/http/server/actions/actions-tests.factor +++ b/extra/http/server/actions/actions-tests.factor @@ -1,16 +1,10 @@ -USING: http.server.actions http.server.validators +USING: kernel http.server.actions validators tools.test math math.parser multiline namespaces http io.streams.string http.server sequences splitting accessors ; IN: http.server.actions.tests -[ - "a" [ v-number ] { { "a" "123" } } validate-param - [ 123 ] [ "a" get ] unit-test -] with-scope - - [ "a" get "b" get + ] >>display - { { "a" [ v-number ] } { "b" [ v-number ] } } >>get-params + [ "a" param "b" param [ string>number ] bi@ + ] >>display "action-1" set : lf>crlf "\n" split "\r\n" join ; diff --git a/extra/http/server/actions/actions.factor b/extra/http/server/actions/actions.factor index 2d73cb46a7..eb5b8bfe68 100755 --- a/extra/http/server/actions/actions.factor +++ b/extra/http/server/actions/actions.factor @@ -1,68 +1,94 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors sequences kernel assocs combinators -http.server http.server.validators http hashtables namespaces -fry continuations locals boxes xml.entities html.elements io ; +USING: accessors sequences kernel assocs combinators http.server +validators http hashtables namespaces fry continuations locals +boxes xml.entities html.elements html.components io arrays math ; IN: http.server.actions SYMBOL: params -SYMBOL: validation-message +SYMBOL: rest-param -: render-validation-message ( -- ) - validation-message get value>> [ - - escape-string write - - ] when* ; - -TUPLE: action init display submit get-params post-params ; - -: - action new - [ ] >>init - [ <400> ] >>display - [ <400> ] >>submit ; - -:: validate-param ( name validator assoc -- ) - name assoc at validator with-validator name set ; inline - -: action-params ( validators -- error? ) - validation-failed? off - params get '[ , validate-param ] assoc-each - validation-failed? get ; - -: handle-get ( -- response ) - action get get-params>> action-params [ <400> ] [ - action get [ init>> call ] [ display>> call ] bi +: render-validation-messages ( -- ) + validation-messages get + dup empty? [ drop ] [ +
    + [
  • message>> escape-string write
    • ] each +
] if ; -: handle-post ( -- response ) - action get post-params>> action-params - [ <400> ] [ action get submit>> call ] if ; +TUPLE: action rest-param init display validate submit ; + +: new-action ( class -- action ) + new + [ ] >>init + [ <400> ] >>display + [ ] >>validate + [ <400> ] >>submit ; + +: ( -- action ) + action new-action ; + +: handle-get ( action -- response ) + blank-values + [ init>> call ] + [ display>> call ] + bi ; : validation-failed ( -- * ) - action get display>> call exit-with ; + request get method>> "POST" = + [ action get display>> call ] [ <400> ] if exit-with ; -: validation-failed-with ( string -- * ) - validation-message get >box - validation-failed ; +: handle-post ( action -- response ) + init-validation + blank-values + [ validate>> call ] + [ submit>> call ] bi ; + +: handle-rest-param ( arg -- ) + dup length 1 > action get rest-param>> not or + [ <404> exit-with ] [ + action get rest-param>> associate rest-param set + ] if ; M: action call-responder* ( path action -- response ) + dup action set '[ - , [ CHAR: / = ] right-trim empty? [ - , action set - request get - validation-message set - [ request-params params set ] - [ - method>> { - { "GET" [ handle-get ] } - { "HEAD" [ handle-get ] } - { "POST" [ handle-post ] } - } case - ] bi - ] [ - <404> - ] if + , dup empty? [ drop ] [ handle-rest-param ] if + + init-validation + , + request get + [ request-params rest-param get assoc-union params set ] + [ method>> ] bi + { + { "GET" [ handle-get ] } + { "HEAD" [ handle-get ] } + { "POST" [ handle-post ] } + } case ] with-exit-continuation ; + +: param ( name -- value ) + params get at ; + +: check-validation ( -- ) + validation-failed? [ validation-failed ] when ; + +: validate-params ( validators -- ) + params get swap validate-values from-assoc + check-validation ; + +: validate-integer-id ( -- ) + { { "id" [ v-number ] } } validate-params ; + +TUPLE: page-action < action template ; + +: ( -- page ) + page-action new-action + dup '[ , template>> ] >>display ; + +TUPLE: feed-action < action feed ; + +: ( -- feed ) + feed-action new + dup '[ , feed>> call ] >>display ; diff --git a/extra/http/server/auth/admin/admin.factor b/extra/http/server/auth/admin/admin.factor deleted file mode 100644 index 21e1a6181b..0000000000 --- a/extra/http/server/auth/admin/admin.factor +++ /dev/null @@ -1,179 +0,0 @@ -! Copyright (C) 2008 Slava Pestov. -! See http://factorcode.org/license.txt for BSD license. -USING: kernel sequences accessors namespaces combinators words -assocs locals db.tuples arrays splitting strings qualified - -http.server.templating.chloe -http.server.boilerplate -http.server.auth.providers -http.server.auth.providers.db -http.server.auth.login -http.server.auth -http.server.forms -http.server.components.inspector -http.server.validators -http.server.sessions -http.server.actions -http.server.crud -http.server ; -EXCLUDE: http.server.components => string? number? ; -IN: http.server.auth.admin - -: admin-template ( name -- template ) - "resource:extra/http/server/auth/admin/" swap ".xml" 3append ; - -: words>strings ( seq -- seq' ) - [ [ word-vocabulary ] [ drop ":" ] [ word-name ] tri 3append ] map ; - -: strings>words ( seq -- seq' ) - [ ":" split1 swap lookup ] map ; - -: ( id -- component ) - capabilities get words>strings ; - -: ( -- form ) - "user"
- "new-user" admin-template >>edit-template - "username" add-field - "realname" add-field - "new-password" t >>required add-field - "verify-password" t >>required add-field - "email" add-field - "capabilities" add-field ; - -: ( -- form ) - "user" - "edit-user" admin-template >>edit-template - "user-summary" admin-template >>summary-template - "username" hidden >>renderer add-field - "realname" add-field - "new-password" add-field - "verify-password" add-field - "email" add-field - "profile" add-field - "capabilities" add-field ; - -: ( -- form ) - "user-list" - "user-list" admin-template >>view-template - "list" +unordered+ add-field ; - -:: ( form ctor next -- action ) - - [ - blank-values - - "username" get ctor call - - { - [ username>> "username" set-value ] - [ realname>> "realname" set-value ] - [ email>> "email" set-value ] - [ profile>> "profile" set-value ] - } cleave - ] >>init - - [ form edit-form ] >>display - - [ - blank-values - - form validate-form - - same-password-twice - - user new "username" value >>username select-tuple - [ user-exists ] when - - "username" value - "realname" value >>realname - "email" value >>email - "new-password" value >>encoded-password - H{ } clone >>profile - - insert-tuple - - next f - ] >>submit ; - -:: ( form ctor next -- action ) - - { { "username" [ v-required ] } } >>get-params - - [ - blank-values - - "username" get ctor call select-tuple - - { - [ username>> "username" set-value ] - [ realname>> "realname" set-value ] - [ email>> "email" set-value ] - [ profile>> "profile" set-value ] - [ capabilities>> words>strings "capabilities" set-value ] - } cleave - ] >>init - - [ form edit-form ] >>display - - [ - blank-values - - form validate-form - - "username" value select-tuple - "realname" value >>realname - "email" value >>email - - { "new-password" "verify-password" } - [ value empty? ] all? [ - same-password-twice - "new-password" value >>encoded-password - ] unless - - "capabilities" value { - { [ dup string? ] [ 1array ] } - { [ dup array? ] [ ] } - } cond strings>words >>capabilities - - update-tuple - - next f - ] >>submit ; - -:: ( ctor next -- action ) - - { { "username" [ ] } } >>post-params - - [ - "username" get - [ select-tuple 1 >>deleted update-tuple ] - [ logout-all-sessions ] - bi - - next f - ] >>submit ; - -TUPLE: user-admin < dispatcher ; - -SYMBOL: can-administer-users? - -can-administer-users? define-capability - -:: ( -- responder ) - [let | ctor [ [ ] ] | - user-admin new-dispatcher - ctor "" add-responder - ctor "$user-admin" "new" add-responder - ctor "$user-admin" "edit" add-responder - ctor "$user-admin" "delete" add-responder - - "admin" admin-template >>template - { can-administer-users? } - ] ; - -: make-admin ( username -- ) - - select-tuple - [ can-administer-users? suffix ] change-capabilities - update-tuple ; diff --git a/extra/http/server/auth/admin/user-list.xml b/extra/http/server/auth/admin/user-list.xml deleted file mode 100644 index 520b7f2512..0000000000 --- a/extra/http/server/auth/admin/user-list.xml +++ /dev/null @@ -1,9 +0,0 @@ - - - - - Users - - - - diff --git a/extra/http/server/auth/admin/user-summary.xml b/extra/http/server/auth/admin/user-summary.xml deleted file mode 100644 index c426e7c072..0000000000 --- a/extra/http/server/auth/admin/user-summary.xml +++ /dev/null @@ -1,9 +0,0 @@ - - - - - - - - - diff --git a/extra/http/server/auth/auth.factor b/extra/http/server/auth/auth.factor index 36fcff4b2e..4b34fbe804 100755 --- a/extra/http/server/auth/auth.factor +++ b/extra/http/server/auth/auth.factor @@ -1,6 +1,6 @@ ! Copyright (c) 2008 Slava Pestov ! See http://factorcode.org/license.txt for BSD license. -USING: accessors assocs namespaces kernel sequences +USING: accessors assocs namespaces kernel sequences sets http.server http.server.sessions http.server.auth.providers ; @@ -38,4 +38,4 @@ SYMBOL: capabilities V{ } clone capabilities set-global -: define-capability ( word -- ) capabilities get push-new ; +: define-capability ( word -- ) capabilities get adjoin ; diff --git a/extra/http/server/auth/login/edit-profile.xml b/extra/http/server/auth/login/edit-profile.xml index 1eaf65fa07..6beaf5de6d 100644 --- a/extra/http/server/auth/login/edit-profile.xml +++ b/extra/http/server/auth/login/edit-profile.xml @@ -10,12 +10,12 @@ User name: - + Real name: - + @@ -25,7 +25,7 @@ Current password: - + @@ -35,12 +35,12 @@ New password: - + Verify: - + @@ -50,7 +50,7 @@ E-mail: - + @@ -62,7 +62,7 @@

- +

diff --git a/extra/http/server/auth/login/login.factor b/extra/http/server/auth/login/login.factor index bb77532a22..fd4fbab8e8 100755 --- a/extra/http/server/auth/login/login.factor +++ b/extra/http/server/auth/login/login.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: accessors quotations assocs kernel splitting combinators sequences namespaces hashtables sets -fry arrays threads locals qualified random +fry arrays threads qualified random validators io io.sockets io.encodings.utf8 @@ -12,23 +12,22 @@ continuations destructors checksums checksums.sha2 +validators +html.components html.elements +html.templates +html.templates.chloe http http.server http.server.auth http.server.auth.providers http.server.auth.providers.db http.server.actions -http.server.components http.server.flows -http.server.forms http.server.sessions -http.server.boilerplate -http.server.templating -http.server.templating.chloe -http.server.validators ; -IN: http.server.auth.login +http.server.boilerplate ; QUALIFIED: smtp +IN: http.server.auth.login TUPLE: login < dispatcher users checksum ; @@ -65,149 +64,122 @@ M: user-saver dispose 3append ; ! ! ! Login - -: - "login" - "login" login-template >>edit-template - "username" - t >>required - add-field - "password" - t >>required - add-field ; - : successful-login ( user -- response ) - username>> set-uid - "$login" end-flow ; + username>> set-uid "$login" end-flow ; -: login-failed "invalid username or password" validation-failed-with ; +: login-failed ( -- * ) + "invalid username or password" validation-error + validation-failed ; -:: ( -- action ) - [let | form [ ] | - - [ blank-values ] >>init +: ( -- action ) + + [ "login" login-template ] >>display - [ form edit-form ] >>display + [ + { + { "username" [ v-required ] } + { "password" [ v-required ] } + } validate-params - [ - blank-values - - form validate-form - - "password" value "username" value check-login - [ successful-login ] [ login-failed ] if* - ] >>submit - ] ; + "password" value + "username" value check-login + [ successful-login ] [ login-failed ] if* + ] >>submit ; ! ! ! New user registration -: ( -- form ) - "register" - "register" login-template >>edit-template - "username" - t >>required - add-field - "realname" add-field - "new-password" - t >>required - add-field - "verify-password" - t >>required - add-field - "email" add-field - "captcha" add-field ; +: user-exists ( -- * ) + "username taken" validation-error + validation-failed ; -: password-mismatch "passwords do not match" validation-failed-with ; - -: user-exists "username taken" validation-failed-with ; +: password-mismatch ( -- * ) + "passwords do not match" validation-error + validation-failed ; : same-password-twice ( -- ) "new-password" value "verify-password" value = [ password-mismatch ] unless ; -:: ( -- action ) - [let | form [ ] | - - [ blank-values ] >>init +: ( -- action ) + + "register" login-template >>template - [ form edit-form ] >>display + [ + { + { "username" [ v-username ] } + { "realname" [ [ v-one-line ] v-optional ] } + { "new-password" [ v-password ] } + { "verify-password" [ v-password ] } + { "email" [ [ v-email ] v-optional ] } + { "captcha" [ v-captcha ] } + } validate-params - [ - blank-values + same-password-twice + ] >>validate - form validate-form + [ + "username" value + "realname" value >>realname + "new-password" value >>encoded-password + "email" value >>email + H{ } clone >>profile - same-password-twice + users new-user [ user-exists ] unless* - "username" value - "realname" value >>realname - "new-password" value >>encoded-password - "email" value >>email - H{ } clone >>profile + login get init-user-profile - users new-user [ user-exists ] unless* - - successful-login - - login get init-user-profile - ] >>submit - ] ; + successful-login + ] >>submit ; ! ! ! Editing user profile -: ( -- form ) - "edit-profile" - "edit-profile" login-template >>edit-template - "username" add-field - "realname" add-field - "password" add-field - "new-password" add-field - "verify-password" add-field - "email" add-field ; +: ( -- action ) + + [ + logged-in-user get + [ username>> "username" set-value ] + [ realname>> "realname" set-value ] + [ email>> "email" set-value ] + tri + ] >>init -:: ( -- action ) - [let | form [ ] | - - [ - blank-values + [ "edit-profile" login-template ] >>display - logged-in-user get - [ username>> "username" set-value ] - [ realname>> "realname" set-value ] - [ email>> "email" set-value ] - tri - ] >>init + [ + uid "username" set-value - [ form edit-form ] >>display + { + { "realname" [ [ v-one-line ] v-optional ] } + { "password" [ ] } + { "new-password" [ [ v-password ] v-optional ] } + { "verify-password" [ [ v-password ] v-optional ] } + { "email" [ [ v-email ] v-optional ] } + } validate-params - [ - blank-values - uid "username" set-value + { "password" "new-password" "verify-password" } + [ value empty? not ] contains? [ + "password" value uid check-login + [ "incorrect password" validation-error ] unless - form validate-form + same-password-twice + ] when + ] >>validate - logged-in-user get + [ + logged-in-user get - { "password" "new-password" "verify-password" } - [ value empty? ] all? [ - same-password-twice + "new-password" value dup empty? + [ drop ] [ >>encoded-password ] if - "password" value uid check-login - [ login-failed ] unless + "realname" value >>realname + "email" value >>email - "new-password" value >>encoded-password - ] unless + t >>changed? - "realname" value >>realname - "email" value >>email + drop - t >>changed? - - drop - - "$login" end-flow - ] >>submit - ] ; + "$login" end-flow + ] >>submit ; ! ! ! Password recovery @@ -250,92 +222,61 @@ SYMBOL: lost-password-from '[ , password-email smtp:send-email ] "E-mail send thread" spawn drop ; -: ( -- form ) - "register" - "recover-1" login-template >>edit-template - "username" - t >>required - add-field - "email" - t >>required - add-field - "captcha" add-field ; +: ( -- action ) + + [ "recover-1" login-template ] >>display -:: ( -- action ) - [let | form [ ] | - - [ blank-values ] >>init + [ + { + { "username" [ v-username ] } + { "email" [ v-email ] } + { "captcha" [ v-captcha ] } + } validate-params + ] >>validate - [ form edit-form ] >>display + [ + "email" value "username" value + users issue-ticket [ + send-password-email + ] when* - [ - blank-values + "recover-2" login-template + ] >>submit ; - form validate-form - - "email" value "username" value - users issue-ticket [ - send-password-email - ] when* - - "recover-2" login-template serve-template - ] >>submit - ] ; - -: - "new-password" - "recover-3" login-template >>edit-template - "username" - hidden >>renderer - t >>required - add-field - "new-password" - t >>required - add-field - "verify-password" - t >>required - add-field - "ticket" - hidden >>renderer - t >>required - add-field ; - -:: ( -- action ) - [let | form [ ] | - - [ - { "username" [ v-required ] } +: ( -- action ) + + [ + { + { "username" [ v-username ] } { "ticket" [ v-required ] } - ] >>get-params + } validate-params + ] >>init - [ - [ - "username" [ get ] keep set - "ticket" [ get ] keep set - ] H{ } make-assoc values set - ] >>init + [ "recover-3" login-template ] >>display - [ edit-form ] >>display + [ + { + { "username" [ v-username ] } + { "ticket" [ v-required ] } + { "new-password" [ v-password ] } + { "verify-password" [ v-password ] } + } validate-params - [ - blank-values + same-password-twice + ] >>validate - form validate-form + [ + "ticket" value + "username" value + users claim-ticket [ + "new-password" value >>encoded-password + users update-user - same-password-twice - - "ticket" value - "username" value - users claim-ticket [ - "new-password" value >>encoded-password - users update-user - - "recover-4" login-template serve-template - ] [ - <400> - ] if* - ] >>submit - ] ; + "recover-4" login-template + ] [ + <400> + ] if* + ] >>submit ; ! ! ! Logout : ( -- action ) diff --git a/extra/http/server/auth/login/login.xml b/extra/http/server/auth/login/login.xml index d0a73a4d8b..545d7e0990 100644 --- a/extra/http/server/auth/login/login.xml +++ b/extra/http/server/auth/login/login.xml @@ -10,12 +10,12 @@ User name: - + Password: - + @@ -23,7 +23,7 @@

- +

diff --git a/extra/http/server/auth/login/recover-1.xml b/extra/http/server/auth/login/recover-1.xml index 7c72181c10..21fbe6fd39 100644 --- a/extra/http/server/auth/login/recover-1.xml +++ b/extra/http/server/auth/login/recover-1.xml @@ -10,25 +10,25 @@ - - - - + + + + - - - - + + + + - - - - + + + + - - - - + + + +
User name:
User name:
E-mail:
E-mail:
Captcha:
Captcha:
Leave the captcha blank. Spam-bots will fill it indiscriminantly, so their attempts to e-mail you will be blocked.
Leave the captcha blank. Spam-bots will fill it indiscriminantly, so their attempts to e-mail you will be blocked.
diff --git a/extra/http/server/auth/login/recover-3.xml b/extra/http/server/auth/login/recover-3.xml index 6c60b257a8..2e412d1f18 100644 --- a/extra/http/server/auth/login/recover-3.xml +++ b/extra/http/server/auth/login/recover-3.xml @@ -10,29 +10,29 @@ - - + + - - + + - - + + - - + +
Password:Password:
Verify password:Verify password:
Enter your password twice to ensure it is correct.Enter your password twice to ensure it is correct.

- +

diff --git a/extra/http/server/auth/login/register.xml b/extra/http/server/auth/login/register.xml index 9b45a7f087..9815f21945 100644 --- a/extra/http/server/auth/login/register.xml +++ b/extra/http/server/auth/login/register.xml @@ -8,62 +8,62 @@ - - - - + + + + - - - - + + + + - - - - + + + + - - - - + + + + - - - - + + + + - - - - + + + + - - - - + + + + - - - - + + + + - - - - + + + + - - - - + + + +
User name:
User name:
Real name:
Real name:
Specifying a real name is optional.
Specifying a real name is optional.
Password:
Password:
Verify:
Verify:
Enter your password twice to ensure it is correct.
Enter your password twice to ensure it is correct.
E-mail:
E-mail:
Specifying an e-mail address is optional. It enables the "recover password" feature.
Specifying an e-mail address is optional. It enables the "recover password" feature.
Captcha:
Captcha:
Leave the captcha blank. Spam-bots will fill it indiscriminantly, so their attempts to register will be blocked.
Leave the captcha blank. Spam-bots will fill it indiscriminantly, so their attempts to register will be blocked.

- +

diff --git a/extra/http/server/auth/providers/assoc/assoc.factor b/extra/http/server/auth/providers/assoc/assoc.factor index 54f96480bc..d6ba587aa0 100755 --- a/extra/http/server/auth/providers/assoc/assoc.factor +++ b/extra/http/server/auth/providers/assoc/assoc.factor @@ -15,5 +15,5 @@ M: users-in-memory get-user ( username provider -- user/f ) M: users-in-memory update-user ( user provider -- ) 2drop ; M: users-in-memory new-user ( user provider -- user/f ) - >r dup username>> r> assoc>> - 2dup key? [ 3drop f ] [ pick >r set-at r> ] if ; + [ dup username>> ] dip assoc>> + 2dup key? [ 3drop f ] [ pick [ set-at ] dip ] if ; diff --git a/extra/http/server/boilerplate/boilerplate.factor b/extra/http/server/boilerplate/boilerplate.factor index e0a4037e31..96c59edd10 100644 --- a/extra/http/server/boilerplate/boilerplate.factor +++ b/extra/http/server/boilerplate/boilerplate.factor @@ -1,73 +1,13 @@ ! Copyright (c) 2008 Slava Pestov ! See http://factorcode.org/license.txt for BSD license. -USING: accessors kernel namespaces boxes sequences strings -io io.streams.string arrays locals -html.elements -http -http.server -http.server.sessions -http.server.templating ; +USING: accessors kernel namespaces http.server html.templates +locals ; IN: http.server.boilerplate TUPLE: boilerplate < filter-responder template ; : f boilerplate boa ; -SYMBOL: title - -: set-title ( string -- ) - title get >box ; - -: write-title ( -- ) - title get value>> write ; - -SYMBOL: style - -: add-style ( string -- ) - "\n" style get push-all - style get push-all ; - -: write-style ( -- ) - style get >string write ; - -SYMBOL: atom-feed - -: set-atom-feed ( title url -- ) - 2array atom-feed get >box ; - -: write-atom-feed ( -- ) - atom-feed get value>> [ - - ] when* ; - -SYMBOL: nested-template? - -SYMBOL: next-template - -: call-next-template ( -- ) - next-template get write-html ; - -M: f call-template* drop call-next-template ; - -: with-boilerplate ( body template -- ) - [ - title get [ title set ] unless - atom-feed get [ atom-feed set ] unless - style get [ SBUF" " clone style set ] unless - - [ - [ - nested-template? on - write-response-body* - ] with-string-writer - next-template set - ] - [ call-template ] - bi* - ] with-scope ; inline - M:: boilerplate call-responder* ( path responder -- ) path responder call-next-method dup content-type>> "text/html" = [ diff --git a/extra/http/server/callbacks/callbacks.factor b/extra/http/server/callbacks/callbacks.factor index 5325ee3b55..3b819e067b 100755 --- a/extra/http/server/callbacks/callbacks.factor +++ b/extra/http/server/callbacks/callbacks.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2004 Chris Double. ! Copyright (C) 2006, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: html http http.server io kernel math namespaces +USING: http http.server io kernel math namespaces continuations calendar sequences assocs hashtables accessors arrays alarms quotations combinators fry assocs.lib ; IN: http.server.callbacks @@ -90,7 +90,7 @@ SYMBOL: current-show [ restore-request store-current-show ] when* ; : show-final ( quot -- * ) - >r redirect-to-here store-current-show r> + [ redirect-to-here store-current-show ] dip call exit-with ; inline : resuming-callback ( responder request -- id ) @@ -111,7 +111,7 @@ M: callback-responder call-responder* ( path responder -- response ) ] with-exit-continuation ; : show-page ( quot -- ) - >r redirect-to-here store-current-show r> + [ redirect-to-here store-current-show ] dip [ [ ] t register-callback swap call exit-with ] callcc1 restore-request ; inline diff --git a/extra/http/server/components/code/code.factor b/extra/http/server/components/code/code.factor deleted file mode 100644 index 19fc8c5ca8..0000000000 --- a/extra/http/server/components/code/code.factor +++ /dev/null @@ -1,20 +0,0 @@ -! Copyright (C) 2008 Slava Pestov -! See http://factorcode.org/license.txt for BSD license. -USING: splitting kernel io sequences xmode.code2html accessors -http.server.components html xml.entities ; -IN: http.server.components.code - -TUPLE: code-renderer < text-renderer mode ; - -: ( mode -- renderer ) - code-renderer new-text-renderer - swap >>mode ; - -M: code-renderer render-view* - [ - [ string-lines ] [ mode>> value ] bi* htmlize-lines - ] with-html-stream ; - -: ( id mode -- component ) - swap - swap >>renderer ; diff --git a/extra/http/server/components/components-tests.factor b/extra/http/server/components/components-tests.factor deleted file mode 100755 index ff87bb71fb..0000000000 --- a/extra/http/server/components/components-tests.factor +++ /dev/null @@ -1,133 +0,0 @@ -IN: http.server.components.tests -USING: http.server.components http.server.forms -http.server.validators namespaces tools.test kernel accessors -tuple-syntax mirrors -http http.server.actions http.server.templating.fhtml -io.streams.string io.streams.null ; - -validation-failed? off - -[ 3 ] [ "3" "n" validate ] unit-test - -[ 123 ] [ - "" - "n" - 123 >>default - validate -] unit-test - -[ f ] [ validation-failed? get ] unit-test - -[ t ] [ "3x" "n" validate validation-error? ] unit-test - -[ t ] [ validation-failed? get ] unit-test - -[ "" ] [ "" "email" validate ] unit-test - -[ "slava@jedit.org" ] [ "slava@jedit.org" "email" validate ] unit-test - -[ "slava@jedit.org" ] [ - "slava@jedit.org" - "email" - t >>required - validate -] unit-test - -[ t ] [ - "a" - "email" - t >>required - validate validation-error? -] unit-test - -[ t ] [ "a" "email" validate validation-error? ] unit-test - -TUPLE: test-tuple text number more-text ; - -: test-tuple new ; - -: ( -- form ) - "test" - "resource:extra/http/server/components/test/form.fhtml" >>view-template - "resource:extra/http/server/components/test/form.fhtml" >>edit-template - "text" - t >>required - add-field - "number" - 123 >>default - t >>required - 0 >>min-value - 10 >>max-value - add-field - "more-text" - "hi" >>default - add-field ; - -[ ] [ values set view-form write-response-body drop ] unit-test - -[ ] [ values set edit-form write-response-body drop ] unit-test - -[ TUPLE{ test-tuple number: 123 more-text: "hi" } ] [ - from-tuple - set-defaults - values-tuple -] unit-test - -[ - H{ - { "text" "fdafsa" } - { "number" "xxx" } - { "more-text" "" } - } params set - - H{ } clone values set - - [ t ] [ (validate-form) ] unit-test - - [ "fdafsa" ] [ "text" value ] unit-test - - [ t ] [ "number" value validation-error? ] unit-test -] with-scope - -[ - [ ] [ - "n" - 0 >>min-value - 10 >>max-value - "n" set - ] unit-test - - [ "123" ] [ - "123" "n" get validate value>> - ] unit-test - - [ ] [ "i" "i" set ] unit-test - - [ 3 ] [ - "3" "i" get validate - ] unit-test - - [ t ] [ - "3.9" "i" get validate validation-error? - ] unit-test - - H{ } clone values set - - [ ] [ 3 "i" set-value ] unit-test - - [ "3" ] [ [ "i" get render-view ] with-string-writer ] unit-test - - [ ] [ [ "i" get render-edit ] with-null-stream ] unit-test - - [ ] [ "t" "t" set ] unit-test - - [ ] [ "hello world" "t" set-value ] unit-test - - [ ] [ [ "t" get render-edit ] with-null-stream ] unit-test -] with-scope - -[ t ] [ "wake up sheeple" dup "n" validate = ] unit-test - -[ ] [ "password" "p" set ] unit-test - -[ ] [ "pub-date" "d" set ] unit-test diff --git a/extra/http/server/components/components.factor b/extra/http/server/components/components.factor deleted file mode 100755 index 7f2a5a9ce1..0000000000 --- a/extra/http/server/components/components.factor +++ /dev/null @@ -1,401 +0,0 @@ -! Copyright (C) 2008 Slava Pestov -! See http://factorcode.org/license.txt for BSD license. -USING: accessors namespaces kernel io math.parser assocs classes -words classes.tuple arrays sequences splitting mirrors -hashtables fry locals combinators continuations math -calendar.format html html.elements xml.entities -http.server.validators ; -IN: http.server.components - -! Renderer protocol -GENERIC: render-summary* ( value renderer -- ) -GENERIC: render-view* ( value renderer -- ) -GENERIC: render-edit* ( value id renderer -- ) - -M: object render-summary* render-view* ; - -TUPLE: field type ; - -C: field - -M: field render-view* - drop escape-string write ; - -M: field render-edit* - > =type =name =value input/> ; - -TUPLE: hidden < field ; - -: hidden ( -- renderer ) T{ hidden f "hidden" } ; inline - -! Component protocol -SYMBOL: components - -TUPLE: component id required default renderer ; - -: component ( name -- component ) - dup components get at - [ ] [ "No such component: " prepend throw ] ?if ; - -GENERIC: init ( component -- component ) - -M: component init ; - -GENERIC: validate* ( value component -- result ) -GENERIC: component-string ( value component -- string ) - -SYMBOL: values - -: value values get at ; - -: set-value values get set-at ; - -: blank-values H{ } clone values set ; - -: from-tuple values set ; - -: values-tuple values get mirror-object ; - -: render-view-or-summary ( component -- value renderer ) - [ id>> value ] [ component-string ] [ renderer>> ] tri ; - -: render-view ( component -- ) - render-view-or-summary render-view* ; - -: render-summary ( component -- ) - render-view-or-summary render-summary* ; - -> ] [ renderer>> ] bi render-edit* ; - -: render-edit-error ( component -- ) - [ id>> value ] keep - [ [ value>> ] dip render-edit-string ] - [ drop reason>> render-error ] 2bi ; - -: value-or-default ( component -- value ) - [ id>> value ] [ default>> ] bi or ; - -: render-edit-value ( component -- ) - [ value-or-default ] - [ component-string ] - [ render-edit-string ] - tri ; - -PRIVATE> - -: render-edit ( component -- ) - dup id>> value validation-error? - [ render-edit-error ] [ render-edit-value ] if ; - -: validate ( value component -- result ) - '[ - , - over empty? [ - [ default>> [ v-default ] when* ] - [ required>> [ v-required ] when ] - bi - ] [ validate* ] if - ] with-validator ; - -: new-component ( id class renderer -- component ) - swap new - swap >>renderer - swap >>id - init ; inline - -! String input fields -TUPLE: string < component one-line min-length max-length ; - -: new-string ( id class -- component ) - "text" new-component - t >>one-line ; inline - -: ( id -- component ) - string new-string ; - -M: string validate* - [ one-line>> [ v-one-line ] when ] - [ min-length>> [ v-min-length ] when* ] - [ max-length>> [ v-max-length ] when* ] - tri ; - -M: string component-string - drop ; - -! Username fields -TUPLE: username < string ; - -M: username init - 2 >>min-length - 20 >>max-length ; - -: ( id -- component ) - username new-string ; - -M: username validate* - call-next-method v-one-word ; - -! E-mail fields -TUPLE: email < string ; - -: ( id -- component ) - email new-string - 5 >>min-length - 60 >>max-length ; - -M: email validate* - call-next-method dup empty? [ v-email ] unless ; - -! URL fields -TUPLE: url < string ; - -: ( id -- component ) - url new-string - 5 >>min-length - 60 >>max-length ; - -M: url validate* - call-next-method dup empty? [ v-url ] unless ; - -! Don't send passwords back to the user -TUPLE: password-renderer < field ; - -: password-renderer T{ password-renderer f "password" } ; - -: blank-password >r >r drop "" r> r> ; - -M: password-renderer render-edit* - blank-password call-next-method ; - -! Password fields -TUPLE: password < string ; - -M: password init - 6 >>min-length - 60 >>max-length ; - -: ( id -- component ) - password new-string - password-renderer >>renderer ; - -M: password validate* - call-next-method v-one-word ; - -! Number fields -TUPLE: number < string min-value max-value ; - -: ( id -- component ) - number new-string ; - -M: number validate* - [ v-number ] [ - [ min-value>> [ v-min-value ] when* ] - [ max-value>> [ v-max-value ] when* ] - bi - ] bi* ; - -M: number component-string - drop dup [ number>string ] when ; - -! Integer fields -TUPLE: integer < number ; - -: ( id -- component ) - integer new-string ; - -M: integer validate* - call-next-method v-integer ; - -! Simple captchas -TUPLE: captcha < string ; - -: ( id -- component ) - captcha new-string ; - -M: captcha validate* - drop v-captcha ; - -! Text areas -TUPLE: text-renderer rows cols ; - -: new-text-renderer ( class -- renderer ) - new - 60 >>cols - 20 >>rows ; - -: ( -- renderer ) - text-renderer new-text-renderer ; - -M: text-renderer render-view* - drop escape-string write ; - -M: text-renderer render-edit* - ; - -TUPLE: text < string ; - -: new-text ( id class -- component ) - new-string - f >>one-line - >>renderer ; - -: ( id -- component ) - text new-text ; - -! HTML text component -TUPLE: html-text-renderer < text-renderer ; - -: ( -- renderer ) - html-text-renderer new-text-renderer ; - -M: html-text-renderer render-view* - drop escape-string write ; - -TUPLE: html-text < text ; - -: ( id -- component ) - html-text new-text - >>renderer ; - -! Date component -TUPLE: date < string ; - -: ( id -- component ) - date new-string ; - -M: date component-string - drop timestamp>string ; - -! Link components - -GENERIC: link-title ( obj -- string ) -GENERIC: link-href ( obj -- url ) - -SINGLETON: link-renderer - -M: link-renderer render-view* - drop link-title escape-string write ; - -TUPLE: link < string ; - -: ( id -- component ) - link new-string - link-renderer >>renderer ; - -! List components -SYMBOL: +plain+ -SYMBOL: +ordered+ -SYMBOL: +unordered+ - -TUPLE: list-renderer component type ; - -C: list-renderer - -: render-plain-list ( seq component quot -- ) - '[ , component>> renderer>> @ ] each ; inline - -: render-li-list ( seq component quot -- ) - '[
  • @
    • ] render-plain-list ; inline - -: render-ordered-list ( seq quot component -- ) -
      render-li-list
    ; inline - -: render-unordered-list ( seq quot component -- ) -
      render-li-list
    ; inline - -: render-list ( value renderer quot -- ) - over type>> { - { +plain+ [ render-plain-list ] } - { +ordered+ [ render-ordered-list ] } - { +unordered+ [ render-unordered-list ] } - } case ; inline - -M: list-renderer render-view* - [ render-view* ] render-list ; - -M: list-renderer render-summary* - [ render-summary* ] render-list ; - -TUPLE: list < component ; - -: ( id component type -- list ) - list swap new-component ; - -M: list component-string drop ; - -! Choice -TUPLE: choice-renderer choices ; - -C: choice-renderer - -M: choice-renderer render-view* - drop escape-string write ; - -: render-option ( text selected? -- ) - ; - -: render-options ( options selected -- ) - '[ dup , member? render-option ] each ; - -M: choice-renderer render-edit* - ; - -TUPLE: choice < string ; - -: ( id choices -- component ) - swap choice new-string - swap >>renderer ; - -! Menu -TUPLE: menu-renderer choices size ; - -: ( choices -- renderer ) - 5 menu-renderer boa ; - -M:: menu-renderer render-edit* ( value id renderer -- ) - ; - -TUPLE: menu < string ; - -: ( id choices -- component ) - swap menu new-string - swap >>renderer ; - -! Checkboxes -TUPLE: checkbox-renderer label ; - -C: checkbox-renderer - -M: checkbox-renderer render-edit* - - label>> escape-string write - ; - -TUPLE: checkbox < string ; - -: ( id label -- component ) - checkbox swap new-component ; diff --git a/extra/http/server/components/farkup/farkup.factor b/extra/http/server/components/farkup/farkup.factor deleted file mode 100755 index 87b7170bbf..0000000000 --- a/extra/http/server/components/farkup/farkup.factor +++ /dev/null @@ -1,17 +0,0 @@ -! Copyright (C) 2008 Slava Pestov -! See http://factorcode.org/license.txt for BSD license. -USING: splitting kernel io sequences farkup accessors -http.server.components xml.entities ; -IN: http.server.components.farkup - -TUPLE: farkup-renderer < text-renderer ; - -: ( -- renderer ) - farkup-renderer new-text-renderer ; - -M: farkup-renderer render-view* - drop string-lines "\n" join convert-farkup write ; - -: ( id -- component ) - - >>renderer ; diff --git a/extra/http/server/components/inspector/inspector.factor b/extra/http/server/components/inspector/inspector.factor deleted file mode 100644 index 42366b57e4..0000000000 --- a/extra/http/server/components/inspector/inspector.factor +++ /dev/null @@ -1,17 +0,0 @@ -! Copyright (C) 2008 Slava Pestov -! See http://factorcode.org/license.txt for BSD license. -USING: splitting kernel io sequences inspector accessors -http.server.components xml.entities html ; -IN: http.server.components.inspector - -SINGLETON: inspector-renderer - -M: inspector-renderer render-view* - drop [ describe ] with-html-stream ; - -TUPLE: inspector < component ; - -M: inspector component-string drop ; - -: ( id -- component ) - inspector inspector-renderer new-component ; diff --git a/extra/http/server/components/test/form.fhtml b/extra/http/server/components/test/form.fhtml deleted file mode 100755 index d3f5a12faa..0000000000 --- a/extra/http/server/components/test/form.fhtml +++ /dev/null @@ -1 +0,0 @@ - diff --git a/extra/http/server/crud/crud.factor b/extra/http/server/crud/crud.factor deleted file mode 100755 index 28c1b02005..0000000000 --- a/extra/http/server/crud/crud.factor +++ /dev/null @@ -1,67 +0,0 @@ -! Copyright (C) 2008 Slava Pestov. -! See http://factorcode.org/license.txt for BSD license. -USING: kernel namespaces db.tuples math.parser -accessors fry locals hashtables -http.server -http.server.actions -http.server.components -http.server.forms -http.server.validators ; -IN: http.server.crud - -:: ( form ctor -- action ) - - { { "id" [ v-number ] } } >>get-params - - [ "id" get ctor call select-tuple from-tuple ] >>init - - [ form view-form ] >>display ; - -: ( id next -- response ) - swap number>string "id" associate ; - -:: ( form ctor next -- action ) - - { { "id" [ [ v-number ] v-optional ] } } >>get-params - - [ - "id" get ctor call - - "id" get - [ select-tuple from-tuple ] - [ from-tuple form set-defaults ] - if - ] >>init - - [ form edit-form ] >>display - - [ - f ctor call from-tuple - - form validate-form - - values-tuple - "id" value [ update-tuple ] [ insert-tuple ] if - - "id" value next - ] >>submit ; - -:: ( ctor next -- action ) - - { { "id" [ v-number ] } } >>post-params - - [ - "id" get ctor call delete-tuples - - next f - ] >>submit ; - -:: ( form ctor -- action ) - - [ - blank-values - - f ctor call select-tuples "list" set-value - - form view-form - ] >>display ; diff --git a/extra/http/server/db/db.factor b/extra/http/server/db/db.factor index d0bd449457..73d4c35e2c 100755 --- a/extra/http/server/db/db.factor +++ b/extra/http/server/db/db.factor @@ -6,7 +6,7 @@ IN: http.server.db TUPLE: db-persistence < filter-responder pool ; -: ( responder db params -- responder' ) +: ( responder params db -- responder' ) db-persistence boa ; M: db-persistence call-responder* diff --git a/extra/http/server/forms/forms.factor b/extra/http/server/forms/forms.factor deleted file mode 100644 index 92fb25bb16..0000000000 --- a/extra/http/server/forms/forms.factor +++ /dev/null @@ -1,79 +0,0 @@ -! Copyright (C) 2008 Slava Pestov -! See http://factorcode.org/license.txt for BSD license. -USING: kernel accessors assocs namespaces io.files sequences fry -http.server -http.server.actions -http.server.components -http.server.validators -http.server.templating ; -IN: http.server.forms - -TUPLE: form < component -view-template edit-template summary-template -components ; - -M: form init V{ } clone >>components ; - -: ( id -- form ) - form f new-component - dup >>renderer ; - -: add-field ( form component -- form ) - dup id>> pick components>> set-at ; - -: set-components ( form -- ) - components>> components set ; - -: with-form ( form quot -- ) - [ [ set-components ] [ call ] bi* ] with-scope ; inline - -: set-defaults ( form -- ) - [ - components get [ - swap values get [ - swap default>> or - ] change-at - ] assoc-each - ] with-form ; - -: ( form template -- response ) - [ components>> components set ] [ ] bi* ; - -: view-form ( form -- response ) - dup view-template>> ; - -: edit-form ( form -- response ) - dup edit-template>> ; - -: 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-form ( value form template -- ) - [ - [ from-tuple ] - [ set-components ] - [ call-template ] - tri* - ] with-scope ; - -M: form component-string drop ; - -M: form render-summary* - dup summary-template>> render-form ; - -M: form render-view* - dup view-template>> render-form ; - -M: form render-edit* - nip dup edit-template>> render-form ; diff --git a/extra/http/server/server-tests.factor b/extra/http/server/server-tests.factor index af27eda527..0aed425ade 100755 --- a/extra/http/server/server-tests.factor +++ b/extra/http/server/server-tests.factor @@ -31,7 +31,7 @@ C: mock-responder M: mock-responder call-responder* nip path>> on - "text/plain" ; + [ ] ; : check-dispatch ( tag path -- ? ) H{ } clone base-paths set @@ -84,7 +84,7 @@ C: path-check-responder M: path-check-responder call-responder* drop - "text/plain" swap >array >>body ; + >array ; [ { "c" } ] [ H{ } clone base-paths set @@ -125,7 +125,7 @@ C: base-path-check-responder M: base-path-check-responder call-responder* 2drop "$funny-dispatcher" resolve-base-path - "text/plain" swap >>body ; + ; [ ] [ diff --git a/extra/http/server/server.factor b/extra/http/server/server.factor index 4e561220f9..d68c66b829 100755 --- a/extra/http/server/server.factor +++ b/extra/http/server/server.factor @@ -1,10 +1,11 @@ ! Copyright (C) 2003, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: assocs kernel namespaces io io.timeouts strings splitting -threads sequences prettyprint io.server logging calendar -http html html.elements accessors math.parser combinators.lib -tools.vocabs debugger continuations random combinators -destructors io.encodings.8-bit fry classes words ; +threads sequences prettyprint io.server logging calendar http +html.streams html.elements accessors math.parser +combinators.lib tools.vocabs debugger continuations random +combinators destructors io.encodings.8-bit fry classes words +math rss json.writer ; IN: http.server ! path is a sequence of path component strings @@ -18,14 +19,27 @@ GENERIC: call-responder* ( path responder -- response ) { "POST" [ post-data>> ] } } case ; -: ( content-type -- response ) +: ( body content-type -- response ) 200 >>code "Document follows" >>message - swap >>content-type ; + swap >>content-type + swap >>body ; -: ( quot -- response ) - "text/html" swap >>body ; +: ( body -- response ) + "text/plain" ; + +: ( body -- response ) + "text/html" ; + +: ( body -- response ) + "text/xml" ; + +: ( feed -- response ) + '[ , feed>xml ] "text/xml" ; + +: ( obj -- response ) + '[ , >json ] "application/json" ; TUPLE: trivial-responder response ; @@ -86,9 +100,7 @@ SYMBOL: link-hook : resolve-base-path ( string -- string' ) "$" ?head [ [ - "/" split1 >r - base-path [ "/" % % ] each "/" % - r> % + "/" split1 [ base-path [ "/" % % ] each "/" % ] dip % ] "" make ] when ; @@ -115,7 +127,7 @@ SYMBOL: form-hook request-url ; : replace-last-component ( path with -- path' ) - >r "/" last-split1 drop "/" r> 3append ; + [ "/" last-split1 drop "/" ] dip 3append ; : relative-redirect ( to query -- url ) request get clone @@ -128,7 +140,7 @@ SYMBOL: form-hook { { [ over "http://" head? ] [ link>string ] } { [ over "/" head? ] [ absolute-redirect ] } - { [ over "$" head? ] [ >r resolve-base-path r> derive-url ] } + { [ over "$" head? ] [ [ resolve-base-path ] dip derive-url ] } [ relative-redirect ] } cond ; @@ -163,7 +175,7 @@ TUPLE: dispatcher default responders ; [ nip ] [ drop default>> ] if ] [ over first over responders>> at* - [ >r drop rest-slice r> ] [ drop default>> ] if + [ [ drop rest-slice ] dip ] [ drop default>> ] if ] if ; M: dispatcher call-responder* ( path dispatcher -- response ) @@ -274,9 +286,11 @@ SYMBOL: exit-continuation ] with-destructors ; : httpd ( port -- ) - internet-server "http.server" - latin1 [ handle-client ] with-server ; + dup integer? [ internet-server ] when + "http.server" latin1 + [ handle-client ] with-server ; -: httpd-main ( -- ) 8888 httpd ; +: httpd-main ( -- ) + 8888 httpd ; MAIN: httpd-main diff --git a/extra/http/server/sessions/sessions-tests.factor b/extra/http/server/sessions/sessions-tests.factor index 0d98bf2150..8ea312dcb5 100755 --- a/extra/http/server/sessions/sessions-tests.factor +++ b/extra/http/server/sessions/sessions-tests.factor @@ -6,7 +6,7 @@ sequences db db.sqlite continuations ; : with-session [ - >r [ save-session-after ] [ session set ] bi r> call + [ [ save-session-after ] [ session set ] bi ] dip call ] with-destructors ; inline TUPLE: foo ; @@ -18,7 +18,7 @@ M: foo init-session* drop 0 "x" sset ; M: foo call-responder* 2drop "x" [ 1+ ] schange - "text/html" [ "x" sget pprint ] >>body ; + [ "x" sget pprint ] ; : url-responder-mock-test [ @@ -44,9 +44,7 @@ M: foo call-responder* : - [ - "text/plain" exit-with - ] >>display ; + [ [ ] exit-with ] >>display ; [ "auth-test.db" temp-file sqlite-db delete-file ] ignore-errors diff --git a/extra/http/server/static/static.factor b/extra/http/server/static/static.factor index 2f7a6eb221..8814004589 100755 --- a/extra/http/server/static/static.factor +++ b/extra/http/server/static/static.factor @@ -1,9 +1,10 @@ ! Copyright (C) 2004, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: calendar html io io.files kernel math math.order +USING: calendar io io.files kernel math math.order math.parser http http.server namespaces parser sequences strings assocs hashtables debugger http.mime sorting html.elements -logging calendar.format accessors io.encodings.binary fry ; +html.templates.fhtml logging calendar.format accessors +io.encodings.binary fry xml.entities destructors ; IN: http.server.static ! special maps mime types to quots with effect ( path -- ) @@ -28,16 +29,14 @@ TUPLE: file-responder root hook special allow-listings ; swap >>root H{ } clone >>special ; +: (serve-static) ( path mime-type -- response ) + [ [ binary &dispose ] dip ] + [ drop file-info [ size>> ] [ modified>> ] bi ] 2bi + [ "content-length" set-header ] + [ "last-modified" set-header ] bi* ; + : ( root -- responder ) - [ - - swap [ - file-info - [ size>> "content-length" set-header ] - [ modified>> "last-modified" set-header ] bi - ] - [ '[ , binary output-stream get stream-copy ] >>body ] bi - ] ; + [ (serve-static) ] ; : serve-static ( filename mime-type -- response ) over modified-since? @@ -57,18 +56,18 @@ TUPLE: file-responder root hook special allow-listings ; : file. ( name dirp -- ) [ "/" append ] when - dup write ; + dup escape-string write ; : directory. ( path -- ) dup file-name [ - [

    file-name write

    ] + [

    file-name escape-string write

    ] [
      directory sort-keys [
    • file.
      • ] assoc-each
    ] bi - ] simple-html-document ; + ] simple-page ; : list-directory ( directory -- response ) file-responder get allow-listings>> [ @@ -99,3 +98,9 @@ M: file-responder call-responder* ( path responder -- response ) file-responder set ".." over member? [ drop <400> ] [ "/" join serve-object ] if ; + +! file responder integration +: enable-fhtml ( responder -- responder ) + [ ] + "application/x-factor-server-page" + pick special>> set-at ; diff --git a/extra/http/server/templating/chloe/chloe-tests.factor b/extra/http/server/templating/chloe/chloe-tests.factor deleted file mode 100644 index 61f72a2f14..0000000000 --- a/extra/http/server/templating/chloe/chloe-tests.factor +++ /dev/null @@ -1,89 +0,0 @@ -USING: http.server.templating http.server.templating.chloe -http.server.components http.server.boilerplate tools.test -io.streams.string kernel sequences ascii boxes namespaces xml -splitting ; -IN: http.server.templating.chloe.tests - -[ f ] [ f parse-query-attr ] unit-test - -[ f ] [ "" parse-query-attr ] unit-test - -[ H{ { "a" "b" } } ] [ - blank-values - "b" "a" set-value - "a" parse-query-attr -] unit-test - -[ H{ { "a" "b" } { "c" "d" } } ] [ - blank-values - "b" "a" set-value - "d" "c" set-value - "a,c" parse-query-attr -] unit-test - -: run-template - with-string-writer [ "\r\n\t" member? not ] filter - "?>" split1 nip ; inline - -: test-template ( name -- template ) - "resource:extra/http/server/templating/chloe/test/" - swap - ".xml" 3append ; - -[ "Hello world" ] [ - [ - "test1" test-template call-template - ] run-template -] unit-test - -[ "Blah blah" "Hello world" ] [ - [ - title set - [ - "test2" test-template call-template - ] run-template - title get box> - ] with-scope -] unit-test - -[ "Hello worldBlah blah" ] [ - [ - [ - "test2" test-template call-template - ] "test3" test-template with-boilerplate - ] run-template -] unit-test - -: test4-aux? t ; - -[ "True" ] [ - [ - "test4" test-template call-template - ] run-template -] unit-test - -: test5-aux? f ; - -[ "" ] [ - [ - "test5" test-template call-template - ] run-template -] unit-test - -SYMBOL: test6-aux? - -[ "True" ] [ - [ - test6-aux? on - "test6" test-template call-template - ] run-template -] unit-test - -SYMBOL: test7-aux? - -[ "" ] [ - [ - test7-aux? off - "test7" test-template call-template - ] run-template -] unit-test diff --git a/extra/http/server/templating/templating.factor b/extra/http/server/templating/templating.factor deleted file mode 100644 index 73f6095eae..0000000000 --- a/extra/http/server/templating/templating.factor +++ /dev/null @@ -1,27 +0,0 @@ -USING: accessors kernel fry io io.encodings.utf8 io.files -http http.server debugger prettyprint continuations ; -IN: http.server.templating - -MIXIN: template - -GENERIC: call-template* ( template -- ) - -ERROR: template-error template error ; - -M: template-error error. - "Error while processing template " write - [ template>> pprint ":" print nl ] - [ error>> error. ] - bi ; - -: call-template ( template -- ) - [ call-template* ] [ template-error ] recover ; - -M: template write-response-body* call-template ; - -: template-convert ( template output -- ) - utf8 [ call-template ] with-file-writer ; - -! responder integration -: serve-template ( template -- response ) - '[ , call-template ] ; diff --git a/extra/http/server/validators/validators-tests.factor b/extra/http/server/validators/validators-tests.factor deleted file mode 100755 index 5e845705ab..0000000000 --- a/extra/http/server/validators/validators-tests.factor +++ /dev/null @@ -1,29 +0,0 @@ -IN: http.server.validators.tests -USING: kernel sequences tools.test http.server.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 diff --git a/extra/http/server/validators/validators.factor b/extra/http/server/validators/validators.factor deleted file mode 100755 index 7415787c79..0000000000 --- a/extra/http/server/validators/validators.factor +++ /dev/null @@ -1,85 +0,0 @@ -! 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 ; -IN: http.server.validators - -SYMBOL: validation-failed? - -TUPLE: validation-error value reason ; - -C: validation-error - -: with-validator ( value quot -- result ) - [ validation-failed? on ] recover ; inline - -: 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 ; diff --git a/extra/irc/authors.txt b/extra/irc/client/authors.txt similarity index 100% rename from extra/irc/authors.txt rename to extra/irc/client/authors.txt diff --git a/extra/irc/client/client.factor b/extra/irc/client/client.factor new file mode 100644 index 0000000000..19dca48e1d --- /dev/null +++ b/extra/irc/client/client.factor @@ -0,0 +1,275 @@ +! Copyright (C) 2007 Doug Coleman, Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: arrays combinators concurrency.mailboxes concurrency.futures io + io.encodings.8-bit io.sockets kernel namespaces sequences + sequences.lib splitting threads calendar classes.tuple + ascii assocs accessors destructors ; +IN: irc.client + +! ====================================== +! Setup and running objects +! ====================================== + +SYMBOL: current-irc-client + +: irc-port 6667 ; ! Default irc port + +! "setup" objects +TUPLE: irc-profile server port nickname password ; +C: irc-profile + +TUPLE: irc-channel-profile name password ; +: ( -- irc-channel-profile ) irc-channel-profile new ; + +! "live" objects +TUPLE: nick name channels log ; +C: nick + +TUPLE: irc-client profile nick stream in-messages out-messages join-messages + listeners is-running ; +: ( profile -- irc-client ) + f V{ } clone V{ } clone + f H{ } clone f irc-client boa ; + +TUPLE: irc-listener in-messages out-messages ; +: ( -- irc-listener ) + irc-listener boa ; + +! ====================================== +! Message objects +! ====================================== + +SINGLETON: irc-end ! Message used when the client isn't running anymore + +TUPLE: irc-message line prefix command parameters trailing timestamp ; +TUPLE: logged-in < irc-message name ; +TUPLE: ping < irc-message ; +TUPLE: join < irc-message ; +TUPLE: part < irc-message name channel ; +TUPLE: quit < irc-message ; +TUPLE: privmsg < irc-message name ; +TUPLE: kick < irc-message channel who ; +TUPLE: roomlist < irc-message channel names ; +TUPLE: nick-in-use < irc-message asterisk name ; +TUPLE: notice < irc-message type ; +TUPLE: mode < irc-message name channel mode ; +TUPLE: unhandled < irc-message ; + + ( -- irc-client ) current-irc-client get ; +: irc-stream> ( -- stream ) irc-client> stream>> ; +: irc-write ( s -- ) irc-stream> stream-write ; +: irc-print ( s -- ) irc-stream> [ stream-print ] keep stream-flush ; + +! ====================================== +! IRC client messages +! ====================================== + +: /NICK ( nick -- ) + "NICK " irc-write irc-print ; + +: /LOGIN ( nick -- ) + dup /NICK + "USER " irc-write irc-write + " hostname servername :irc.factor" irc-print ; + +: /CONNECT ( server port -- stream ) + latin1 drop ; + +: /JOIN ( channel password -- ) + "JOIN " irc-write + [ " :" swap 3append ] when* irc-print ; + +: /PART ( channel text -- ) + [ "PART " irc-write irc-write ] dip + " :" irc-write irc-print ; + +: /KICK ( channel who -- ) + [ "KICK " irc-write irc-write ] dip + " " irc-write irc-print ; + +: /PRIVMSG ( nick line -- ) + [ "PRIVMSG " irc-write irc-write ] dip + " :" irc-write irc-print ; + +: /ACTION ( nick line -- ) + [ 1 , "ACTION " % % 1 , ] "" make /PRIVMSG ; + +: /QUIT ( text -- ) + "QUIT :" irc-write irc-print ; + +: /PONG ( text -- ) + "PONG " irc-write irc-print ; + +! ====================================== +! Server message handling +! ====================================== + +USE: prettyprint + +GENERIC: handle-incoming-irc ( irc-message -- ) + +M: irc-message handle-incoming-irc ( irc-message -- ) + . ; + +M: logged-in handle-incoming-irc ( logged-in -- ) + name>> irc-client> nick>> (>>name) ; + +M: ping handle-incoming-irc ( ping -- ) + trailing>> /PONG ; + +M: nick-in-use handle-incoming-irc ( nick-in-use -- ) + name>> "_" append /NICK ; + +M: privmsg handle-incoming-irc ( privmsg -- ) + dup name>> irc-client> listeners>> at + [ in-messages>> mailbox-put ] [ drop ] if* ; + +M: join handle-incoming-irc ( join -- ) + irc-client> join-messages>> mailbox-put ; + +! ====================================== +! Client message handling +! ====================================== + +GENERIC: handle-outgoing-irc ( obj -- ) + +M: privmsg handle-outgoing-irc ( privmsg -- ) + [ name>> ] [ trailing>> ] bi /PRIVMSG ; + +! ====================================== +! Message parsing +! ====================================== + +: split-at-first ( seq separators -- before after ) + dupd [ member? ] curry find + [ cut 1 tail ] + [ swap ] + if ; + +: remove-heading-: ( seq -- seq ) dup ":" head? [ 1 tail ] when ; + +: parse-name ( string -- string ) + remove-heading-: "!" split-at-first drop ; + +: split-prefix ( string -- string/f string ) + dup ":" head? + [ remove-heading-: " " split1 ] + [ f swap ] + if ; + +: split-trailing ( string -- string string/f ) + ":" split1 ; + +: string>irc-message ( string -- object ) + dup split-prefix split-trailing + [ [ blank? ] trim " " split unclip swap ] dip + now irc-message boa ; + +: parse-irc-line ( string -- message ) + string>irc-message + dup command>> { + { "PING" [ \ ping ] } + { "NOTICE" [ \ notice ] } + { "001" [ \ logged-in ] } + { "433" [ \ nick-in-use ] } + { "JOIN" [ \ join ] } + { "PART" [ \ part ] } + { "PRIVMSG" [ \ privmsg ] } + { "QUIT" [ \ quit ] } + { "MODE" [ \ mode ] } + { "KICK" [ \ kick ] } + [ drop \ unhandled ] + } case + [ [ tuple-slots ] [ parameters>> ] bi append ] dip prefix >tuple ; + +! ====================================== +! Reader/Writer +! ====================================== + +: stream-readln-or-close ( stream -- str/f ) + dup stream-readln [ nip ] [ dispose f ] if* ; + +: handle-reader-message ( irc-message -- ) + irc-client> in-messages>> mailbox-put ; + +: handle-stream-close ( -- ) + irc-client> f >>is-running in-messages>> irc-end swap mailbox-put ; + +: reader-loop ( -- ) + irc-client> stream>> stream-readln-or-close [ + parse-irc-line handle-reader-message + ] [ + handle-stream-close + ] if* ; + +: writer-loop ( -- ) + irc-client> out-messages>> mailbox-get handle-outgoing-irc ; + +! ====================================== +! Processing loops +! ====================================== + +: in-multiplexer-loop ( -- ) + irc-client> in-messages>> mailbox-get handle-incoming-irc ; + +! FIXME: Hack, this should be handled better +GENERIC: add-name ( name obj -- obj ) +M: object add-name nip ; +M: privmsg add-name swap >>name ; + +: listener-loop ( name -- ) ! FIXME: take different values from the stack? + dup irc-client> listeners>> at [ + out-messages>> mailbox-get add-name + irc-client> out-messages>> + mailbox-put + ] [ drop ] if* ; + +: spawn-irc-loop ( quot name -- ) + [ [ irc-client> is-running>> ] compose ] dip + spawn-server drop ; + +: spawn-irc ( -- ) + [ reader-loop ] "irc-reader-loop" spawn-irc-loop + [ writer-loop ] "irc-writer-loop" spawn-irc-loop + [ in-multiplexer-loop ] "in-multiplexer-loop" spawn-irc-loop ; + +! ====================================== +! Listener join request handling +! ====================================== + +: make-registered-listener ( join -- listener ) + swap trailing>> + dup [ listener-loop ] curry "listener" spawn-irc-loop + [ irc-client> listeners>> set-at ] curry keep ; + +: make-join-future ( name -- future ) + [ [ swap trailing>> = ] curry ! compare name with channel name + irc-client> join-messages>> 60 seconds rot mailbox-get-timeout? + make-registered-listener ] + curry future ; + +PRIVATE> + +: (connect-irc) ( irc-client -- ) + [ profile>> [ server>> ] keep port>> /CONNECT ] keep + swap >>stream + t >>is-running drop ; + +: connect-irc ( irc-client -- ) + dup current-irc-client [ + [ (connect-irc) ] [ profile>> nickname>> /LOGIN ] bi + spawn-irc + ] with-variable ; + +: listen-to ( irc-client name -- future ) + swap current-irc-client [ [ f /JOIN ] keep make-join-future ] with-variable ; + +! shorcut for privmsgs, etc +: sender>> ( obj -- string ) + prefix>> parse-name ; diff --git a/extra/irc/summary.txt b/extra/irc/client/summary.txt similarity index 100% rename from extra/irc/summary.txt rename to extra/irc/client/summary.txt diff --git a/extra/irc/irc.factor b/extra/irc/irc.factor deleted file mode 100755 index 9a278fb67f..0000000000 --- a/extra/irc/irc.factor +++ /dev/null @@ -1,286 +0,0 @@ -! Copyright (C) 2007 Doug Coleman, Slava Pestov. -! See http://factorcode.org/license.txt for BSD license. -USING: arrays calendar combinators channels concurrency.messaging fry io - io.encodings.8-bit io.sockets kernel math namespaces sequences - sequences.lib splitting strings threads - continuations destructors classes.tuple ascii accessors ; -IN: irc - -! utils -: split-at-first ( seq separators -- before after ) - dupd '[ , member? ] find - [ cut rest ] - [ swap ] - if ; - -: spawn-server-linked ( quot name -- thread ) - >r '[ , [ ] [ ] while ] r> - spawn-linked ; -! --- - -! Default irc port -: irc-port 6667 ; - -! Message used when the client isn't running anymore -SINGLETON: irc-end - -! "setup" objects -TUPLE: irc-profile server port nickname password default-channels ; -C: irc-profile - -TUPLE: irc-channel-profile name password auto-rejoin ; -C: irc-channel-profile - -! "live" objects -TUPLE: nick name channels log ; -C: nick - -TUPLE: irc-client profile nick stream stream-channel controller-channel - listeners is-running ; -: ( profile -- irc-client ) - f V{ } clone V{ } clone - f V{ } clone f irc-client boa ; - -USE: prettyprint -TUPLE: irc-listener channel ; -! FIXME: spawn-server-linked con manejo de excepciones, mandar un mensaje final (ya se maneja esto al recibir mensajes del channel? ) -! tener la opción de dejar de correr un client?? -: ( quot -- irc-listener ) - irc-listener boa swap - [ - [ channel>> '[ , from ] ] - [ '[ , curry f spawn drop ] ] - bi* compose "irc-listener" spawn-server-linked drop - ] [ drop ] 2bi ; - -! TUPLE: irc-channel name topic members log attributes ; -! C: irc-channel - -! the delegate of all irc messages -TUPLE: irc-message line prefix command parameters trailing timestamp ; -C: irc-message - -! "irc message" objects -TUPLE: logged-in < irc-message name ; -C: logged-in - -TUPLE: ping < irc-message ; -C: ping - -TUPLE: join_ < irc-message ; -C: join_ - -TUPLE: part < irc-message name channel ; -C: part - -TUPLE: quit ; -C: quit - -TUPLE: privmsg < irc-message name ; -C: privmsg - -TUPLE: kick < irc-message channel who ; -C: kick - -TUPLE: roomlist < irc-message channel names ; -C: roomlist - -TUPLE: nick-in-use < irc-message name ; -C: nick-in-use - -TUPLE: notice < irc-message type ; -C: notice - -TUPLE: mode < irc-message name channel mode ; -C: mode - -TUPLE: unhandled < irc-message ; -C: unhandled - -SYMBOL: irc-client -: irc-client> ( -- irc-client ) irc-client get ; -: irc-stream> ( -- stream ) irc-client> stream>> ; - -: remove-heading-: ( seq -- seq ) dup ":" head? [ rest ] when ; - -: parse-name ( string -- string ) - remove-heading-: "!" split-at-first drop ; - -: sender>> ( obj -- string ) - prefix>> parse-name ; - -: split-prefix ( string -- string/f string ) - dup ":" head? - [ remove-heading-: " " split1 ] - [ f swap ] - if ; - -: split-trailing ( string -- string string/f ) - ":" split1 ; - -: string>irc-message ( string -- object ) - dup split-prefix split-trailing - [ [ blank? ] trim " " split unclip swap ] dip - now ; - -: me? ( name -- ? ) - irc-client> nick>> name>> = ; - -: irc-write ( s -- ) - irc-stream> stream-write ; - -: irc-print ( s -- ) - irc-stream> [ stream-print ] keep stream-flush ; - -! Irc commands - -: NICK ( nick -- ) - "NICK " irc-write irc-print ; - -: LOGIN ( nick -- ) - dup NICK - "USER " irc-write irc-write - " hostname servername :irc.factor" irc-print ; - -: CONNECT ( server port -- stream ) - latin1 drop ; - -: JOIN ( channel password -- ) - "JOIN " irc-write - [ " :" swap 3append ] when* irc-print ; - -: PART ( channel text -- ) - [ "PART " irc-write irc-write ] dip - " :" irc-write irc-print ; - -: KICK ( channel who -- ) - [ "KICK " irc-write irc-write ] dip - " " irc-write irc-print ; - -: PRIVMSG ( nick line -- ) - [ "PRIVMSG " irc-write irc-write ] dip - " :" irc-write irc-print ; - -: SAY ( nick line -- ) - PRIVMSG ; - -: ACTION ( nick line -- ) - [ 1 , "ACTION " % % 1 , ] "" make PRIVMSG ; - -: QUIT ( text -- ) - "QUIT :" irc-write irc-print ; - -: join-channel ( channel-profile -- ) - [ name>> ] keep password>> JOIN ; - -: irc-connect ( irc-client -- ) - [ profile>> [ server>> ] keep port>> CONNECT ] keep - swap >>stream t >>is-running drop ; - -GENERIC: handle-irc ( obj -- ) - -M: object handle-irc ( obj -- ) - drop ; - -M: logged-in handle-irc ( obj -- ) - name>> - irc-client> [ nick>> swap >>name drop ] keep - profile>> default-channels>> [ join-channel ] each ; - -M: ping handle-irc ( obj -- ) - "PONG " irc-write - trailing>> irc-print ; - -M: nick-in-use handle-irc ( obj -- ) - name>> "_" append NICK ; - -: parse-irc-line ( string -- message ) - string>irc-message - dup command>> { - { "PING" [ \ ping ] } - { "NOTICE" [ \ notice ] } - { "001" [ \ logged-in ] } - { "433" [ \ nick-in-use ] } - { "JOIN" [ \ join_ ] } - { "PART" [ \ part ] } - { "PRIVMSG" [ \ privmsg ] } - { "QUIT" [ \ quit ] } - { "MODE" [ \ mode ] } - { "KICK" [ \ kick ] } - [ drop \ unhandled ] - } case - [ [ tuple-slots ] [ parameters>> ] bi append ] dip prefix >tuple ; - -! Reader -: handle-reader-message ( irc-client irc-message -- ) - dup handle-irc swap stream-channel>> to ; - -: reader-loop ( irc-client -- ) - dup stream>> stream-readln [ - dup print parse-irc-line handle-reader-message - ] [ - f >>is-running - dup stream>> dispose - irc-end over controller-channel>> to - stream-channel>> irc-end swap to - ] if* ; - -! Controller commands -GENERIC: handle-command ( obj -- ) - -M: object handle-command ( obj -- ) - . ; - -TUPLE: send-message to text ; -C: send-message -M: send-message handle-command ( obj -- ) - dup to>> swap text>> SAY ; - -TUPLE: send-action to text ; -C: send-action -M: send-action handle-command ( obj -- ) - dup to>> swap text>> ACTION ; - -TUPLE: send-quit text ; -C: send-quit -M: send-quit handle-command ( obj -- ) - text>> QUIT ; - -: irc-listen ( irc-client quot -- ) - [ listeners>> ] [ ] bi* swap push ; - -! Controller loop -: controller-loop ( irc-client -- ) - controller-channel>> from handle-command ; - -! Multiplexer -: multiplex-message ( irc-client message -- ) - swap listeners>> [ channel>> ] map - [ '[ , , to ] "message" spawn drop ] each-with ; - -: multiplexer-loop ( irc-client -- ) - dup stream-channel>> from multiplex-message ; - -! process looping and starting -: (spawn-irc-loop) ( irc-client quot name -- ) - [ over >r curry r> '[ @ , is-running>> ] ] dip - spawn-server-linked drop ; - -: spawn-irc-loop ( irc-client quot name -- ) - '[ , , , [ (spawn-irc-loop) receive ] [ print ] recover ] - f spawn drop ; - -: spawn-irc ( irc-client -- ) - [ [ reader-loop ] "reader-loop" spawn-irc-loop ] - [ [ controller-loop ] "controller-loop" spawn-irc-loop ] - [ [ multiplexer-loop ] "multiplexer-loop" spawn-irc-loop ] - tri ; - -: do-irc ( irc-client -- ) - irc-client [ - irc-client> - [ irc-connect ] - [ profile>> nickname>> LOGIN ] - [ spawn-irc ] - tri - ] with-variable ; \ No newline at end of file diff --git a/extra/lcs/diff2html/diff2html.factor b/extra/lcs/diff2html/diff2html.factor new file mode 100644 index 0000000000..a8f649e2c9 --- /dev/null +++ b/extra/lcs/diff2html/diff2html.factor @@ -0,0 +1,44 @@ +! Copyright (C) 2008 Slava Pestov +! See http://factorcode.org/license.txt for BSD license. +USING: lcs html.elements kernel qualified ; +FROM: accessors => item>> ; +FROM: io => write ; +FROM: sequences => each empty? ; +FROM: xml.entities => escape-string ; +IN: lcs.diff2html + +GENERIC: diff-line ( obj -- ) + +: write-item ( item -- ) + item>> dup empty? [ drop " " ] [ escape-string ] if write ; + +M: retain diff-line + + dup [ + + write-item + + ] bi@ + ; + +M: insert diff-line + + + + write-item + + ; + +M: delete diff-line + + + write-item + + + ; + +: htmlize-diff ( diff -- ) + + + [ diff-line ] each +
    "Old" write "New" write
    ; diff --git a/extra/lisp/lisp-tests.factor b/extra/lisp/lisp-tests.factor index f1db203a78..0312080907 100644 --- a/extra/lisp/lisp-tests.factor +++ b/extra/lisp/lisp-tests.factor @@ -7,7 +7,7 @@ IN: lisp.test [ init-env - "#f" [ f ] lisp-define + "#f" [ f ] lisp-define "#t" [ t ] lisp-define "+" "math" "+" define-primitve diff --git a/extra/lisp/lisp.factor b/extra/lisp/lisp.factor index 0f5e4b4d2e..82a331f2ca 100644 --- a/extra/lisp/lisp.factor +++ b/extra/lisp/lisp.factor @@ -2,7 +2,8 @@ ! See http://factorcode.org/license.txt for BSD license. USING: kernel peg sequences arrays strings combinators.lib namespaces combinators math bake locals locals.private accessors -vectors syntax lisp.parser assocs parser sequences.lib words quotations ; +vectors syntax lisp.parser assocs parser sequences.lib words quotations +fry ; IN: lisp DEFER: convert-form @@ -12,52 +13,52 @@ DEFER: lookup-var ! Functions to convert s-exps to quotations ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! : convert-body ( s-exp -- quot ) - [ convert-form ] map [ ] [ compose ] reduce ; inline + [ ] [ convert-form compose ] reduce ; inline : convert-if ( s-exp -- quot ) - rest [ convert-form ] map reverse first3 [ % , , if ] bake ; - + rest first3 [ convert-form ] tri@ '[ @ , , if ] ; + : convert-begin ( s-exp -- quot ) - rest [ convert-form ] map >quotation [ , [ funcall ] each ] bake ; - + rest [ convert-form ] [ ] map-as '[ , [ funcall ] each ] ; + : convert-cond ( s-exp -- quot ) - rest [ body>> >array [ convert-form ] map first2 swap `{ [ % funcall ] , } bake ] - map >array [ , cond ] bake ; - + rest [ body>> first2 [ convert-form ] bi@ [ '[ @ funcall ] ] dip 2array ] + { } map-as '[ , cond ] ; + : convert-general-form ( s-exp -- quot ) - unclip convert-form swap convert-body [ , % funcall ] bake ; + unclip convert-form swap convert-body swap '[ , @ funcall ] ; ! words for convert-lambda > ] dip at swap or ] + [ dup lisp-symbol? [ over dupd [ name>> ] dip at swap or ] [ dup s-exp? [ body>> localize-body ] when ] if ] map ; - + : localize-lambda ( body vars -- newbody newvars ) - make-locals dup push-locals swap - [ swap localize-body convert-form swap pop-locals ] dip swap ; + make-locals dup push-locals swap + [ swap localize-body convert-form swap pop-locals ] dip swap ; : split-lambda ( s-exp -- body vars ) - first3 -rot nip [ body>> ] bi@ [ name>> ] map ; inline - + first3 -rot nip [ body>> ] bi@ [ name>> ] map ; inline + : rest-lambda ( body vars -- quot ) - "&rest" swap [ remove ] [ index ] 2bi - [ localize-lambda ] dip - [ , cut swap [ % , ] bake , compose ] bake ; - + "&rest" swap [ index ] [ remove ] 2bi + localize-lambda + '[ , cut '[ @ , ] , compose ] ; + : normal-lambda ( body vars -- quot ) - localize-lambda [ , compose ] bake ; + localize-lambda '[ , compose ] ; PRIVATE> - + : convert-lambda ( s-exp -- quot ) - split-lambda dup "&rest" swap member? [ rest-lambda ] [ normal-lambda ] if ; - + split-lambda "&rest" over member? [ rest-lambda ] [ normal-lambda ] if ; + : convert-quoted ( s-exp -- quot ) - second [ , ] bake ; - + second 1quotation ; + : convert-list-form ( s-exp -- quot ) - dup first dup lisp-symbol? + dup first dup lisp-symbol? [ name>> { { "lambda" [ convert-lambda ] } { "quote" [ convert-quoted ] } @@ -67,35 +68,35 @@ PRIVATE> [ drop convert-general-form ] } case ] [ drop convert-general-form ] if ; - + : convert-form ( lisp-form -- quot ) - { { [ dup s-exp? ] [ body>> convert-list-form ] } - { [ dup lisp-symbol? ] [ [ , lookup-var ] bake ] } - [ [ , ] bake ] - } cond ; - + { { [ dup s-exp? ] [ body>> convert-list-form ] } + { [ dup lisp-symbol? ] [ '[ , lookup-var ] ] } + [ 1quotation ] + } cond ; + : lisp-string>factor ( str -- quot ) - lisp-expr parse-result-ast convert-form lambda-rewrite call ; - + lisp-expr parse-result-ast convert-form lambda-rewrite call ; + ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! SYMBOL: lisp-env ERROR: no-such-var var ; : init-env ( -- ) - H{ } clone lisp-env set ; + H{ } clone lisp-env set ; : lisp-define ( name quot -- ) - swap lisp-env get set-at ; - + swap lisp-env get set-at ; + : lisp-get ( name -- word ) - dup lisp-env get at [ ] [ no-such-var throw ] ?if ; - + dup lisp-env get at [ ] [ no-such-var throw ] ?if ; + : lookup-var ( lisp-symbol -- quot ) - name>> lisp-get ; - + name>> lisp-get ; + : funcall ( quot sym -- * ) - dup lisp-symbol? [ lookup-var ] when call ; inline - + dup lisp-symbol? [ lookup-var ] when call ; inline + : define-primitve ( name vocab word -- ) - swap lookup [ [ , ] compose call ] bake lisp-define ; \ No newline at end of file + swap lookup 1quotation '[ , compose call ] lisp-define ; \ No newline at end of file diff --git a/extra/locals/locals-tests.factor b/extra/locals/locals-tests.factor index c5adaa5e5e..4e670cdac0 100755 --- a/extra/locals/locals-tests.factor +++ b/extra/locals/locals-tests.factor @@ -254,3 +254,14 @@ M:: fixnum next-method-test ( a -- b ) a call-next-method 1 + ; [ 3 ] [ 1 [let | a [ ] | 3 ] ] unit-test [ ] [ 1 2 [let | a [ ] b [ ] | ] ] unit-test + +:: a-word-with-locals ( a b -- ) ; + +: new-definition "USING: math ;\nIN: locals.tests\n: a-word-with-locals ( -- x ) 2 3 + ;\n" ; + +[ ] [ new-definition eval ] unit-test + +[ t ] [ + [ \ a-word-with-locals see ] with-string-writer + new-definition = +] unit-test diff --git a/extra/locals/locals.factor b/extra/locals/locals.factor index af4f1a77b6..e74d0b6078 100755 --- a/extra/locals/locals.factor +++ b/extra/locals/locals.factor @@ -364,6 +364,9 @@ M: lambda-word definer drop \ :: \ ; ; M: lambda-word definition "lambda" word-prop body>> ; +M: lambda-word reset-word + [ f "lambda" set-word-prop ] [ call-next-method ] bi ; + INTERSECTION: lambda-macro macro lambda-word ; M: lambda-macro definer drop \ MACRO:: \ ; ; @@ -371,6 +374,9 @@ M: lambda-macro definer drop \ MACRO:: \ ; ; M: lambda-macro definition "lambda" word-prop body>> ; +M: lambda-macro reset-word + [ f "lambda" set-word-prop ] [ call-next-method ] bi ; + INTERSECTION: lambda-method method-body lambda-word ; M: lambda-method definer drop \ M:: \ ; ; @@ -378,6 +384,9 @@ M: lambda-method definer drop \ M:: \ ; ; M: lambda-method definition "lambda" word-prop body>> ; +M: lambda-method reset-word + [ f "lambda" set-word-prop ] [ call-next-method ] bi ; + INTERSECTION: lambda-memoized memoized lambda-word ; M: lambda-memoized definer drop \ MEMO:: \ ; ; @@ -385,6 +394,9 @@ M: lambda-memoized definer drop \ MEMO:: \ ; ; M: lambda-memoized definition "lambda" word-prop body>> ; +M: lambda-memoized reset-word + [ f "lambda" set-word-prop ] [ call-next-method ] bi ; + : method-stack-effect ( method -- effect ) dup "lambda" word-prop vars>> swap "method-generic" word-prop stack-effect diff --git a/extra/macros/macros-tests.factor b/extra/macros/macros-tests.factor index 59a53afb70..d5011b0ecb 100644 --- a/extra/macros/macros-tests.factor +++ b/extra/macros/macros-tests.factor @@ -1,4 +1,14 @@ IN: macros.tests USING: tools.test macros math kernel arrays -vectors ; +vectors io.streams.string prettyprint parser ; +MACRO: see-test ( a b -- c ) + ; + +[ "USING: macros math ;\nIN: macros.tests\nMACRO: see-test ( a b -- c ) + ;\n" ] +[ [ \ see-test see ] with-string-writer ] +unit-test + +[ t ] [ + "USING: math ;\nIN: macros.tests\n: see-test ( a b -- c ) - ;\n" dup eval + [ \ see-test see ] with-string-writer = +] unit-test diff --git a/extra/macros/macros.factor b/extra/macros/macros.factor index b242f91d3b..88bfd01fbe 100755 --- a/extra/macros/macros.factor +++ b/extra/macros/macros.factor @@ -23,6 +23,9 @@ M: macro definer drop \ MACRO: \ ; ; M: macro definition "macro" word-prop ; +M: macro reset-word + [ f "macro" set-word-prop ] [ call-next-method ] bi ; + : macro-expand ( ... word -- quot ) "macro" word-prop call ; : n*quot ( n seq -- seq' ) concat >quotation ; diff --git a/extra/math/functions/functions-tests.factor b/extra/math/functions/functions-tests.factor index c9215d8de7..6176c12d21 100755 --- a/extra/math/functions/functions-tests.factor +++ b/extra/math/functions/functions-tests.factor @@ -39,6 +39,13 @@ IN: math.functions.tests [ 0.0 ] [ 0 sin ] unit-test [ 0.0 ] [ 0 asin ] unit-test +[ t ] [ 10 atan real? ] unit-test +[ f ] [ 10 atanh real? ] unit-test + +[ t ] [ 10 asin sin 10 1.e-10 ~ ] unit-test +[ t ] [ -1 sqrt neg dup acos cos 1.e-10 ~ ] unit-test +[ t ] [ 10 asinh sinh 10 1.e-10 ~ ] unit-test + [ 100 ] [ 100 100 gcd nip ] unit-test [ 100 ] [ 1000 100 gcd nip ] unit-test [ 100 ] [ 100 1000 gcd nip ] unit-test diff --git a/extra/math/functions/functions.factor b/extra/math/functions/functions.factor index bce93fbb11..bb43e4a721 100755 --- a/extra/math/functions/functions.factor +++ b/extra/math/functions/functions.factor @@ -125,74 +125,90 @@ M: real absq sq ; M: number (^) swap >polar 3dup ^theta >r ^mag r> polar> ; +: [-1,1]? ( x -- ? ) + dup complex? [ drop f ] [ abs 1 <= ] if ; inline + +: >=1? ( x -- ? ) + dup complex? [ drop f ] [ 1 >= ] if ; inline + : exp ( x -- y ) >rect swap fexp swap polar> ; inline : log ( x -- y ) >polar swap flog swap rect> ; inline : cos ( x -- y ) - >float-rect 2dup - fcosh swap fcos * -rot - fsinh swap fsin neg * rect> ; foldable + dup complex? [ + >float-rect 2dup + fcosh swap fcos * -rot + fsinh swap fsin neg * rect> + ] [ fcos ] if ; foldable : sec ( x -- y ) cos recip ; inline : cosh ( x -- y ) - >float-rect 2dup - fcos swap fcosh * -rot - fsin swap fsinh * rect> ; foldable + dup complex? [ + >float-rect 2dup + fcos swap fcosh * -rot + fsin swap fsinh * rect> + ] [ fcosh ] if ; foldable : sech ( x -- y ) cosh recip ; inline : sin ( x -- y ) - >float-rect 2dup - fcosh swap fsin * -rot - fsinh swap fcos * rect> ; foldable + dup complex? [ + >float-rect 2dup + fcosh swap fsin * -rot + fsinh swap fcos * rect> + ] [ fsin ] if ; foldable : cosec ( x -- y ) sin recip ; inline : sinh ( x -- y ) - >float-rect 2dup - fcos swap fsinh * -rot - fsin swap fcosh * rect> ; foldable + dup complex? [ + >float-rect 2dup + fcos swap fsinh * -rot + fsin swap fcosh * rect> + ] [ fsinh ] if ; foldable : cosech ( x -- y ) sinh recip ; inline -: tan ( x -- y ) dup sin swap cos / ; inline +: tan ( x -- y ) + dup complex? [ dup sin swap cos / ] [ ftan ] if ; inline -: tanh ( x -- y ) dup sinh swap cosh / ; inline +: tanh ( x -- y ) + dup complex? [ dup sinh swap cosh / ] [ ftanh ] if ; inline -: cot ( x -- y ) dup cos swap sin / ; inline +: cot ( x -- y ) tan recip ; inline -: coth ( x -- y ) dup cosh swap sinh / ; inline +: coth ( x -- y ) tanh recip ; inline -: acosh ( x -- y ) dup sq 1- sqrt + log ; inline +: acosh ( x -- y ) + dup >=1? [ facosh ] [ dup sq 1- sqrt + log ] if ; inline : asech ( x -- y ) recip acosh ; inline -: asinh ( x -- y ) dup sq 1+ sqrt + log ; inline +: asinh ( x -- y ) + dup complex? [ dup sq 1+ sqrt + log ] [ fasinh ] if ; inline : acosech ( x -- y ) recip asinh ; inline -: atanh ( x -- y ) dup 1+ swap 1- neg / log 2 / ; inline +: atanh ( x -- y ) + dup [-1,1]? [ fatanh ] [ dup 1+ swap 1- neg / log 2 / ] if ; inline : acoth ( x -- y ) recip atanh ; inline -: [-1,1]? ( x -- ? ) - dup complex? [ drop f ] [ abs 1 <= ] if ; inline - : i* ( x -- y ) >rect neg swap rect> ; : -i* ( x -- y ) >rect swap neg rect> ; : asin ( x -- y ) - dup [-1,1]? [ >float fasin ] [ i* asinh -i* ] if ; inline + dup [-1,1]? [ fasin ] [ i* asinh -i* ] if ; inline : acos ( x -- y ) - dup [-1,1]? [ >float facos ] [ asin pi 2 / swap - ] if ; + dup [-1,1]? [ facos ] [ asin pi 2 / swap - ] if ; inline : atan ( x -- y ) - dup [-1,1]? [ >float fatan ] [ i* atanh i* ] if ; inline + dup complex? [ i* atanh i* ] [ fatan ] if ; inline : asec ( x -- y ) recip acos ; inline diff --git a/extra/math/libm/libm.factor b/extra/math/libm/libm.factor index 0cc402e6e5..f70c8d2a77 100644 --- a/extra/math/libm/libm.factor +++ b/extra/math/libm/libm.factor @@ -15,6 +15,18 @@ IN: math.libm "double" "libm" "atan" { "double" } alien-invoke ; foldable +: facosh ( x -- y ) + "double" "libm" "acosh" { "double" } alien-invoke ; + foldable + +: fasinh ( x -- y ) + "double" "libm" "asinh" { "double" } alien-invoke ; + foldable + +: fatanh ( x -- y ) + "double" "libm" "atanh" { "double" } alien-invoke ; + foldable + : fatan2 ( x y -- z ) "double" "libm" "atan2" { "double" "double" } alien-invoke ; foldable @@ -27,6 +39,10 @@ IN: math.libm "double" "libm" "sin" { "double" } alien-invoke ; foldable +: ftan ( x -- y ) + "double" "libm" "tan" { "double" } alien-invoke ; + foldable + : fcosh ( x -- y ) "double" "libm" "cosh" { "double" } alien-invoke ; foldable @@ -35,6 +51,10 @@ IN: math.libm "double" "libm" "sinh" { "double" } alien-invoke ; foldable +: ftanh ( x -- y ) + "double" "libm" "tanh" { "double" } alien-invoke ; + foldable + : fexp ( x -- y ) "double" "libm" "exp" { "double" } alien-invoke ; foldable diff --git a/extra/memoize/memoize-tests.factor b/extra/memoize/memoize-tests.factor index 43428efbe0..c2592b38ca 100644 --- a/extra/memoize/memoize-tests.factor +++ b/extra/memoize/memoize-tests.factor @@ -1,6 +1,7 @@ ! Copyright (C) 2007 Slava Pestov, Daniel Ehrenberg. ! See http://factorcode.org/license.txt for BSD license. -USING: math kernel memoize tools.test parser ; +USING: math kernel memoize tools.test parser +prettyprint io.streams.string sequences ; IN: memoize.tests MEMO: fib ( m -- n ) @@ -9,3 +10,13 @@ MEMO: fib ( m -- n ) [ 89 ] [ 10 fib ] unit-test [ "USING: kernel math memoize ; IN: memoize.tests MEMO: x ( a b c d e -- f g h i j ) >r >r >r >r 1+ r> r> r> r> ;" eval ] must-fail + +MEMO: see-test ( a -- b ) reverse ; + +[ "USING: memoize sequences ;\nIN: memoize.tests\nMEMO: see-test ( a -- b ) reverse ;\n" ] +[ [ \ see-test see ] with-string-writer ] +unit-test + +[ ] [ "IN: memoize.tests : fib ;" eval ] unit-test + +[ "IN: memoize.tests\n: fib ( -- ) ;\n" ] [ [ \ fib see ] with-string-writer ] unit-test diff --git a/extra/memoize/memoize.factor b/extra/memoize/memoize.factor index 4136f9eaff..7da2ee0f0d 100755 --- a/extra/memoize/memoize.factor +++ b/extra/memoize/memoize.factor @@ -44,8 +44,14 @@ IN: memoize PREDICATE: memoized < word "memoize" word-prop ; M: memoized definer drop \ MEMO: \ ; ; + M: memoized definition "memo-quot" word-prop ; +M: memoized reset-word + [ { "memoize" "memo-quot" } reset-props ] + [ call-next-method ] + bi ; + : memoize-quot ( quot effect -- memo-quot ) gensym swap dupd "declared-effect" set-word-prop dup rot define-memoized 1quotation ; diff --git a/extra/multi-methods/multi-methods.factor b/extra/multi-methods/multi-methods.factor index 59e8049232..46ad6fc58e 100755 --- a/extra/multi-methods/multi-methods.factor +++ b/extra/multi-methods/multi-methods.factor @@ -4,7 +4,7 @@ USING: kernel math sequences vectors classes classes.algebra combinators arrays words assocs parser namespaces definitions prettyprint prettyprint.backend quotations arrays.lib debugger io compiler.units kernel.private effects accessors -hashtables sorting shuffle math.order ; +hashtables sorting shuffle math.order sets ; IN: multi-methods ! PART I: Converting hook specializers @@ -25,7 +25,7 @@ SYMBOL: total ] [ [ pair? ] filter - [ keys [ hooks get push-new ] each ] keep + [ keys [ hooks get adjoin ] each ] keep ] bi append ; : canonicalize-specializer-2 ( specializer -- specializer' ) diff --git a/extra/newfx/newfx.factor b/extra/newfx/newfx.factor index abe0449d06..e017dc4b2b 100644 --- a/extra/newfx/newfx.factor +++ b/extra/newfx/newfx.factor @@ -170,6 +170,11 @@ METHOD: as-mutate { object object assoc } set-at ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +: index ( seq obj -- i ) swap sequences:index ; +: index-of ( obj seq -- i ) sequences:index ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + : 1st 0 at ; : 2nd 1 at ; : 3rd 2 at ; diff --git a/extra/opengl/opengl.factor b/extra/opengl/opengl.factor index a6e76cdc9e..79470131f3 100755 --- a/extra/opengl/opengl.factor +++ b/extra/opengl/opengl.factor @@ -203,9 +203,7 @@ TUPLE: sprite loc dim dim2 dlist texture ; dup sprite-loc gl-translate GL_TEXTURE_2D over sprite-texture glBindTexture init-texture - GL_QUADS [ dup sprite-dim2 four-sides ] do-state - dup sprite-dim { 1 0 } v* - swap sprite-loc v- gl-translate + GL_QUADS [ sprite-dim2 four-sides ] do-state GL_TEXTURE_2D 0 glBindTexture ; : rect-vertices ( lower-left upper-right -- ) diff --git a/extra/qualified/qualified-docs.factor b/extra/qualified/qualified-docs.factor index d336d31114..d62f696a74 100755 --- a/extra/qualified/qualified-docs.factor +++ b/extra/qualified/qualified-docs.factor @@ -8,26 +8,26 @@ HELP: QUALIFIED: "QUALIFIED: math\n1 2 math:+ ! ==> 3" } } ; HELP: QUALIFIED-WITH: -{ $syntax "QUALIFIED-WITH: vocab prefix" } -{ $description "Works like " { $link POSTPONE: QUALIFIED: } " but uses the specified prefix." } +{ $syntax "QUALIFIED-WITH: vocab word-prefix" } +{ $description "Works like " { $link POSTPONE: QUALIFIED: } " but uses " { $snippet "word-prefix" } " as prefix." } { $examples { $code "QUALIFIED-WITH: math m\n1 2 m:+ ! ==> 3" } } ; HELP: FROM: { $syntax "FROM: vocab => words ... ;" } -{ $description "Imports the specified words from vocab." } +{ $description "Imports " { $snippet "words" } " from " { $snippet "vocab" } "." } { $examples { $code "FROM: math.parser => bin> hex> ; ! imports only bin> and hex>" } } ; HELP: EXCLUDE: { $syntax "EXCLUDE: vocab => words ... ;" } -{ $description "Imports everything from vocab excluding the specified words" } +{ $description "Imports everything from " { $snippet "vocab" } " excluding " { $snippet "words" } "." } { $examples { $code - "EXCLUDE: math.parser => bin> hex> ; ! imports everythin but bin> and hex>" } } ; + "EXCLUDE: math.parser => bin> hex> ; ! imports everything but bin> and hex>" } } ; HELP: RENAME: { $syntax "RENAME: word vocab => newname " } -{ $description "Imports word from vocab, but renamed to newname." } +{ $description "Imports " { $snippet "word" } " from " { $snippet "vocab" } ", but renamed to " { $snippet "newname" } "." } { $examples { $code "RENAME: + math => -" "2 3 - ! => 5" } } ; diff --git a/extra/rss/rss.factor b/extra/rss/rss.factor index 6e616e51a9..364c24b91f 100644 --- a/extra/rss/rss.factor +++ b/extra/rss/rss.factor @@ -18,51 +18,67 @@ TUPLE: entry title link description pub-date ; C: entry +: try-parsing-timestamp ( string -- timestamp ) + [ rfc822>timestamp ] [ drop rfc3339>timestamp ] recover ; + : rss1.0-entry ( tag -- entry ) - [ "title" tag-named children>string ] keep - [ "link" tag-named children>string ] keep - [ "description" tag-named children>string ] keep - f "date" "http://purl.org/dc/elements/1.1/" - tag-named dup [ children>string rfc822>timestamp ] when - ; + { + [ "title" tag-named children>string ] + [ "link" tag-named children>string ] + [ "description" tag-named children>string ] + [ + f "date" "http://purl.org/dc/elements/1.1/" + tag-named dup [ children>string try-parsing-timestamp ] when + ] + } cleave ; : rss1.0 ( xml -- feed ) [ "channel" tag-named - [ "title" tag-named children>string ] keep - "link" tag-named children>string - ] keep - "item" tags-named [ rss1.0-entry ] map ; + [ "title" tag-named children>string ] + [ "link" tag-named children>string ] bi + ] [ "item" tags-named [ rss1.0-entry ] map ] bi + ; : rss2.0-entry ( tag -- entry ) - [ "title" tag-named children>string ] keep - [ "link" tag-named ] keep - [ "guid" tag-named dupd ? children>string ] keep - [ "description" tag-named children>string ] keep - "pubDate" tag-named children>string rfc822>timestamp ; + { + [ "title" tag-named children>string ] + [ { "link" "guid" } any-tag-named children>string ] + [ "description" tag-named children>string ] + [ + { "date" "pubDate" } any-tag-named + children>string try-parsing-timestamp + ] + } cleave ; : rss2.0 ( xml -- feed ) "channel" tag-named - [ "title" tag-named children>string ] keep - [ "link" tag-named children>string ] keep - "item" tags-named [ rss2.0-entry ] map ; + [ "title" tag-named children>string ] + [ "link" tag-named children>string ] + [ "item" tags-named [ rss2.0-entry ] map ] + tri ; : atom1.0-entry ( tag -- entry ) - [ "title" tag-named children>string ] keep - [ "link" tag-named "href" swap at ] keep - [ - { "content" "summary" } any-tag-named - dup tag-children [ string? not ] contains? - [ tag-children [ write-chunk ] with-string-writer ] - [ children>string ] if - ] keep - { "published" "updated" "issued" "modified" } any-tag-named - children>string rfc3339>timestamp ; + { + [ "title" tag-named children>string ] + [ "link" tag-named "href" swap at ] + [ + { "content" "summary" } any-tag-named + dup tag-children [ string? not ] contains? + [ tag-children [ write-chunk ] with-string-writer ] + [ children>string ] if + ] + [ + { "published" "updated" "issued" "modified" } + any-tag-named children>string try-parsing-timestamp + ] + } cleave ; : atom1.0 ( xml -- feed ) - [ "title" tag-named children>string ] keep - [ "link" tag-named "href" swap at ] keep - "entry" tags-named [ atom1.0-entry ] map ; + [ "title" tag-named children>string ] + [ "link" tag-named "href" swap at ] + [ "entry" tags-named [ atom1.0-entry ] map ] + tri ; : xml>feed ( xml -- feed ) dup name-tag { diff --git a/extra/tangle/html/html-tests.factor b/extra/tangle/html/html-tests.factor index 8e7d8c24e1..88ad748400 100644 --- a/extra/tangle/html/html-tests.factor +++ b/extra/tangle/html/html-tests.factor @@ -1,4 +1,4 @@ -USING: html kernel semantic-db tangle.html tools.test ; +USING: kernel semantic-db tangle.html tools.test ; IN: tangle.html.tests [ "test" ] [ "test" >html ] unit-test diff --git a/extra/tangle/html/html.factor b/extra/tangle/html/html.factor index fc604f4d46..2ec6b52609 100644 --- a/extra/tangle/html/html.factor +++ b/extra/tangle/html/html.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2008 Alex Chapman ! See http://factorcode.org/license.txt for BSD license. -USING: accessors html html.elements io io.streams.string kernel namespaces semantic-db sequences strings tangle.path ; +USING: accessors html.elements io io.streams.string kernel namespaces semantic-db sequences strings tangle.path ; IN: tangle.html TUPLE: element attributes ; diff --git a/extra/tangle/tangle.factor b/extra/tangle/tangle.factor index 52c454f97f..8a4c6146de 100644 --- a/extra/tangle/tangle.factor +++ b/extra/tangle/tangle.factor @@ -19,11 +19,8 @@ C: tangle : with-tangle ( tangle quot -- ) [ [ db>> ] [ seq>> ] bi ] dip with-db ; -: ( text -- response ) - "text/plain" swap >>body ; - : node-response ( id -- response ) - load-node [ node-content ] [ <404> ] if* ; + load-node [ node-content ] [ <404> ] if* ; : display-node ( params -- response ) [ @@ -39,7 +36,7 @@ C: tangle : submit-node ( params -- response ) [ "node_content" swap at* [ - create-node id>> number>string + create-node id>> number>string ] [ drop <400> ] if @@ -55,10 +52,7 @@ TUPLE: path-responder ; C: path-responder M: path-responder call-responder* ( path responder -- response ) - drop path>file [ node-content ] [ <404> ] if* ; - -: ( obj -- response ) - "application/json" swap >json >>body ; + drop path>file [ node-content ] [ <404> ] if* ; TUPLE: tangle-dispatcher < dispatcher tangle ; @@ -67,7 +61,7 @@ TUPLE: tangle-dispatcher < dispatcher tangle ; >>default "resource:extra/tangle/resources" "resources" add-responder "node" add-responder - [ all-node-ids ] >>display "all" add-responder ; + [ all-node-ids ] >>display "all" add-responder ; M: tangle-dispatcher call-responder* ( path dispatcher -- response ) dup tangle>> [ diff --git a/extra/trees/splay/splay-tests.factor b/extra/trees/splay/splay-tests.factor index 29ea2eee2d..e54e3cd538 100644 --- a/extra/trees/splay/splay-tests.factor +++ b/extra/trees/splay/splay-tests.factor @@ -1,14 +1,14 @@ ! Copyright (c) 2005 Mackenzie Straight. ! See http://factorcode.org/license.txt for BSD license. USING: kernel tools.test trees.splay math namespaces assocs -sequences random ; +sequences random sets ; IN: trees.splay.tests : randomize-numeric-splay-tree ( splay-tree -- ) 100 [ drop 100 random swap at drop ] with each ; : make-numeric-splay-tree ( n -- splay-tree ) - [ [ dupd set-at ] curry each ] keep ; + [ [ conjoin ] curry each ] keep ; [ t ] [ 100 make-numeric-splay-tree dup randomize-numeric-splay-tree diff --git a/extra/ui/freetype/freetype-docs.factor b/extra/ui/freetype/freetype-docs.factor index f463a7c0e7..855df9f564 100755 --- a/extra/ui/freetype/freetype-docs.factor +++ b/extra/ui/freetype/freetype-docs.factor @@ -38,7 +38,7 @@ HELP: render-glyph { $description "Renders a character and outputs a pointer to the bitmap." } ; HELP: -{ $values { "font" font } { "char" "a non-negative integer" } { "sprite" sprite } } +{ $values { "open-font" font } { "char" "a non-negative integer" } { "sprite" sprite } } { $description "Renders a character to an OpenGL texture and records a display list which draws a quad with this texture. This word allocates native resources which must be freed by " { $link free-sprites } "." } ; HELP: (draw-string) diff --git a/extra/ui/freetype/freetype.factor b/extra/ui/freetype/freetype.factor index 1c83bc9713..3512bbf670 100755 --- a/extra/ui/freetype/freetype.factor +++ b/extra/ui/freetype/freetype.factor @@ -3,7 +3,8 @@ USING: alien alien.accessors alien.c-types arrays io kernel libc math math.vectors namespaces opengl opengl.gl prettyprint assocs sequences io.files io.styles continuations freetype -ui.gadgets.worlds ui.render ui.backend byte-arrays ; +ui.gadgets.worlds ui.render ui.backend byte-arrays accessors +locals ; IN: ui.freetype @@ -41,8 +42,8 @@ M: font hashcode* drop font hashcode* ; ] bind ; M: freetype-renderer free-fonts ( world -- ) - dup world-handle select-gl-context - world-fonts [ nip second free-sprites ] assoc-each ; + [ handle>> select-gl-context ] + [ fonts>> [ nip second free-sprites ] assoc-each ] bi ; : ttf-name ( font style -- name ) 2array H{ @@ -67,7 +68,7 @@ M: freetype-renderer free-fonts ( world -- ) #! We use FT_New_Memory_Face, not FT_New_Face, since #! FT_New_Face only takes an ASCII path name and causes #! problems on localized versions of Windows - freetype -rot 0 f [ + [ freetype ] 2dip 0 f [ FT_New_Memory_Face freetype-error ] keep *void* ; @@ -85,29 +86,29 @@ SYMBOL: dpi : font-units>pixels ( n font -- n ) face-size face-size-y-scale FT_MulFix ; -: init-ascent ( font face -- ) - dup face-y-max swap font-units>pixels swap set-font-ascent ; +: init-ascent ( font face -- font ) + dup face-y-max swap font-units>pixels >>ascent ; inline -: init-descent ( font face -- ) - dup face-y-min swap font-units>pixels swap set-font-descent ; +: init-descent ( font face -- font ) + dup face-y-min swap font-units>pixels >>descent ; inline -: init-font ( font -- ) - dup font-handle 2dup init-ascent dupd init-descent - dup font-ascent over font-descent - ft-ceil - swap set-font-height ; +: init-font ( font -- font ) + dup handle>> init-ascent + dup handle>> init-descent + dup [ ascent>> ] [ descent>> ] bi - ft-ceil >>height ; inline + +: set-char-size ( handle size -- ) + 0 swap 6 shift dpi get-global dup FT_Set_Char_Size freetype-error ; : ( handle -- font ) - H{ } clone - { set-font-handle set-font-widths } font construct - dup init-font ; - -: (open-font) ( font -- open-font ) - first3 >r open-face dup 0 r> 6 shift - dpi get-global dpi get-global FT_Set_Char_Size - freetype-error ; + font new + H{ } clone >>widths + over first2 open-face >>handle + dup handle>> rot third set-char-size + init-font ; M: freetype-renderer open-font ( font -- open-font ) - freetype drop open-fonts get [ (open-font) ] cache ; + freetype drop open-fonts get [ ] cache ; : load-glyph ( font char -- glyph ) >r font-handle dup r> 0 FT_Load_Char @@ -132,30 +133,35 @@ M: freetype-renderer string-height ( open-font string -- h ) load-glyph dup FT_RENDER_MODE_NORMAL FT_Render_Glyph freetype-error ; -: copy-pixel ( bit tex -- bit tex ) - 255 f pick set-alien-unsigned-1 1+ - f pick alien-unsigned-1 - f pick set-alien-unsigned-1 >r 1+ r> 1+ ; +:: copy-pixel ( i j bitmap texture -- i j ) + 255 j texture set-char-nth + i bitmap char-nth j 1 + texture set-char-nth + i 1 + j 2 + ; inline -: (copy-row) ( bit tex bitend texend -- bitend texend ) - >r pick over >= [ - 2nip r> - ] [ - >r copy-pixel r> r> (copy-row) - ] if ; +:: (copy-row) ( i j bitmap texture end -- ) + i end < [ + i j bitmap texture copy-pixel + bitmap texture end (copy-row) + ] when ; inline -: copy-row ( bit tex width width2 -- bitend texend width width2 ) - [ pick + >r pick + r> (copy-row) ] 2keep ; +:: copy-row ( i j bitmap texture width width2 -- i j ) + i j bitmap texture i width + (copy-row) + i width + + j width2 + ; inline -: copy-bitmap ( glyph texture -- ) - over glyph-bitmap-rows >r - over glyph-bitmap-width dup next-power-of-2 2 * - >r >r >r glyph-bitmap-buffer alien-address r> r> r> r> - [ copy-row ] times 2drop 2drop ; +:: copy-bitmap ( glyph texture -- ) + [let* | bitmap [ glyph glyph-bitmap-buffer ] + rows [ glyph glyph-bitmap-rows ] + width [ glyph glyph-bitmap-width ] + width2 [ width next-power-of-2 2 * ] | + 0 0 + rows [ bitmap texture width width2 copy-row ] times + 2drop + ] ; : bitmap>texture ( glyph sprite -- id ) tuck sprite-size2 * 2 * [ - alien-address [ copy-bitmap ] keep gray-texture + [ copy-bitmap ] keep gray-texture ] with-malloc ; : glyph-texture-loc ( glyph font -- loc ) @@ -163,34 +169,47 @@ M: freetype-renderer string-height ( open-font string -- h ) font-ascent swap glyph-hori-bearing-y - ft-floor 2array ; : glyph-texture-size ( glyph -- dim ) - dup glyph-bitmap-width next-power-of-2 - swap glyph-bitmap-rows next-power-of-2 2array ; + [ glyph-bitmap-width next-power-of-2 ] + [ glyph-bitmap-rows next-power-of-2 ] + bi 2array ; -: ( font char -- sprite ) +: ( open-font char -- sprite ) over >r render-glyph dup r> glyph-texture-loc over glyph-size pick glyph-texture-size [ bitmap>texture ] keep [ init-sprite ] keep ; -: draw-char ( open-font char sprites -- ) - [ dupd ] cache nip - sprite-dlist glCallList ; +:: char-sprite ( open-font sprites char -- sprite ) + char sprites [ open-font swap ] cache ; -: (draw-string) ( open-font sprites string loc -- ) +: draw-char ( open-font sprites char loc -- ) + GL_MODELVIEW [ + 0 0 glTranslated + char-sprite sprite-dlist glCallList + ] do-matrix ; + +: char-widths ( open-font string -- widths ) + [ char-width ] with { } map-as ; + +: scan-sums ( seq -- seq' ) + 0 [ + ] accumulate nip ; + +:: (draw-string) ( open-font sprites string loc -- ) GL_TEXTURE_2D [ - [ - [ >r 2dup r> swap draw-char ] each 2drop + loc [ + string open-font string char-widths scan-sums [ + [ open-font sprites ] 2dip draw-char + ] 2each ] with-translation ] do-enabled ; -: font-sprites ( open-font world -- pair ) - world-fonts [ open-font H{ } clone 2array ] cache ; +: font-sprites ( font world -- open-font sprites ) + world-fonts [ open-font H{ } clone 2array ] cache first2 ; M: freetype-renderer draw-string ( font string loc -- ) - >r >r world get font-sprites first2 r> r> (draw-string) ; + >r >r world get font-sprites r> r> (draw-string) ; : run-char-widths ( open-font string -- widths ) - [ char-width ] with { } map-as - dup 0 [ + ] accumulate nip swap 2 v/n v+ ; + char-widths [ scan-sums ] [ 2 v/n ] bi v+ ; M: freetype-renderer x>offset ( x open-font string -- n ) dup >r run-char-widths [ <= ] with find drop diff --git a/extra/ui/tools/interactor/interactor.factor b/extra/ui/tools/interactor/interactor.factor index 2e59363531..400169908b 100755 --- a/extra/ui/tools/interactor/interactor.factor +++ b/extra/ui/tools/interactor/interactor.factor @@ -6,7 +6,7 @@ models namespaces parser prettyprint quotations sequences strings threads listener classes.tuple ui.commands ui.gadgets ui.gadgets.editors ui.gadgets.presentations ui.gadgets.worlds ui.gestures definitions calendar concurrency.flags -concurrency.mailboxes ui.tools.workspace accessors ; +concurrency.mailboxes ui.tools.workspace accessors sets ; IN: ui.tools.interactor ! If waiting is t, we're waiting for user input, and invoking @@ -76,7 +76,7 @@ M: interactor model-changed ] with-output-stream* ; : add-interactor-history ( str interactor -- ) - over empty? [ 2drop ] [ interactor-history push-new ] if ; + over empty? [ 2drop ] [ interactor-history adjoin ] if ; : interactor-continue ( obj interactor -- ) mailbox>> mailbox-put ; diff --git a/extra/unicode/collation/collation-tests.factor b/extra/unicode/collation/collation-tests.factor index c9d6cb808f..b4a54bb11d 100755 --- a/extra/unicode/collation/collation-tests.factor +++ b/extra/unicode/collation/collation-tests.factor @@ -20,7 +20,7 @@ IN: unicode.collation.tests [ execute ] 2with each ; [ f f f f ] [ "hello" "hi" test-equality ] unit-test -[ t f f f ] [ "hello" "hŽllo" test-equality ] unit-test +[ t f f f ] [ "hello" "h\u0000e9llo" test-equality ] unit-test [ t t f f ] [ "hello" "HELLO" test-equality ] unit-test [ t t t f ] [ "hello" "h e l l o." test-equality ] unit-test [ t t t t ] [ "hello" "\0hello\0" test-equality ] unit-test diff --git a/extra/validators/validators-tests.factor b/extra/validators/validators-tests.factor new file mode 100644 index 0000000000..7d4325cbb6 --- /dev/null +++ b/extra/validators/validators-tests.factor @@ -0,0 +1,118 @@ +IN: validators.tests +USING: kernel sequences tools.test validators accessors +namespaces assocs ; + +: with-validation ( quot -- messages ) + [ + init-validation + call + validation-messages get + named-validation-messages get >alist append + ] with-scope ; inline + +[ "" v-one-line ] must-fail +[ "hello world" ] [ "hello world" v-one-line ] unit-test +[ "hello\nworld" v-one-line ] must-fail + +[ "" v-one-word ] must-fail +[ "hello" ] [ "hello" v-one-word ] unit-test +[ "hello world" v-one-word ] must-fail + +[ "foo" v-number ] must-fail +[ 123 ] [ "123" v-number ] unit-test +[ 123 ] [ "123" v-integer ] unit-test + +[ "1.0" v-integer ] [ "must be an integer" = ] must-fail-with + +[ "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 + +[ 4561261212345467 ] [ "4561261212345467" v-credit-card ] unit-test + +[ 4561261212345467 ] [ "4561-2612-1234-5467" v-credit-card ] unit-test + +[ 0 ] [ "0000000000000000" v-credit-card ] unit-test + +[ "000000000" v-credit-card ] must-fail + +[ "0000000000000000000000000" v-credit-card ] must-fail + +[ "4561_2612_1234_5467" v-credit-card ] must-fail + +[ "4561-2621-1234-5467" v-credit-card ] must-fail + + +[ 14 V{ } ] [ + [ + "14" "age" [ v-number 13 v-min-value 100 v-max-value ] validate + ] with-validation +] unit-test + +[ f t ] [ + [ + "140" "age" [ 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" [ ] } + { "age" [ v-number 13 v-min-value 100 v-max-value ] } +} define-validators + +[ t t ] [ + [ + { { "age" "" } } required-values + validation-failed? + ] with-validation first + [ first "age" = ] + [ second validation-error? ] + [ second message>> "required" = ] + tri and and +] unit-test + +[ H{ { "a" 123 } } f V{ } ] [ + [ + H{ + { "a" "123" } + { "b" "c" } + { "c" "d" } + } + H{ + { "a" [ v-integer ] } + } validate-values + validation-failed? + ] with-validation +] unit-test + +[ t "foo" ] [ + [ + "foo" validation-error + validation-failed? + ] with-validation first message>> +] unit-test diff --git a/extra/validators/validators.factor b/extra/validators/validators.factor new file mode 100644 index 0000000000..aeb2dc2f80 --- /dev/null +++ b/extra/validators/validators.factor @@ -0,0 +1,159 @@ +! Copyright (C) 2006, 2008 Slava Pestov +! See http://factorcode.org/license.txt for BSD license. +USING: kernel continuations sequences sequences.lib math +namespaces sets math.parser math.ranges assocs regexp fry +unicode.categories arrays hashtables words combinators mirrors +classes quotations xmode.catalog ; +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 ( str -- n ) + v-number 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 + 60 v-max-length + "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 ) + v-required + dup "\r\n" intersect empty? + [ "must be a single line" throw ] unless ; + +: v-one-word ( str -- str ) + v-required + dup [ alpha? ] all? + [ "must be a single word" throw ] unless ; + +: v-username ( str -- str ) + 2 v-min-length 16 v-max-length v-one-word ; + +: v-password ( str -- str ) + 6 v-min-length 40 v-max-length v-one-line ; + +: v-mode ( str -- str ) + dup mode-names member? [ + "not a valid syntax mode" throw + ] unless ; + +: luhn? ( n -- ? ) + string>digits + [ odd? [ 2 * 10 /mod + ] when ] map-index + sum 10 mod 0 = ; + +: v-credit-card ( str -- n ) + "- " diff + dup CHAR: 0 CHAR: 9 [a,b] diff empty? [ + 13 v-min-length + 16 v-max-length + dup luhn? [ string>number ] [ + "card number check failed" throw + ] if + ] [ + "invalid credit card number format" throw + ] if ; + +SYMBOL: validation-messages +SYMBOL: named-validation-messages + +: init-validation ( -- ) + V{ } clone validation-messages set + H{ } clone named-validation-messages set ; + +: (validation-message) ( obj -- ) + validation-messages get push ; + +: (validation-message-for) ( obj name -- ) + named-validation-messages get set-at ; + +TUPLE: validation-message message ; + +C: validation-message + +: validation-message ( string -- ) + (validation-message) ; + +: validation-message-for ( string name -- ) + [ ] dip (validation-message-for) ; + +TUPLE: validation-error message value ; + +C: validation-error + +: validation-error ( message -- ) + f (validation-message) ; + +: validation-error-for ( message value name -- ) + [ ] dip (validation-message-for) ; + +: validation-failed? ( -- ? ) + validation-messages get [ validation-error? ] contains? + named-validation-messages get [ nip validation-error? ] assoc-contains? + or ; + +: define-validators ( class validators -- ) + >hashtable "validators" set-word-prop ; + +: validate ( value name quot -- result ) + '[ drop @ ] [ -rot validation-error-for f ] recover ; inline + +: required-values ( assoc -- ) + [ swap [ v-required ] validate drop ] assoc-each ; + +: validate-values ( assoc validators -- assoc' ) + swap '[ [ [ dup , at ] keep ] dip validate ] assoc-map ; diff --git a/extra/webapps/counter/counter.factor b/extra/webapps/counter/counter.factor index 3cc1eb567b..04194adb29 100644 --- a/extra/webapps/counter/counter.factor +++ b/extra/webapps/counter/counter.factor @@ -1,26 +1,25 @@ -USING: math kernel accessors http.server http.server.actions -http.server.sessions http.server.templating -http.server.templating.fhtml locals ; +USING: math kernel accessors html.components +http.server http.server.actions +http.server.sessions html.templates.chloe fry ; IN: webapps.counter SYMBOL: count TUPLE: counter-app < dispatcher ; -M: counter-app init-session* - drop 0 count sset ; +M: counter-app init-session* drop 0 count sset ; -:: ( quot -- action ) - [ - count quot schange - "" f - ] >>display ; +: ( quot -- action ) + + swap '[ count , schange "" f ] >>submit ; : counter-template ( -- template ) - "resource:extra/webapps/counter/counter.fhtml" ; + "resource:extra/webapps/counter/counter.xml" ; : ( -- action ) - [ counter-template serve-template ] >>display ; + + [ count sget "counter" set-value ] >>init + counter-template >>template ; : ( -- responder ) counter-app new-dispatcher diff --git a/extra/webapps/counter/counter.fhtml b/extra/webapps/counter/counter.fhtml deleted file mode 100644 index 521096f105..0000000000 --- a/extra/webapps/counter/counter.fhtml +++ /dev/null @@ -1,10 +0,0 @@ -<% USING: io math.parser http.server.sessions webapps.counter ; %> - - - -

    <% count sget number>string write %>

    - - ++ - -- - - diff --git a/extra/webapps/counter/counter.xml b/extra/webapps/counter/counter.xml new file mode 100644 index 0000000000..75e7cf3c4b --- /dev/null +++ b/extra/webapps/counter/counter.xml @@ -0,0 +1,13 @@ + + + + + + +

    + + ++ + -- + + +     diff --git a/extra/webapps/factor-website/factor-website.factor b/extra/webapps/factor-website/factor-website.factor index 9b3ce57d02..9ad4a05492 100644 --- a/extra/webapps/factor-website/factor-website.factor +++ b/extra/webapps/factor-website/factor-website.factor @@ -1,19 +1,21 @@ ! Copyright (c) 2008 Slava Pestov ! See http://factorcode.org/license.txt for BSD license. USING: accessors kernel sequences assocs io.files io.sockets +io.server namespaces db db.sqlite smtp http.server http.server.db http.server.flows http.server.sessions -http.server.auth.admin http.server.auth.login http.server.auth.providers.db http.server.boilerplate -http.server.templating.chloe +html.templates.chloe webapps.pastebin webapps.planet -webapps.todo ; +webapps.todo +webapps.wiki +webapps.user-admin ; IN: webapps.factor-website : test-db "resource:test.db" sqlite-db ; @@ -30,15 +32,20 @@ IN: webapps.factor-website init-annotations-table init-blog-table + init-postings-table init-todo-table + + init-articles-table + init-revisions-table ] with-db ; : ( -- responder ) - + "todo" add-responder "pastebin" add-responder "planet" add-responder + "wiki" add-responder "user-admin" add-responder users-in-db >>users @@ -59,7 +66,7 @@ IN: webapps.factor-website main-responder set-global ; -: start-factor-website +: start-factor-website ( -- ) test-db start-expiring-sessions - "planet" main-responder get responders>> at test-db start-update-task + test-db start-update-task 8812 httpd ; diff --git a/extra/webapps/factor-website/page.css b/extra/webapps/factor-website/page.css index 55721d7bef..49e26883ad 100644 --- a/extra/webapps/factor-website/page.css +++ b/extra/webapps/factor-website/page.css @@ -21,6 +21,8 @@ a:hover, .link:hover { .error { color: #a00; } +.errors li { color: #a00; } + .field-label { text-align: right; } @@ -40,12 +42,15 @@ a:hover, .link:hover { } .description { - border: 1px dashed #ccc; - background-color: #f5f5f5; padding: 5px; color: #000; } +.description pre { + border: 1px dashed #ccc; + background-color: #f5f5f5; +} + .description p:first-child { margin-top: 0px; } @@ -53,3 +58,21 @@ a:hover, .link:hover { .description p:last-child { margin-bottom: 0px; } + +.description table, .description td { + border-color: #666; + border-style: solid; +} + +.description table { + border-width: 0 0 1px 1px; + border-spacing: 0; + border-collapse: collapse; +} + +.description td { + margin: 0; + padding: 4px; + border-width: 1px 1px 0 0; +} + diff --git a/extra/webapps/pastebin/annotation.xml b/extra/webapps/pastebin/annotation.xml deleted file mode 100644 index d5b4ea8d3a..0000000000 --- a/extra/webapps/pastebin/annotation.xml +++ /dev/null @@ -1,17 +0,0 @@ - - - - -

    Annotation:

    - - - - - -
    Author:
    Mode:
    Date:
    - -
    - - Delete Annotation - -     diff --git a/extra/webapps/pastebin/new-annotation.xml b/extra/webapps/pastebin/new-annotation.xml deleted file mode 100644 index 5d18860977..0000000000 --- a/extra/webapps/pastebin/new-annotation.xml +++ /dev/null @@ -1,24 +0,0 @@ - - - - - New Annotation - - - - - - - - - - - - - -
    Summary:
    Author:
    Mode:
    Description:
    Captcha:
    Leave the captcha blank. Spam-bots will fill it indiscriminantly, so their attempts to register will be blocked.
    - - -     - -     diff --git a/extra/webapps/pastebin/new-paste.xml b/extra/webapps/pastebin/new-paste.xml index 86daf09aeb..6abae4895b 100644 --- a/extra/webapps/pastebin/new-paste.xml +++ b/extra/webapps/pastebin/new-paste.xml @@ -7,11 +7,11 @@ - - - - - + + + + + diff --git a/extra/webapps/pastebin/paste-list.xml b/extra/webapps/pastebin/paste-list.xml deleted file mode 100644 index c91aa6fc42..0000000000 --- a/extra/webapps/pastebin/paste-list.xml +++ /dev/null @@ -1,15 +0,0 @@ - - - - - Pastebin - -
    Summary:
    Author:
    Mode:
    Description:
    Captcha:
    Summary:
    Author:
    Mode:
    Body:
    Captcha:
    Leave the captcha blank. Spam-bots will fill it indiscriminantly, so their attempts to register will be blocked.
    - - - - - -
    Summary:Paste by:Date:
    - - diff --git a/extra/webapps/pastebin/paste-summary.xml b/extra/webapps/pastebin/paste-summary.xml deleted file mode 100644 index c751b110c0..0000000000 --- a/extra/webapps/pastebin/paste-summary.xml +++ /dev/null @@ -1,11 +0,0 @@ - - - - - - - - - - - diff --git a/extra/webapps/pastebin/paste.xml b/extra/webapps/pastebin/paste.xml index 9141ee4ef1..57c2fdb7c2 100644 --- a/extra/webapps/pastebin/paste.xml +++ b/extra/webapps/pastebin/paste.xml @@ -2,19 +2,59 @@ - Paste: + + + Paste: - - - + + +
    Author:
    Mode:
    Date:
    Author:
    Mode:
    Date:
    -
    +
    Delete Paste | Annotate - + + +

    Annotation:

    + + + + + +
    Author:
    Mode:
    Date:
    + +
    + + Delete Annotation + +     + + + +

    New Annotation

    + + + + + + + + + + + + + +
    Summary:
    Author:
    Mode:
    Body:
    Captcha:
    Leave the captcha blank. Spam-bots will fill it indiscriminantly, so their attempts to register will be blocked.
    + + +     + +     +     diff --git a/extra/webapps/pastebin/pastebin-common.xml b/extra/webapps/pastebin/pastebin-common.xml new file mode 100644 index 0000000000..f785fceb6b --- /dev/null +++ b/extra/webapps/pastebin/pastebin-common.xml @@ -0,0 +1,28 @@ + + + + + + +
    + + Pastes + | New Paste + + + + + | Edit Profile + + + | Logout + + + +
    + +

    + + + +     diff --git a/extra/webapps/pastebin/pastebin.factor b/extra/webapps/pastebin/pastebin.factor index 273b250695..9852bf47cb 100644 --- a/extra/webapps/pastebin/pastebin.factor +++ b/extra/webapps/pastebin/pastebin.factor @@ -1,46 +1,40 @@ +! Copyright (C) 2007, 2008 Slava Pestov +! See http://factorcode.org/license.txt for BSD license. USING: namespaces assocs sorting sequences kernel accessors -hashtables sequences.lib locals db.types db.tuples db -calendar calendar.format rss xml.writer -xmode.catalog +hashtables sequences.lib db.types db.tuples db combinators +calendar calendar.format math.parser rss xml.writer +xmode.catalog validators html.components html.templates.chloe http.server -http.server.crud http.server.actions -http.server.components -http.server.components.code -http.server.templating.chloe http.server.auth http.server.auth.login -http.server.boilerplate -http.server.validators -http.server.forms ; +http.server.boilerplate ; IN: webapps.pastebin -: ( id -- component ) - modes keys natural-sort ; +! ! ! +! DOMAIN MODEL +! ! ! -: pastebin-template ( name -- template ) - "resource:extra/webapps/pastebin/" swap ".xml" 3append ; +TUPLE: paste id summary author mode date contents annotations ; -TUPLE: paste id summary author mode date contents annotations captcha ; - -paste "PASTE" +\ paste "PASTE" { { "id" "ID" INTEGER +db-assigned-id+ } { "summary" "SUMMARY" { VARCHAR 256 } +not-null+ } { "author" "AUTHOR" { VARCHAR 256 } +not-null+ } { "mode" "MODE" { VARCHAR 256 } +not-null+ } - { "date" "DATE" DATETIME +not-null+ } + { "date" "DATE" DATETIME +not-null+ , } { "contents" "CONTENTS" TEXT +not-null+ } } define-persistent : ( id -- paste ) - paste new + \ paste new swap >>id ; : pastes ( -- pastes ) f select-tuples ; -TUPLE: annotation aid id summary author mode contents date captcha ; +TUPLE: annotation aid id summary author mode contents date ; annotation "ANNOTATION" { @@ -63,175 +57,170 @@ annotation "ANNOTATION" dup id>> f select-tuples >>annotations ] unless ; -: ( -- form ) - "annotation" - "annotation" pastebin-template >>view-template - "id" - hidden >>renderer - add-field - "aid" - hidden >>renderer - add-field - "summary" add-field - "author" add-field - "mode" add-field - "contents" "mode" add-field - "date" add-field ; +: paste ( id -- paste ) + select-tuple fetch-annotations ; -: ( -- form ) - "annotation" - "new-annotation" pastebin-template >>edit-template - "id" - hidden >>renderer - t >>required add-field - "summary" - t >>required add-field - "author" - t >>required - add-field - "mode" - "factor" >>default - t >>required - add-field - "contents" "mode" - t >>required add-field - "captcha" add-field ; +: ( id next -- response ) + swap "id" associate ; -: ( -- form ) - "paste" - "paste" pastebin-template >>view-template - "paste-summary" pastebin-template >>summary-template - "id" - hidden >>renderer add-field - "summary" add-field - "author" add-field - "mode" add-field - "date" add-field - "contents" "mode" add-field - "annotations" +plain+ add-field ; +! ! ! +! LINKS, ETC +! ! ! -: ( -- form ) - "paste" - "new-paste" pastebin-template >>edit-template - "summary" - t >>required add-field - "author" - t >>required add-field - "mode" - "factor" >>default - t >>required - add-field - "contents" "mode" - t >>required add-field - "captcha" add-field ; +: pastebin-link ( -- url ) + "$pastebin/list" f link>string ; -: ( -- form ) - "pastebin" - "paste-list" pastebin-template >>view-template - "pastes" +plain+ add-field ; +GENERIC: entity-link ( entity -- url ) -:: ( -- action ) - [let | form [ ] | - - [ - blank-values +M: paste entity-link + id>> "id" associate "$pastebin/paste" swap link>string ; - pastes "pastes" set-value +M: annotation entity-link + [ id>> "id" associate "$pastebin/paste" swap link>string ] + [ aid>> number>string "#" prepend ] bi + append ; - form view-form - ] >>display - ] ; +: pastebin-template ( name -- template ) + "resource:extra/webapps/pastebin/" swap ".xml" 3append ; -:: ( form ctor next -- action ) - - { { "id" [ v-number ] } } >>get-params +! ! ! +! PASTE LIST +! ! ! - [ - "id" get f ctor call +: ( -- action ) + + [ pastes "pastes" set-value ] >>init + "pastebin" pastebin-template >>template ; - from-tuple form set-defaults - ] >>init - - [ form edit-form ] >>display - - [ - f f ctor call from-tuple - - form validate-form - - values-tuple insert-tuple - - "id" value next - ] >>submit ; - -: pastebin-feed-entries ( -- entries ) - pastes 20 short head [ - [ summary>> ] - [ "$pastebin/view-paste" swap id>> "id" associate link>string ] - [ date>> ] tri - f swap +: pastebin-feed-entries ( seq -- entries ) + 20 short head [ + entry new + swap + [ summary>> >>title ] + [ date>> >>pub-date ] + [ entity-link >>link ] + tri ] map ; : pastebin-feed ( -- feed ) feed new "Factor Pastebin" >>title - "http://paste.factorcode.org" >>link - pastebin-feed-entries >>entries ; + pastebin-link >>link + pastes pastebin-feed-entries >>entries ; -: ( -- action ) - +: ( -- action ) + [ pastebin-feed ] >>feed ; + +! ! ! +! PASTES +! ! ! + +: ( -- action ) + [ - "text/xml" - [ pastebin-feed feed>xml write-xml ] >>body - ] >>display ; + validate-integer-id + "id" value paste from-tuple -:: ( form ctor -- action ) - - { { "id" [ v-number ] } } >>get-params - - [ "id" get ctor call select-tuple fetch-annotations from-tuple ] >>init - - [ form view-form ] >>display ; - -:: ( ctor next -- action ) - - { { "id" [ v-number ] } } >>post-params - - [ - "id" get ctor call delete-tuples - - "id" get f delete-tuples - - next f - ] >>submit ; - -:: ( ctor next -- action ) - - { { "aid" [ v-number ] } } >>post-params - - [ - f "aid" get ctor call select-tuple - [ delete-tuples ] [ id>> next ] bi - ] >>submit ; - -:: ( form ctor next -- action ) - - [ - f ctor call from-tuple - - form set-defaults + "id" value + "new-annotation" [ + "id" set-value + mode-names "modes" set-value + "factor" "mode" set-value + ] nest-values ] >>init - [ form edit-form ] >>display + "paste" pastebin-template >>template ; + +: paste-feed-entries ( paste -- entries ) + fetch-annotations annotations>> pastebin-feed-entries ; + +: paste-feed ( paste -- feed ) + feed new + swap + [ "Paste #" swap id>> number>string append >>title ] + [ entity-link >>link ] + [ paste-feed-entries >>entries ] + tri ; + +: ( -- action ) + + [ validate-integer-id ] >>init + [ "id" value paste annotations>> paste-feed ] >>feed ; + +: validate-paste ( -- ) + { + { "summary" [ v-one-line ] } + { "author" [ v-one-line ] } + { "mode" [ v-mode ] } + { "contents" [ v-required ] } + { "captcha" [ v-captcha ] } + } validate-params ; + +: deposit-paste-slots ( tuple -- ) + now >>date + { "summary" "author" "mode" "contents" } deposit-slots ; + +: ( -- action ) + + [ + "factor" "mode" set-value + mode-names "modes" set-value + ] >>init + + "new-paste" pastebin-template >>template [ - f ctor call from-tuple + validate-paste - form validate-form + f + [ deposit-paste-slots ] + [ insert-tuple ] + [ id>> "$pastebin/paste" ] + tri + ] >>submit ; - values-tuple insert-tuple +: ( -- action ) + + [ validate-integer-id ] >>validate - "id" value next + [ + "id" value delete-tuples + "id" value f delete-tuples + "$pastebin/list" f + ] >>submit ; + +! ! ! +! ANNOTATIONS +! ! ! + +: ( -- action ) + + [ validate-paste ] >>validate + + [ "id" param "$pastebin/paste" ] >>display + + [ + f f + { + [ deposit-paste-slots ] + [ { "id" } deposit-slots ] + [ insert-tuple ] + [ + ! Add anchor here + id>> "$pastebin/paste" + ] + } cleave + ] >>submit ; + +: ( -- action ) + + [ { { "aid" [ v-number ] } } validate-params ] >>validate + + [ + f "aid" value select-tuple + [ delete-tuples ] + [ id>> "$pastebin/paste" ] + bi ] >>submit ; TUPLE: pastebin < dispatcher ; @@ -242,17 +231,17 @@ can-delete-pastes? define-capability : ( -- responder ) pastebin new-dispatcher - "list" add-main-responder - "feed.xml" add-responder - [ ] "view-paste" add-responder - [ ] "$pastebin/list" { can-delete-pastes? } "delete-paste" add-responder - [ ] "$pastebin/view-paste" { can-delete-pastes? } "delete-annotation" add-responder - [ ] "$pastebin/view-paste" add-responder - [ now >>date ] "$pastebin/view-paste" "new-paste" add-responder - [ now >>date ] "$pastebin/view-paste" "annotate" add-responder + "list" add-main-responder + "list.atom" add-responder + "paste" add-responder + "paste.atom" add-responder + "new-paste" add-responder + { can-delete-pastes? } "delete-paste" add-responder + "new-annotation" add-responder + { can-delete-pastes? } "delete-annotation" add-responder - "pastebin" pastebin-template >>template ; + "pastebin-common" pastebin-template >>template ; -: init-pastes-table paste ensure-table ; +: init-pastes-table \ paste ensure-table ; : init-annotations-table annotation ensure-table ; diff --git a/extra/webapps/pastebin/pastebin.xml b/extra/webapps/pastebin/pastebin.xml index 7ca4c95f8e..9ec2cb7976 100644 --- a/extra/webapps/pastebin/pastebin.xml +++ b/extra/webapps/pastebin/pastebin.xml @@ -2,29 +2,22 @@ - + - + Pastebin -
    - Pastes - | New Paste - | Atom Feed + + + + - - - - | Edit Profile - - - | Logout - - - - - -

    - - + + + + + + + +
    Summary:Paste by:Date:
    diff --git a/extra/webapps/planet/admin.xml b/extra/webapps/planet/admin.xml index c79fe2efd1..4711ca4716 100644 --- a/extra/webapps/planet/admin.xml +++ b/extra/webapps/planet/admin.xml @@ -4,11 +4,19 @@ Planet Factor Administration - +
      + +
    • + + + +
      • +       +

    - Add Blog - | Update + Add Blog + | Update

    diff --git a/extra/webapps/planet/blog-admin-link.xml b/extra/webapps/planet/blog-admin-link.xml deleted file mode 100644 index 8d6c890643..0000000000 --- a/extra/webapps/planet/blog-admin-link.xml +++ /dev/null @@ -1,7 +0,0 @@ - - - - - - - diff --git a/extra/webapps/planet/edit-blog.xml b/extra/webapps/planet/edit-blog.xml index ebfccc47de..fd9c659f59 100644 --- a/extra/webapps/planet/edit-blog.xml +++ b/extra/webapps/planet/edit-blog.xml @@ -10,17 +10,17 @@ Blog name: - + Home page: - + Feed: - + @@ -30,4 +30,5 @@ Delete + diff --git a/extra/webapps/planet/mini-planet.xml b/extra/webapps/planet/mini-planet.xml new file mode 100644 index 0000000000..1338463bcf --- /dev/null +++ b/extra/webapps/planet/mini-planet.xml @@ -0,0 +1,14 @@ + + + + + + +

    +
    + Read More... +

    + +     + +     diff --git a/extra/webapps/planet/new-blog.xml b/extra/webapps/planet/new-blog.xml new file mode 100644 index 0000000000..4a9638da03 --- /dev/null +++ b/extra/webapps/planet/new-blog.xml @@ -0,0 +1,32 @@ + + + + + Edit Blog + + + + + + + + + + + + + + + + + + + + +
    Blog name:
    Home page:
    Feed:
    + + + +     + +     diff --git a/extra/webapps/planet/planet-common.xml b/extra/webapps/planet/planet-common.xml new file mode 100644 index 0000000000..29609e12ba --- /dev/null +++ b/extra/webapps/planet/planet-common.xml @@ -0,0 +1,25 @@ + + + + + + +
    + Front Page + | Atom Feed + | Admin + + + + | Edit Profile + + + | Logout + +
    + +

    + + + +     diff --git a/extra/webapps/planet/planet.factor b/extra/webapps/planet/planet.factor index c8aeab35a8..414a59f3b2 100755 --- a/extra/webapps/planet/planet.factor +++ b/extra/webapps/planet/planet.factor @@ -1,22 +1,18 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel accessors sequences sorting locals math math.order +USING: kernel accessors sequences sorting math math.order calendar alarms logging concurrency.combinators namespaces -sequences.lib db.types db.tuples db fry +sequences.lib db.types db.tuples db fry locals hashtables +html.components html.templates.chloe rss xml.writer +validators http.server -http.server.crud -http.server.forms http.server.actions http.server.boilerplate -http.server.templating.chloe -http.server.components http.server.auth.login http.server.auth ; IN: webapps.planet -TUPLE: planet-factor < dispatcher postings ; - : planet-template ( name -- template ) "resource:extra/webapps/planet/" swap ".xml" 3append ; @@ -34,92 +30,63 @@ blog "BLOGS" { "feed-url" "FEEDURL" { VARCHAR 256 } +not-null+ } } define-persistent +! TUPLE: posting < entry id ; +TUPLE: posting id title link description pub-date ; + +posting "POSTINGS" +{ + { "id" "ID" INTEGER +db-assigned-id+ } + { "title" "TITLE" { VARCHAR 256 } +not-null+ } + { "link" "LINK" { VARCHAR 256 } +not-null+ } + { "description" "DESCRIPTION" TEXT +not-null+ } + { "pub-date" "DATE" TIMESTAMP +not-null+ } +} define-persistent + : init-blog-table blog ensure-table ; +: init-postings-table posting ensure-table ; + : ( id -- todo ) blog new swap >>id ; : blogroll ( -- seq ) - f select-tuples [ [ name>> ] compare ] sort ; + f select-tuples + [ [ name>> ] compare ] sort ; -: ( -- form ) - "entry" - "entry" planet-template >>view-template - "entry-summary" planet-template >>summary-template - "title" add-field - "description" add-field - "pub-date" add-field ; +: postings ( -- seq ) + posting new select-tuples + [ [ pub-date>> ] compare invert-comparison ] sort ; -: ( -- form ) - "blog" - "edit-blog" planet-template >>edit-template - "blog-admin-link" planet-template >>summary-template - "id" - hidden >>renderer - add-field - "name" - t >>required - add-field - "www-url" - t >>required - add-field - "feed-url" - t >>required - add-field ; +: ( -- action ) + + [ blogroll "blogroll" set-value ] >>init + "admin" planet-template >>template ; -: ( -- form ) - "planet-factor" - "postings" planet-template >>view-template - "postings-summary" planet-template >>summary-template - "postings" +plain+ add-field - "blogroll" "blog" +unordered+ add-field ; +: ( -- action ) + + [ + blogroll "blogroll" set-value + postings "postings" set-value + ] >>init -: ( -- form ) - "admin" - "admin" planet-template >>view-template - "blogroll" +unordered+ add-field ; + "planet" planet-template >>template ; -:: ( planet -- action ) - [let | form [ ] | - - [ - blank-values - - blogroll "blogroll" set-value - - form view-form - ] >>display - ] ; - -:: ( planet -- action ) - [let | form [ ] | - - [ - blank-values - - planet postings>> "postings" set-value - blogroll "blogroll" set-value - - form view-form - ] >>display - ] ; - -:: planet-feed ( planet -- feed ) +: planet-feed ( -- feed ) feed new "Planet Factor" >>title "http://planet.factorcode.org" >>link - planet postings>> 16 short head >>entries ; + postings >>entries ; -:: ( planet -- action ) - - [ - "text/xml" - [ planet planet-feed feed>xml write-xml ] >>body - ] >>display ; +: ( -- action ) + [ planet-feed ] >>feed ; -: ( name entry -- entry' ) - clone [ ": " swap 3append ] change-title ; +:: ( entry name -- entry' ) + posting new + name ": " entry title>> 3append >>title + entry link>> >>link + entry description>> >>description + entry pub-date>> >>pub-date ; : fetch-feed ( url -- feed ) download-feed entries>> ; @@ -127,55 +94,106 @@ blog "BLOGS" \ fetch-feed DEBUG add-error-logging : fetch-blogroll ( blogroll -- entries ) - dup - [ feed-url>> fetch-feed ] parallel-map - [ >r name>> r> [ ] with map ] 2map concat ; + [ [ feed-url>> fetch-feed ] parallel-map ] [ [ name>> ] map ] bi + [ '[ , ] map ] 2map concat ; : sort-entries ( entries -- entries' ) - [ [ pub-date>> ] compare ] sort ; + [ [ pub-date>> ] compare invert-comparison ] sort ; -: update-cached-postings ( planet -- ) - "webapps.planet" [ - blogroll fetch-blogroll sort-entries 8 short head - >>postings drop - ] with-logging ; +: update-cached-postings ( -- ) + blogroll fetch-blogroll sort-entries 8 short head [ + posting new delete-tuples + [ insert-tuple ] each + ] with-transaction ; -:: ( planet -- action ) +: ( -- action ) [ - planet update-cached-postings - "" f - ] >>display ; + update-cached-postings + "" f + ] >>submit ; -:: ( planet-factor -- responder ) - [let | blog-form [ ] - blog-ctor [ [ ] ] | - - planet-factor >>default +: ( -- action ) + + [ validate-integer-id ] >>validate - planet-factor "update" add-responder + [ + "id" value delete-tuples + "$planet-factor/admin" f + ] >>submit ; - ! Administrative CRUD - blog-ctor "$planet-factor/admin" "delete-blog" add-responder - blog-form blog-ctor "$planet-factor/admin" "edit-blog" add-responder - ] ; +: validate-blog ( -- ) + { + { "name" [ v-one-line ] } + { "www-url" [ v-url ] } + { "feed-url" [ v-url ] } + } validate-params ; + +: ( id next -- response ) + swap "id" associate ; + +: deposit-blog-slots ( blog -- ) + { "name" "www-url" "feed-url" } deposit-slots ; + +: ( -- action ) + + "new-blog" planet-template >>template + + [ validate-blog ] >>validate + + [ + f + [ deposit-blog-slots ] + [ insert-tuple ] + [ id>> "$planet-factor/admin/edit-blog" ] + tri + ] >>submit ; + +: ( -- action ) + + [ + validate-integer-id + "id" value select-tuple from-tuple + ] >>init + + "edit-blog" planet-template >>template + + [ + validate-integer-id + validate-blog + ] >>validate + + [ + f + [ deposit-blog-slots ] + [ update-tuple ] + [ id>> "$planet-factor/admin" ] + tri + ] >>submit ; + +TUPLE: planet-factor-admin < dispatcher ; + +: ( -- responder ) + planet-factor-admin new-dispatcher + "blogroll" add-main-responder + "update" add-responder + "new-blog" add-responder + "edit-blog" add-responder + "delete-blog" add-responder ; SYMBOL: can-administer-planet-factor? can-administer-planet-factor? define-capability +TUPLE: planet-factor < dispatcher ; + : ( -- responder ) planet-factor new-dispatcher - dup "list" add-main-responder - dup "feed.xml" add-responder - dup { can-administer-planet-factor? } "admin" add-responder + "list" add-main-responder + "feed.xml" add-responder + { can-administer-planet-factor? } "admin" add-responder - "planet" planet-template >>template ; + "planet-common" planet-template >>template ; -: start-update-task ( planet db seq -- ) - '[ - , , , [ - dup filter-responder? [ responder>> ] when - update-cached-postings - ] with-db - ] 10 minutes every drop ; +: start-update-task ( db params -- ) + '[ , , [ update-cached-postings ] with-db ] 10 minutes every drop ; diff --git a/extra/webapps/planet/planet.xml b/extra/webapps/planet/planet.xml index 29609e12ba..526a9b306b 100644 --- a/extra/webapps/planet/planet.xml +++ b/extra/webapps/planet/planet.xml @@ -2,24 +2,44 @@ - + Planet Factor -
    - Front Page - | Atom Feed - | Admin + + + + + + +
    - - - | Edit Profile - - - | Logout - - + -

    +

    + +

    - +

    + +

    + +

    + +

    + +     + +     		+ +

    Blogroll

    + +
      + +
    • + +
      • +       +
    + +
    diff --git a/extra/webapps/planet/postings-summary.xml b/extra/webapps/planet/postings-summary.xml deleted file mode 100644 index 765c3a8006..0000000000 --- a/extra/webapps/planet/postings-summary.xml +++ /dev/null @@ -1,7 +0,0 @@ - - - - - - - diff --git a/extra/webapps/planet/postings.xml b/extra/webapps/planet/postings.xml deleted file mode 100644 index c2c73d7e89..0000000000 --- a/extra/webapps/planet/postings.xml +++ /dev/null @@ -1,19 +0,0 @@ - - - - - Planet Factor - - - - - - - -
    -

    Blogroll

    - - -
    - -     diff --git a/extra/webapps/todo/edit-todo.xml b/extra/webapps/todo/edit-todo.xml index e1d4c40e23..0974c8ce1b 100644 --- a/extra/webapps/todo/edit-todo.xml +++ b/extra/webapps/todo/edit-todo.xml @@ -6,9 +6,9 @@ - - - + + +
    Summary:
    Priority:
    Description:
    Summary:
    Priority:
    Description:
    diff --git a/extra/webapps/todo/todo-list.xml b/extra/webapps/todo/todo-list.xml index 66abeafc86..845c38dbf7 100644 --- a/extra/webapps/todo/todo-list.xml +++ b/extra/webapps/todo/todo-list.xml @@ -5,8 +5,33 @@ My Todo List - - + + + + + + + + + + + + + + + + + + +
    SummaryPriorityViewEdit
    SummaryPriorityViewEdit
    + + + + + View + + Edit +
    diff --git a/extra/webapps/todo/todo-summary.xml b/extra/webapps/todo/todo-summary.xml deleted file mode 100644 index 056c9cab0a..0000000000 --- a/extra/webapps/todo/todo-summary.xml +++ /dev/null @@ -1,20 +0,0 @@ - - - - - - - - - - - - - View - - - Edit - - - - diff --git a/extra/webapps/todo/todo.factor b/extra/webapps/todo/todo.factor index 8bfda1aad5..e3b174eaea 100755 --- a/extra/webapps/todo/todo.factor +++ b/extra/webapps/todo/todo.factor @@ -1,14 +1,11 @@ ! Copyright (c) 2008 Slava Pestov ! See http://factorcode.org/license.txt for BSD license. -USING: accessors kernel locals sequences namespaces -db db.types db.tuples +USING: accessors kernel sequences namespaces +db db.types db.tuples validators hashtables +html.components +html.templates.chloe http.server.sessions -http.server.components -http.server.components.farkup -http.server.forms -http.server.templating.chloe http.server.boilerplate -http.server.crud http.server.auth http.server.actions http.server.db @@ -37,44 +34,86 @@ todo "TODO" : todo-template ( name -- template ) "resource:extra/webapps/todo/" swap ".xml" 3append ; -: ( -- form ) - "todo" - "view-todo" todo-template >>view-template - "edit-todo" todo-template >>edit-template - "todo-summary" todo-template >>summary-template - "id" - hidden >>renderer - add-field - "summary" - t >>required - add-field - "priority" - t >>required - 0 >>default - 0 >>min-value - 10 >>max-value - add-field - "description" - add-field ; +: ( -- action ) + + [ + validate-integer-id + "id" value select-tuple from-tuple + ] >>init + + "view-todo" todo-template >>template ; -: ( -- form ) - "todo-list" - "todo-list" todo-template >>view-template - "list" +plain+ - add-field ; +: ( id next -- response ) + swap "id" associate ; + +: validate-todo ( -- ) + { + { "summary" [ v-one-line ] } + { "priority" [ v-integer 0 v-min-value 10 v-max-value ] } + { "description" [ v-required ] } + } validate-params ; + +: ( -- action ) + + [ 0 "priority" set-value ] >>init + + "edit-todo" todo-template >>template + + [ validate-todo ] >>validate + + [ + f + dup { "summary" "description" } deposit-slots + [ insert-tuple ] + [ id>> "$todo-list/view" ] + bi + ] >>submit ; + +: ( -- action ) + + [ + validate-integer-id + "id" value select-tuple from-tuple + ] >>init + + "edit-todo" todo-template >>template + + [ + validate-integer-id + validate-todo + ] >>validate + + [ + f + dup { "id" "summary" "priority" "description" } deposit-slots + [ update-tuple ] + [ id>> "$todo-list/view" ] + bi + ] >>submit ; + +: ( -- action ) + + [ validate-integer-id ] >>validate + + [ + "id" get delete-tuples + "$todo-list/list" f + ] >>submit ; + +: ( -- action ) + + [ f select-tuples "items" set-value ] >>init + "todo-list" todo-template >>template ; TUPLE: todo-list < dispatcher ; -:: ( -- responder ) - [let | todo-form [ ] - list-form [ ] - ctor [ [ ] ] | - todo-list new-dispatcher - list-form ctor "list" add-main-responder - todo-form ctor "view" add-responder - todo-form ctor "$todo-list/view" "edit" add-responder - ctor "$todo-list/list" "delete" add-responder - - "todo" todo-template >>template - f - ] ; +: ( -- responder ) + todo-list new-dispatcher + "list" add-main-responder + "view" add-responder + "new" add-responder + "edit" add-responder + "delete" add-responder + + "todo" todo-template >>template + f ; diff --git a/extra/webapps/todo/todo.xml b/extra/webapps/todo/todo.xml index 651e29d867..39ab5cda8b 100644 --- a/extra/webapps/todo/todo.xml +++ b/extra/webapps/todo/todo.xml @@ -12,7 +12,7 @@ | Edit Profile - Logout + | Logout

    diff --git a/extra/webapps/todo/view-todo.xml b/extra/webapps/todo/view-todo.xml index 8c90ba9056..a443528bac 100644 --- a/extra/webapps/todo/view-todo.xml +++ b/extra/webapps/todo/view-todo.xml @@ -5,12 +5,12 @@ View Item - - + +
    Summary:
    Priority:
    Summary:
    Priority:
    - +
    Edit diff --git a/extra/http/server/auth/admin/edit-user.xml b/extra/webapps/user-admin/edit-user.xml similarity index 67% rename from extra/http/server/auth/admin/edit-user.xml rename to extra/webapps/user-admin/edit-user.xml index 9c0fe702bb..3f9ac8d690 100644 --- a/extra/http/server/auth/admin/edit-user.xml +++ b/extra/webapps/user-admin/edit-user.xml @@ -10,44 +10,44 @@ User name: - + Real name: - + New password: - + Verify: - + E-mail: - + Capabilities: - + Profile: - +

    - +

    diff --git a/extra/http/server/auth/admin/new-user.xml b/extra/webapps/user-admin/new-user.xml similarity index 64% rename from extra/http/server/auth/admin/new-user.xml rename to extra/webapps/user-admin/new-user.xml index 2d67639985..881dca9c16 100644 --- a/extra/http/server/auth/admin/new-user.xml +++ b/extra/webapps/user-admin/new-user.xml @@ -10,39 +10,39 @@ User name: - + Real name: - + New password: - + Verify: - + E-mail: - + Capabilities: - +

    - +

    diff --git a/extra/webapps/user-admin/user-admin.factor b/extra/webapps/user-admin/user-admin.factor new file mode 100644 index 0000000000..cdaf3f5ea9 --- /dev/null +++ b/extra/webapps/user-admin/user-admin.factor @@ -0,0 +1,156 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: kernel sequences accessors namespaces combinators words +assocs db.tuples arrays splitting strings validators +html.elements +html.components +html.templates.chloe +http.server.boilerplate +http.server.auth.providers +http.server.auth.providers.db +http.server.auth.login +http.server.auth +http.server.sessions +http.server.actions +http.server ; +IN: webapps.user-admin + +: admin-template ( name -- template ) + "resource:extra/webapps/user-admin/" swap ".xml" 3append ; + +: words>strings ( seq -- seq' ) + [ [ word-vocabulary ] [ drop ":" ] [ word-name ] tri 3append ] map ; + +: strings>words ( seq -- seq' ) + [ ":" split1 swap lookup ] map ; + +: ( -- action ) + + [ f select-tuples "users" set-value ] >>init + "user-list" admin-template >>template ; + +: ( -- action ) + + [ + "username" param from-tuple + capabilities get words>strings "all-capabilities" set-value + ] >>init + + "new-user" admin-template >>template + + [ + capabilities get words>strings "all-capabilities" set-value + + { + { "username" [ v-username ] } + { "realname" [ v-one-line ] } + { "new-password" [ v-password ] } + { "verify-password" [ v-password ] } + { "email" [ [ v-email ] v-optional ] } + { "capabilities" [ ] } + } validate-params + + same-password-twice + + user new "username" value >>username select-tuple + [ user-exists ] when + ] >>validate + + [ + "username" value + "realname" value >>realname + "email" value >>email + "new-password" value >>encoded-password + H{ } clone >>profile + + insert-tuple + + "$user-admin" f + ] >>submit ; + +: validate-username ( -- ) + { { "username" [ v-username ] } } validate-params ; + +: ( -- action ) + + [ + validate-username + + "username" value select-tuple + [ from-tuple ] [ capabilities>> words>strings "capabilities" set-value ] bi + + capabilities get words>strings "all-capabilities" set-value + ] >>init + + "edit-user" admin-template >>template + + [ + capabilities get words>strings "all-capabilities" set-value + + { + { "username" [ v-username ] } + { "realname" [ v-one-line ] } + { "new-password" [ [ v-password ] v-optional ] } + { "verify-password" [ [ v-password ] v-optional ] } + { "email" [ [ v-email ] v-optional ] } + { "capabilities" [ ] } + } validate-params + + "new-password" "verify-password" + [ value empty? not ] either? [ + same-password-twice + ] when + ] >>validate + + [ + "username" value select-tuple + "realname" value >>realname + "email" value >>email + + "new-password" value empty? [ + "new-password" value >>encoded-password + ] unless + + "capabilities" value { + { [ dup string? ] [ 1array ] } + { [ dup array? ] [ ] } + } cond strings>words >>capabilities + + update-tuple + + "$user-admin" f + ] >>submit ; + +: ( -- action ) + + [ + validate-username + + [ select-tuple 1 >>deleted update-tuple ] + [ logout-all-sessions ] + bi + + "$user-admin" f + ] >>submit ; + +TUPLE: user-admin < dispatcher ; + +SYMBOL: can-administer-users? + +can-administer-users? define-capability + +: ( -- responder ) + user-admin new-dispatcher + "list" add-main-responder + "new" add-responder + "edit" add-responder + "delete" add-responder + + "user-admin" admin-template >>template + { can-administer-users? } ; + +: make-admin ( username -- ) + + select-tuple + [ can-administer-users? suffix ] change-capabilities + update-tuple ; diff --git a/extra/http/server/auth/admin/admin.xml b/extra/webapps/user-admin/user-admin.xml similarity index 100% rename from extra/http/server/auth/admin/admin.xml rename to extra/webapps/user-admin/user-admin.xml diff --git a/extra/webapps/user-admin/user-list.xml b/extra/webapps/user-admin/user-list.xml new file mode 100644 index 0000000000..020d053e03 --- /dev/null +++ b/extra/webapps/user-admin/user-list.xml @@ -0,0 +1,19 @@ + + + + + Users + +
      + + +
    • + + + +
      • +       + +
    + +     diff --git a/extra/webapps/wiki/articles.xml b/extra/webapps/wiki/articles.xml new file mode 100644 index 0000000000..a552c2618f --- /dev/null +++ b/extra/webapps/wiki/articles.xml @@ -0,0 +1,15 @@ + + + + + All Articles + +
      + +
    • + +
      • +       +
    + +     diff --git a/extra/webapps/wiki/changes.xml b/extra/webapps/wiki/changes.xml new file mode 100644 index 0000000000..5efa0c045a --- /dev/null +++ b/extra/webapps/wiki/changes.xml @@ -0,0 +1,19 @@ + + + + + Recent Changes + +
      + +
    • + + on + + by + +
      • +       +
    + +     diff --git a/extra/webapps/wiki/diff.xml b/extra/webapps/wiki/diff.xml new file mode 100644 index 0000000000..0fb0d6bae6 --- /dev/null +++ b/extra/webapps/wiki/diff.xml @@ -0,0 +1,35 @@ + + + + + + Diff: + + + + + + + + + + + + + + + +
    Old revision:Created on by .
    New revision:Created on by .
    + + + + +
    + Latest + | Revisions + | Edit + | Delete +
    +     + +     diff --git a/extra/webapps/wiki/edit.xml b/extra/webapps/wiki/edit.xml new file mode 100644 index 0000000000..85c8490c5d --- /dev/null +++ b/extra/webapps/wiki/edit.xml @@ -0,0 +1,20 @@ + + + + + Edit: + + + +

    + +

    + +

    + +

    + +     + + Delete +     diff --git a/extra/webapps/wiki/revisions.xml b/extra/webapps/wiki/revisions.xml new file mode 100644 index 0000000000..4b7bdadf50 --- /dev/null +++ b/extra/webapps/wiki/revisions.xml @@ -0,0 +1,48 @@ + + + + + Revisions of + +
      + +
    • + + by + +
      • +       +
    + +

    View Differences

    + + + + + + + + + + + + + +
    Old revision: + +
    New revision: + +
    + + + + +     diff --git a/extra/webapps/wiki/user-edits.xml b/extra/webapps/wiki/user-edits.xml new file mode 100644 index 0000000000..cf19a38370 --- /dev/null +++ b/extra/webapps/wiki/user-edits.xml @@ -0,0 +1,17 @@ + + + + + Edits by + +
      + +
    • + + on + +
      • +       +
    + +     diff --git a/extra/webapps/wiki/view.xml b/extra/webapps/wiki/view.xml new file mode 100644 index 0000000000..56c8b37a1d --- /dev/null +++ b/extra/webapps/wiki/view.xml @@ -0,0 +1,19 @@ + + + + + + +
    + +
    + +
    + Latest + | Revisions + | Edit + | Delete + | This revision created on by . +
    + +     diff --git a/extra/webapps/wiki/wiki-common.xml b/extra/webapps/wiki/wiki-common.xml new file mode 100644 index 0000000000..23e61e55fe --- /dev/null +++ b/extra/webapps/wiki/wiki-common.xml @@ -0,0 +1,29 @@ + + + + + + +
    + + Front Page + | All Articles + | Recent Changes + + + + + | Edit Profile + + + | Logout + + + +
    + +

    + + + +     diff --git a/extra/webapps/wiki/wiki.css b/extra/webapps/wiki/wiki.css new file mode 100644 index 0000000000..e737cdd898 --- /dev/null +++ b/extra/webapps/wiki/wiki.css @@ -0,0 +1,25 @@ +.comparison table, { + border-color: #666; + border-style: solid; +} + +.comparison th { + border-width: 1px; + border-color: #666; + border-style: solid; +} + +.comparison table { + border-width: 1px; + border-spacing: 0; + border-collapse: collapse; +} + + +.insert { + background-color: #9f9; +} + +.delete { + background-color: #f99; +} diff --git a/extra/webapps/wiki/wiki.factor b/extra/webapps/wiki/wiki.factor new file mode 100644 index 0000000000..344a3d40bd --- /dev/null +++ b/extra/webapps/wiki/wiki.factor @@ -0,0 +1,202 @@ +! Copyright (C) 2008 Slava Pestov +! See http://factorcode.org/license.txt for BSD license. +USING: accessors kernel hashtables calendar +namespaces splitting sequences sorting math.order +html.components +html.templates.chloe +http.server +http.server.actions +http.server.auth +http.server.auth.login +http.server.boilerplate +validators +db.types db.tuples lcs farkup ; +IN: webapps.wiki + +TUPLE: article title revision ; + +article "ARTICLES" { + { "title" "TITLE" { VARCHAR 256 } +not-null+ +user-assigned-id+ } + ! { "AUTHOR" INTEGER +not-null+ } ! uid + ! { "PROTECTED" BOOLEAN +not-null+ } + { "revision" "REVISION" INTEGER +not-null+ } ! revision id +} define-persistent + +:
    ( title -- article ) article new swap >>title ; + +: init-articles-table article ensure-table ; + +TUPLE: revision id title author date content ; + +revision "REVISIONS" { + { "id" "ID" INTEGER +db-assigned-id+ } + { "title" "TITLE" { VARCHAR 256 } +not-null+ } ! article id + { "author" "AUTHOR" { VARCHAR 256 } +not-null+ } ! uid + { "date" "DATE" TIMESTAMP +not-null+ } + { "content" "CONTENT" TEXT +not-null+ } +} define-persistent + +: ( id -- revision ) + revision new swap >>id ; + +: init-revisions-table revision ensure-table ; + +: wiki-template ( name -- template ) + "resource:extra/webapps/wiki/" swap ".xml" 3append ; + +: ( title next -- response ) + swap "title" associate ; + +: validate-title ( -- ) + { { "title" [ v-one-line ] } } validate-params ; + +: ( -- action ) + + [ "Front Page" "$wiki/view" ] >>display ; + +: ( -- action ) + + "title" >>rest-param + + [ + validate-title + "view?title=" relative-link-prefix set + ] >>init + + [ + "title" value dup
    select-tuple [ + revision>> select-tuple from-tuple + "view" wiki-template + ] [ + "$wiki/edit" + ] ?if + ] >>display ; + +: ( -- action ) + + [ + { { "id" [ v-integer ] } } validate-params + "id" value + select-tuple from-tuple + ] >>init + + "view" wiki-template >>template ; + +: add-revision ( revision -- ) + [ insert-tuple ] + [ + dup title>>
    select-tuple [ + swap id>> >>revision update-tuple + ] [ + [ title>> ] [ id>> ] bi article boa insert-tuple + ] if* + ] bi ; + +: ( -- action ) + + [ + validate-title + "title" value
    select-tuple [ + revision>> select-tuple from-tuple + ] when* + ] >>init + + "edit" wiki-template >>template + + [ + validate-title + { { "content" [ v-required ] } } validate-params + + f + "title" value >>title + now >>date + logged-in-user get username>> >>author + "content" value >>content + [ add-revision ] + [ title>> "$wiki/view" ] bi + ] >>submit ; + +: ( -- action ) + + [ + validate-title + f "title" value >>title select-tuples + [ [ date>> ] compare invert-comparison ] sort + "revisions" set-value + ] >>init + + "revisions" wiki-template >>template ; + +: ( -- action ) + + [ + f select-tuples + [ [ date>> ] compare invert-comparison ] sort + "changes" set-value + ] >>init + + "changes" wiki-template >>template ; + +: ( -- action ) + + [ validate-title ] >>validate + + [ + "title" value
    delete-tuples + f "title" value >>title delete-tuples + "" f + ] >>submit ; + +: ( -- action ) + + [ + { + { "old-id" [ v-integer ] } + { "new-id" [ v-integer ] } + } validate-params + + "old-id" "new-id" + [ value select-tuple ] bi@ + [ [ "old" set-value ] [ "new" set-value ] bi* ] + [ [ content>> string-lines ] bi@ diff "diff" set-value ] + 2bi + ] >>init + + "diff" wiki-template >>template ; + +: ( -- action ) + + [ + f
    select-tuples + [ [ title>> ] compare ] sort + "articles" set-value + ] >>init + + "articles" wiki-template >>template ; + +: ( -- action ) + + [ + { { "author" [ v-username ] } } validate-params + f "author" value >>author + select-tuples "user-edits" set-value + ] >>init + + "user-edits" wiki-template >>template ; + +TUPLE: wiki < dispatcher ; + +: ( -- dispatcher ) + wiki new-dispatcher + "" add-responder + "view" add-responder + "revision" add-responder + "revisions" add-responder + "user-edits" add-responder + "diff" add-responder + "articles" add-responder + "changes" add-responder + { } "edit" add-responder + { } "delete" add-responder + + "wiki-common" wiki-template >>template ; diff --git a/extra/xmode/catalog/catalog.factor b/extra/xmode/catalog/catalog.factor index 277439c0cd..8c6025f726 100755 --- a/extra/xmode/catalog/catalog.factor +++ b/extra/xmode/catalog/catalog.factor @@ -1,6 +1,6 @@ USING: xmode.loader xmode.utilities xmode.rules namespaces strings splitting assocs sequences kernel io.files xml memoize -words globs combinators io.encodings.utf8 ; +words globs combinators io.encodings.utf8 sorting ; IN: xmode.catalog TUPLE: mode file file-name-glob first-line-glob ; @@ -23,17 +23,15 @@ TAGS> swap child-tags [ parse-mode-tag ] with each ] keep ; -: load-catalog ( -- modes ) +MEMO: modes ( -- modes ) "resource:extra/xmode/modes/catalog" file>xml parse-modes-tag ; -: modes ( -- assoc ) - \ modes get-global [ - load-catalog dup \ modes set-global - ] unless* ; +MEMO: mode-names ( -- modes ) + modes keys natural-sort ; : reset-catalog ( -- ) - f \ modes set-global ; + \ modes reset-memoized ; MEMO: (load-mode) ( name -- rule-sets ) modes at [ diff --git a/extra/xmode/code2html/code2html.factor b/extra/xmode/code2html/code2html.factor index 3977f4277c..6eccddc94a 100755 --- a/extra/xmode/code2html/code2html.factor +++ b/extra/xmode/code2html/code2html.factor @@ -1,12 +1,12 @@ -USING: xmode.tokens xmode.marker xmode.catalog kernel html +USING: xmode.tokens xmode.marker xmode.catalog kernel html.elements io io.files sequences words io.encodings.utf8 -namespaces ; +namespaces xml.entities ; IN: xmode.code2html : htmlize-tokens ( tokens -- ) [ dup token-str swap token-id [ - write + escape-string write ] [ write ] if* @@ -21,7 +21,7 @@ IN: xmode.code2html : default-stylesheet ( -- ) ; : htmlize-stream ( path stream -- ) @@ -29,7 +29,7 @@ IN: xmode.code2html default-stylesheet - dup write + dup escape-string write 
    diff --git a/extra/xmode/code2html/responder/responder.factor b/extra/xmode/code2html/responder/responder.factor
index 7b2bdd992a..2f56a5b819 100755
--- a/extra/xmode/code2html/responder/responder.factor
+++ b/extra/xmode/code2html/responder/responder.factor
@@ -1,21 +1,16 @@
 ! Copyright (C) 2007, 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: io.files io.encodings.utf8 namespaces http.server
-http.server.static http xmode.code2html kernel html sequences
+USING: io io.files io.encodings.utf8 namespaces http.server
+http.server.static http xmode.code2html kernel sequences
 accessors fry ;
 IN: xmode.code2html.responder
 
 :  ( root -- responder )
     [
         drop
-        "text/html"  swap
-        [ "last-modified" set-header ]
-        [
-            '[
-                ,
-                dup file-name swap utf8
-                
-                [ htmlize-stream ] with-html-stream
-            ] >>body
-        ] bi
+        dup '[
+            , utf8 [
+                , file-name input-stream get htmlize-stream
+            ] with-file-reader
+        ] 
     ]  ;
diff --git a/vm/code_gc.h b/vm/code_gc.h
index 658dc990ae..ecc9f697f5 100644
--- a/vm/code_gc.h
+++ b/vm/code_gc.h
@@ -17,9 +17,6 @@ typedef struct _F_BLOCK
 
 	/* Used during compaction */
 	struct _F_BLOCK *forwarding;
-
-	/* Alignment padding */
-	CELL padding[4];
 } F_BLOCK;
 
 typedef struct {