diff --git a/core/alien/compiler/compiler.factor b/core/alien/compiler/compiler.factor index 08b52367b0..67665b4d7e 100755 --- a/core/alien/compiler/compiler.factor +++ b/core/alien/compiler/compiler.factor @@ -7,7 +7,7 @@ math.parser classes alien.arrays alien.c-types alien.strings alien.structs alien.syntax cpu.architecture alien inspector quotations assocs kernel.private threads continuations.private libc combinators compiler.errors continuations layouts accessors -; +init ; IN: alien.compiler TUPLE: #alien-node < node return parameters abi ; @@ -336,7 +336,7 @@ M: #alien-indirect generate-node ! this hashtable, they will all be blown away by code GC, beware SYMBOL: callbacks -callbacks global [ H{ } assoc-like ] change-at +[ H{ } clone callbacks set-global ] "alien.compiler" add-init-hook : register-callback ( word -- ) dup callbacks get set-at ; @@ -344,7 +344,7 @@ M: alien-callback-error summary drop "Words calling ``alien-callback'' must be compiled with the optimizing compiler." ; : callback-bottom ( node -- ) - xt>> [ word-xt drop ] curry + xt>> [ [ register-callback ] [ word-xt drop ] bi ] curry recursive-state get infer-quot ; \ alien-callback [ @@ -354,7 +354,7 @@ M: alien-callback-error summary pop-literal nip >>abi pop-parameters >>parameters pop-literal nip >>return - gensym dup register-callback >>xt + gensym >>xt callback-bottom ] "infer" set-word-prop diff --git a/core/alien/structs/structs-docs.factor b/core/alien/structs/structs-docs.factor index e7e576293f..baf0b40707 100755 --- a/core/alien/structs/structs-docs.factor +++ b/core/alien/structs/structs-docs.factor @@ -91,6 +91,6 @@ $nl ARTICLE: "c-unions" "C unions" "A " { $snippet "union" } " in C defines a type large enough to hold its largest member. This is usually used to allocate a block of memory which can hold one of several types of values." { $subsection POSTPONE: C-UNION: } -"C structure objects can be allocated by calling " { $link } " or " { $link malloc-object } "." +"C union objects can be allocated by calling " { $link } " or " { $link malloc-object } "." $nl "Arrays of C unions can be created by calling " { $link } " or " { $link malloc-array } ". Elements can be read and written using words named " { $snippet { $emphasis "type" } "-nth" } " and " { $snippet "set-" { $emphasis "type" } "-nth" } "; these words are automatically generated by " { $link POSTPONE: C-UNION: } "." ; 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-docs.factor b/core/combinators/combinators-docs.factor index 61752ac7d6..c65c01d2ab 100755 --- a/core/combinators/combinators-docs.factor +++ b/core/combinators/combinators-docs.factor @@ -10,8 +10,10 @@ ARTICLE: "combinators-quot" "Quotation construction utilities" { $subsection alist>quot } ; ARTICLE: "combinators" "Additional combinators" -"The " { $vocab-link "combinators" } " vocabulary provides generalizations of certain combinators from the " { $vocab-link "kernel" } " vocabulary." +"The " { $vocab-link "combinators" } " vocabulary provides a few useful combinators." $nl +"A looping combinator:" +{ $subsection while } "Generalization of " { $link bi } " and " { $link tri } ":" { $subsection cleave } "Generalization of " { $link bi* } " and " { $link tri* } ":" 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-docs.factor b/core/generator/fixup/fixup-docs.factor index f5d530dccb..64d733ef8c 100644 --- a/core/generator/fixup/fixup-docs.factor +++ b/core/generator/fixup/fixup-docs.factor @@ -1,14 +1,11 @@ -USING: help.syntax help.markup generator.fixup math kernel +USING: help.syntax help.markup math kernel words strings alien ; +IN: generator.fixup HELP: frame-required { $values { "n" "a non-negative integer" } } { $description "Notify the code generator that the currently compiling code block needs a stack frame with room for at least " { $snippet "n" } " parameters." } ; -HELP: (rel-fixup) -{ $values { "arg" integer } { "class" "a relocation class" } { "type" "a relocation type" } { "offset" integer } { "pair" "a pair of integers" } } -{ $description "Creates a relocation instruction for the VM's runtime compiled code linker." } ; - HELP: add-literal { $values { "obj" object } { "n" integer } } { $description "Adds a literal to the " { $link literal-table } ", if it is not already there, and outputs the index of the literal in the table. This literal can then be used as an argument for a " { $link rt-literal } " relocation with " { $link rel-fixup } "." } ; diff --git a/core/generator/fixup/fixup.factor b/core/generator/fixup/fixup.factor index 06895cd8ac..a0961984ed 100755 --- a/core/generator/fixup/fixup.factor +++ b/core/generator/fixup/fixup.factor @@ -1,9 +1,10 @@ ! Copyright (C) 2007, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: arrays generic assocs hashtables +USING: arrays byte-arrays generic assocs hashtables io.binary kernel kernel.private math namespaces sequences words -quotations strings alien.strings layouts system combinators -math.bitfields words.private cpu.architecture math.order ; +quotations strings alien.accessors alien.strings layouts system +combinators math.bitfields words.private cpu.architecture +math.order accessors growable ; IN: generator.fixup : no-stack-frame -1 ; inline @@ -77,38 +78,35 @@ TUPLE: label-fixup label class ; : label-fixup ( label class -- ) \ label-fixup boa , ; M: label-fixup fixup* - dup label-fixup-class rc-absolute? + dup class>> rc-absolute? [ "Absolute labels not supported" throw ] when - dup label-fixup-label swap label-fixup-class - compiled-offset 4 - rot 3array label-table get push ; + dup label>> swap class>> compiled-offset 4 - rot + 3array label-table get push ; TUPLE: rel-fixup arg class type ; : rel-fixup ( arg class type -- ) \ rel-fixup boa , ; -: (rel-fixup) ( arg class type offset -- pair ) - pick rc-absolute-cell = cell 4 ? - - >r { 0 8 16 } bitfield r> - 2array ; +: push-4 ( value vector -- ) + [ length ] [ B{ 0 0 0 0 } swap push-all ] [ underlying ] tri + swap set-alien-unsigned-4 ; M: rel-fixup fixup* - dup rel-fixup-arg - over rel-fixup-class - rot rel-fixup-type - compiled-offset (rel-fixup) - relocation-table get push-all ; + [ [ arg>> ] [ class>> ] [ type>> ] tri { 0 8 16 } bitfield ] + [ class>> rc-absolute-cell = cell 4 ? compiled-offset swap - ] bi + [ relocation-table get push-4 ] bi@ ; 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 ; @@ -134,7 +132,7 @@ SYMBOL: literal-table 0 swap rt-here rel-fixup ; : init-fixup ( -- ) - V{ } clone relocation-table set + BV{ } clone relocation-table set V{ } clone label-table set ; : resolve-labels ( labels -- labels' ) @@ -150,6 +148,6 @@ SYMBOL: literal-table dup stack-frame-size swap [ fixup* ] each drop literal-table get >array - relocation-table get >array + relocation-table get >byte-array label-table get resolve-labels ] { } make ; 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/io/binary/binary-docs.factor b/core/io/binary/binary-docs.factor index 507571c044..ab82abe146 100644 --- a/core/io/binary/binary-docs.factor +++ b/core/io/binary/binary-docs.factor @@ -1,8 +1,8 @@ -USING: help.markup help.syntax io math ; +USING: help.markup help.syntax io math byte-arrays ; IN: io.binary ARTICLE: "stream-binary" "Working with binary data" -"The core stream words read and write strings. Packed binary integers can be read and written by converting to and from sequences of bytes. Floating point numbers can be read and written by converting them into a their bitwise integer representation (" { $link "floats" } ")." +"Stream words on binary streams only read and write byte arrays. Packed binary integers can be read and written by converting to and from sequences of bytes. Floating point numbers can be read and written by converting them into a their bitwise integer representation (" { $link "floats" } ")." $nl "There are two ways to order the bytes making up an integer; " { $emphasis "little endian" } " byte order outputs the least significant byte first, and the most significant byte last, whereas " { $emphasis "big endian" } " is the other way around." $nl @@ -42,11 +42,11 @@ HELP: nth-byte { $description "Outputs the " { $snippet "n" } "th least significant byte of the sign-extended 2's complement representation of " { $snippet "x" } "." } ; HELP: >le -{ $values { "x" integer } { "n" "a non-negative integer" } { "str" "a string" } } +{ $values { "x" integer } { "n" "a non-negative integer" } { "byte-array" byte-array } } { $description "Converts an integer " { $snippet "x" } " into a string of " { $snippet "n" } " bytes in little endian order. Truncation will occur if the integer is not in the range " { $snippet "[-2^(8n),2^(8n))" } "." } ; HELP: >be -{ $values { "x" integer } { "n" "a non-negative integer" } { "str" "a string" } } +{ $values { "x" integer } { "n" "a non-negative integer" } { "byte-array" byte-array } } { $description "Converts an integer " { $snippet "x" } " into a string of " { $snippet "n" } " bytes in big endian order. Truncation will occur if the integer is not in the range " { $snippet "[-2^(8n),2^(8n))" } "." } ; HELP: mask-byte diff --git a/core/io/binary/binary.factor b/core/io/binary/binary.factor index f2ede93fd5..f3d236433f 100755 --- a/core/io/binary/binary.factor +++ b/core/io/binary/binary.factor @@ -10,8 +10,8 @@ IN: io.binary : nth-byte ( x n -- b ) -8 * shift mask-byte ; inline -: >le ( x n -- str ) [ nth-byte ] with B{ } map-as ; -: >be ( x n -- str ) >le dup reverse-here ; +: >le ( x n -- byte-array ) [ nth-byte ] with B{ } map-as ; +: >be ( x n -- byte-array ) >le dup reverse-here ; : d>w/w ( d -- w1 w2 ) dup HEX: ffffffff bitand diff --git a/core/kernel/kernel-docs.factor b/core/kernel/kernel-docs.factor index 96c582a3e5..c39010f228 100755 --- a/core/kernel/kernel-docs.factor +++ b/core/kernel/kernel-docs.factor @@ -193,10 +193,7 @@ ARTICLE: "implementing-combinators" "Implementing combinators" ": keep ( x quot -- x )" " over >r call r> ; inline" } -"Word inlining is documented in " { $link "declarations" } "." -$nl -"A looping combinator:" -{ $subsection while } ; +"Word inlining is documented in " { $link "declarations" } "." ; ARTICLE: "booleans" "Booleans" "In Factor, any object that is not " { $link f } " has a true value, and " { $link f } " has a false value. The " { $link t } " object is the canonical true value." 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/bunny/model/model.factor b/extra/bunny/model/model.factor index 2dac9eb688..8fef44a76a 100755 --- a/extra/bunny/model/model.factor +++ b/extra/bunny/model/model.factor @@ -35,10 +35,8 @@ IN: bunny.model [ normalize ] map ; : read-model ( stream -- model ) - "Reading model" print flush [ - ascii [ parse-model ] with-file-reader - [ normals ] 2keep 3array - ] time ; + ascii [ parse-model ] with-file-reader + [ normals ] 2keep 3array ; : model-path "bun_zipper.ply" temp-file ; diff --git a/extra/cairo/gadgets/gadgets.factor b/extra/cairo/gadgets/gadgets.factor index bda18d04b4..f5f4d3e965 100644 --- a/extra/cairo/gadgets/gadgets.factor +++ b/extra/cairo/gadgets/gadgets.factor @@ -1,100 +1,39 @@ ! Copyright (C) 2008 Matthew Willis. ! See http://factorcode.org/license.txt for BSD license. -USING: cairo cairo.ffi ui.render kernel opengl.gl opengl -math byte-arrays ui.gadgets accessors arrays -namespaces io.backend memoize colors ; +USING: sequences math opengl.gadgets kernel +byte-arrays cairo.ffi cairo io.backend +opengl.gl arrays ; IN: cairo.gadgets -! We need two kinds of gadgets: -! one performs the cairo ops once and caches the bytes, the other -! performs cairo ops every refresh - -TUPLE: cairo-gadget width height quot cache? texture ; -PREDICATE: cached-cairo < cairo-gadget cache?>> ; -: ( width height quot -- cairo-gadget ) - cairo-gadget construct-gadget - swap >>quot - swap >>height - swap >>width ; - -: ( width height quot -- cairo-gadget ) - t >>cache? ; - : width>stride ( width -- stride ) 4 * ; -: copy-cairo ( width height quot -- byte-array ) - >r over width>stride +: copy-cairo ( dim quot -- byte-array ) + >r first2 over width>stride [ * nip dup CAIRO_FORMAT_ARGB32 ] [ cairo_image_surface_create_for_data ] 3bi r> with-cairo-from-surface ; -: cairo>bytes ( gadget -- byte-array ) - [ width>> ] [ height>> ] [ quot>> ] tri copy-cairo ; +: ( dim quot -- ) + over 2^-bounds swap copy-cairo + GL_BGRA rot ; -: cairo>png ( gadget path -- ) - >r [ cairo>bytes CAIRO_FORMAT_ARGB32 ] [ width>> ] - [ height>> ] tri over width>stride - cairo_image_surface_create_for_data - r> [ cairo_surface_write_to_png check-cairo ] curry with-surface ; - -: with-cairo-gl ( quot -- ) - >r origin get [ - 0 0 glRasterPos2i - 1.0 -1.0 glPixelZoom - ] r> compose with-translation ; - -M: cairo-gadget draw-gadget* ( gadget -- ) - [ - [ width>> ] [ height>> GL_BGRA GL_UNSIGNED_BYTE ] - [ cairo>bytes ] tri glDrawPixels - ] with-cairo-gl ; - -MEMO: render-to-texture ( gadget -- ) - GL_TEXTURE_BIT [ - GL_TEXTURE_2D over texture>> glBindTexture - >r GL_TEXTURE_2D 0 GL_RGBA r> - [ width>> ] [ height>> 0 GL_BGRA GL_UNSIGNED_BYTE ] - [ cairo>bytes ] tri glTexImage2D - init-texture - GL_TEXTURE_2D 0 glBindTexture - ] do-attribs ; - -M: cached-cairo draw-gadget* ( gadget -- ) - GL_TEXTURE_2D [ - [ - dup render-to-texture - white gl-color - GL_TEXTURE_2D over texture>> glBindTexture - GL_QUADS [ - [ width>> ] [ height>> ] bi 2array four-sides - ] do-state - GL_TEXTURE_2D 0 glBindTexture - ] with-cairo-gl - ] do-enabled ; - -M: cached-cairo graft* ( gadget -- ) - gen-texture >>texture drop ; - -M: cached-cairo ungraft* ( gadget -- ) - [ texture>> delete-texture ] - [ \ render-to-texture invalidate-memoized ] bi ; - -M: cairo-gadget pref-dim* ( gadget -- rect ) - [ width>> ] [ height>> ] bi 2array ; +! maybe also texture>png +! : cairo>png ( gadget path -- ) +! >r [ cairo>bytes CAIRO_FORMAT_ARGB32 ] [ width>> ] +! [ height>> ] tri over width>stride +! cairo_image_surface_create_for_data +! r> [ cairo_surface_write_to_png check-cairo ] curry with-surface ; : copy-surface ( surface -- ) cr swap 0 0 cairo_set_source_surface cr cairo_paint ; -: ( width height bytes -- cairo-gadget ) - >r [ ] r> >>texture ; - : ( path -- gadget ) normalize-path cairo_image_surface_create_from_png [ cairo_image_surface_get_width ] - [ cairo_image_surface_get_height 2dup ] + [ cairo_image_surface_get_height 2array dup 2^-bounds ] [ [ copy-surface ] curry copy-cairo ] tri - ; + GL_BGRA rot ; diff --git a/extra/cairo/samples/samples.factor b/extra/cairo/samples/samples.factor index 3cc63922f8..0e83381349 100644 --- a/extra/cairo/samples/samples.factor +++ b/extra/cairo/samples/samples.factor @@ -142,6 +142,6 @@ IN: cairo.samples USING: quotations cairo.gadgets ui.gadgets.panes sequences ; : samples ( -- ) { arc clip clip-image dash gradient text utf8 } - [ 256 256 rot 1quotation gadget. ] each ; + [ { 256 256 } swap 1quotation gadget. ] each ; - MAIN: samples \ No newline at end of file + MAIN: samples 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..3976b36cb9 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 -- ? ) + [ [ 3dup ] prepend [ t ] ] f short-circuit [ 3nip ] append ; + ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! ifte ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! diff --git a/extra/db/db.factor b/extra/db/db.factor index 9514f62cf0..8d1feca6c7 100755 --- a/extra/db/db.factor +++ b/extra/db/db.factor @@ -39,31 +39,13 @@ TUPLE: statement handle sql in-params out-params bind-params bound? type ; TUPLE: simple-statement < statement ; TUPLE: prepared-statement < statement ; -SINGLETON: throwable -SINGLETON: nonthrowable - -: make-throwable ( obj -- obj' ) - dup sequence? [ - [ make-throwable ] map - ] [ - throwable >>type - ] if ; - -: make-nonthrowable ( obj -- obj' ) - dup sequence? [ - [ make-nonthrowable ] map - ] [ - nonthrowable >>type - ] if ; - TUPLE: result-set sql in-params out-params handle n max ; : construct-statement ( sql in out class -- statement ) new swap >>out-params swap >>in-params - swap >>sql - throwable >>type ; + swap >>sql ; HOOK: db ( str in out -- statement ) HOOK: db ( str in out -- statement ) @@ -81,12 +63,9 @@ GENERIC: more-rows? ( result-set -- ? ) GENERIC: execute-statement* ( statement type -- ) -M: throwable execute-statement* ( statement type -- ) +M: object execute-statement* ( statement type -- ) drop query-results dispose ; -M: nonthrowable execute-statement* ( statement type -- ) - drop [ query-results dispose ] [ 2drop ] recover ; - : execute-statement ( statement -- ) dup sequence? [ [ execute-statement ] each @@ -127,7 +106,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/errors/errors.factor b/extra/db/errors/errors.factor new file mode 100644 index 0000000000..1e0d1e7fb4 --- /dev/null +++ b/extra/db/errors/errors.factor @@ -0,0 +1,11 @@ +! Copyright (C) 2008 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: kernel ; +IN: db.errors + +ERROR: db-error ; +ERROR: sql-error ; + + +ERROR: table-exists ; +ERROR: bad-schema ; 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/postgresql/postgresql.factor b/extra/db/postgresql/postgresql.factor index 3e81b264d6..f55897db88 100755 --- a/extra/db/postgresql/postgresql.factor +++ b/extra/db/postgresql/postgresql.factor @@ -175,7 +175,7 @@ M: postgresql-db create-sql-statement ( class -- seq ) : drop-table-sql ( table -- statement ) [ - "drop table " 0% 0% ";" 0% drop + "drop table " 0% 0% drop ] query-make ; M: postgresql-db drop-sql-statement ( class -- seq ) diff --git a/extra/db/queries/queries.factor b/extra/db/queries/queries.factor index 6dab4f80b8..59ee60aa1f 100644 --- a/extra/db/queries/queries.factor +++ b/extra/db/queries/queries.factor @@ -1,21 +1,19 @@ ! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. USING: accessors kernel math namespaces sequences random -strings -math.bitfields.lib namespaces.lib db db.tuples db.types -math.intervals ; +strings math.parser math.intervals combinators +math.bitfields.lib namespaces.lib db db.tuples db.types ; IN: db.queries GENERIC: where ( specs obj -- ) : maybe-make-retryable ( statement -- statement ) - dup in-params>> [ generator-bind? ] contains? [ - make-retryable - ] when ; + dup in-params>> [ generator-bind? ] contains? + [ make-retryable ] when ; : query-make ( class quot -- ) >r sql-props r> - [ 0 sql-counter rot with-variable ";" 0% ] { "" { } { } } nmake + [ 0 sql-counter rot with-variable ] { "" { } { } } nmake maybe-make-retryable ; inline M: db begin-transaction ( -- ) "BEGIN" sql-command ; @@ -127,3 +125,36 @@ M: db ( tuple class -- statement ) " from " 0% 0% where-clause ] query-make ; + +: do-group ( tuple groups -- ) + [ + ", " join " group by " prepend append + ] curry change-sql drop ; + +: do-order ( tuple order -- ) + [ + ", " join " order by " prepend append + ] curry change-sql drop ; + +: do-offset ( tuple n -- ) + [ + number>string " offset " prepend append + ] curry change-sql drop ; + +: do-limit ( tuple n -- ) + [ + number>string " limit " prepend append + ] curry change-sql drop ; + +: make-advanced-statement ( tuple advanced -- tuple' ) + dupd + { + [ group>> [ do-group ] [ drop ] if* ] + [ order>> [ do-order ] [ drop ] if* ] + [ limit>> [ do-limit ] [ drop ] if* ] + [ offset>> [ do-offset ] [ drop ] if* ] + } 2cleave ; + +M: db ( tuple class group order limit offset -- tuple ) + advanced-statement boa + [ ] dip make-advanced-statement ; diff --git a/extra/db/sql/sql-tests.factor b/extra/db/sql/sql-tests.factor index cab7b83ced..0b57c2d8fa 100644 --- a/extra/db/sql/sql-tests.factor +++ b/extra/db/sql/sql-tests.factor @@ -4,9 +4,11 @@ IN: db.sql.tests ! TUPLE: person name age ; : insert-1 { insert - { table "person" } - { columns "name" "age" } - { values "erg" 26 } + { + { table "person" } + { columns "name" "age" } + { values "erg" 26 } + } } ; : update-1 diff --git a/extra/db/sqlite/lib/lib.factor b/extra/db/sqlite/lib/lib.factor index e92c4bbd8a..b652e8fed7 100755 --- a/extra/db/sqlite/lib/lib.factor +++ b/extra/db/sqlite/lib/lib.factor @@ -4,24 +4,25 @@ USING: alien.c-types arrays assocs kernel math math.parser namespaces sequences db.sqlite.ffi db combinators continuations db.types calendar.format serialize io.streams.byte-array byte-arrays io.encodings.binary -io.backend ; +io.backend db.errors ; IN: db.sqlite.lib -: sqlite-error ( n -- * ) - sqlite-error-messages nth throw ; +ERROR: sqlite-error < db-error n string ; +ERROR: sqlite-sql-error < sql-error n string ; -: sqlite-statement-error-string ( -- str ) - db get db-handle sqlite3_errmsg ; +: throw-sqlite-error ( n -- * ) + dup sqlite-error-messages nth sqlite-error ; : sqlite-statement-error ( -- * ) - sqlite-statement-error-string throw ; + SQLITE_ERROR + db get db-handle sqlite3_errmsg sqlite-sql-error ; : sqlite-check-result ( n -- ) { - { [ dup SQLITE_OK = ] [ drop ] } - { [ dup SQLITE_ERROR = ] [ sqlite-statement-error ] } - [ sqlite-error ] - } cond ; + { SQLITE_OK [ ] } + { SQLITE_ERROR [ sqlite-statement-error ] } + [ throw-sqlite-error ] + } case ; : sqlite-open ( path -- db ) normalize-path @@ -158,12 +159,11 @@ IN: db.sqlite.lib dup sqlite-#columns [ sqlite-column ] with map ; : sqlite-step-has-more-rows? ( prepared -- bool ) - dup SQLITE_ROW = [ - drop t - ] [ - dup SQLITE_DONE = - [ drop ] [ sqlite-check-result ] if f - ] if ; + { + { SQLITE_ROW [ t ] } + { SQLITE_DONE [ f ] } + [ sqlite-check-result f ] + } case ; : sqlite-next ( prepared -- ? ) sqlite3_step sqlite-step-has-more-rows? ; diff --git a/extra/db/sqlite/sqlite.factor b/extra/db/sqlite/sqlite.factor index c10775f1c9..cc4e4d116a 100755 --- a/extra/db/sqlite/sqlite.factor +++ b/extra/db/sqlite/sqlite.factor @@ -16,7 +16,7 @@ M: sqlite-db make-db* ( path db -- db ) swap >>path ; M: sqlite-db db-open ( db -- db ) - [ path>> sqlite-open ] [ swap >>handle ] bi ; + dup path>> sqlite-open >>handle ; M: sqlite-db db-close ( handle -- ) sqlite-close ; M: sqlite-db dispose ( db -- ) dispose-db ; @@ -197,4 +197,3 @@ M: sqlite-db compound ( str seq -- str' ) { "default" [ first number>string join-space ] } [ 2drop ] } case ; - diff --git a/extra/db/tuples/tuples-tests.factor b/extra/db/tuples/tuples-tests.factor index 4da82d92d6..f9a597e814 100755 --- a/extra/db/tuples/tuples-tests.factor +++ b/extra/db/tuples/tuples-tests.factor @@ -3,7 +3,8 @@ USING: io.files kernel tools.test db db.tuples classes db.types continuations namespaces math math.ranges prettyprint calendar sequences db.sqlite math.intervals -db.postgresql accessors random math.bitfields.lib ; +db.postgresql accessors random math.bitfields.lib +math.ranges strings sequences.lib ; IN: db.tuples.tests TUPLE: person the-id the-name the-number the-real @@ -198,8 +199,8 @@ TUPLE: annotation n paste-id summary author mode contents ; : test-sqlite ( quot -- ) >r "tuples-test.db" temp-file sqlite-db r> with-db ; -: test-postgresql ( -- ) ->r { "localhost" "postgres" "foob" "factor-test" } postgresql-db r> with-db ; +: test-postgresql ( quot -- ) + >r { "localhost" "postgres" "foob" "factor-test" } postgresql-db r> with-db ; : test-repeated-insert [ ] [ person ensure-table ] unit-test @@ -224,6 +225,12 @@ TUPLE: serialize-me id data ; TUPLE: exam id name score ; +: random-exam ( -- exam ) + f + 6 [ CHAR: a CHAR: b [a,b] random ] replicate >string + 100 random + exam boa ; + : test-intervals ( -- ) exam "EXAM" { @@ -414,6 +421,43 @@ TUPLE: does-not-persist ; [ class \ not-persistent = ] must-fail-with ] test-postgresql + +TUPLE: suparclass id a ; + +suparclass f { + { "id" "ID" +db-assigned-id+ } + { "a" "A" INTEGER } +} define-persistent + +TUPLE: subbclass < suparclass b ; + +subbclass "SUBCLASS" { + { "b" "B" TEXT } +} define-persistent + +TUPLE: fubbclass < subbclass ; + +fubbclass "FUBCLASS" { } define-persistent + +: test-db-inheritance ( -- ) + [ ] [ subbclass ensure-table ] unit-test + [ ] [ fubbclass ensure-table ] unit-test + + [ ] [ + subbclass new 5 >>a "hi" >>b dup insert-tuple id>> "id" set + ] unit-test + + [ t "hi" 5 ] [ + subbclass new "id" get >>id select-tuple + [ subbclass? ] [ b>> ] [ a>> ] tri + ] unit-test + + [ ] [ fubbclass new 0 >>a "hi" >>b insert-tuple ] unit-test + + [ t ] [ fubbclass new select-tuples [ fubbclass? ] all? ] 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..bac141d6d2 100755 --- a/extra/db/tuples/tuples.factor +++ b/extra/db/tuples/tuples.factor @@ -13,13 +13,13 @@ IN: db.tuples "db-columns" set-word-prop "db-relations" set-word-prop ; -ERROR: not-persistent ; +ERROR: not-persistent class ; : db-table ( class -- obj ) - "db-table" word-prop [ not-persistent ] unless* ; + dup "db-table" word-prop [ ] [ not-persistent ] ?if ; : db-columns ( class -- obj ) - "db-columns" word-prop ; + superclasses [ "db-columns" word-prop ] map concat ; : db-relations ( class -- obj ) "db-relations" word-prop ; @@ -42,6 +42,8 @@ HOOK: db ( class -- obj ) HOOK: db ( class -- obj ) HOOK: db ( tuple class -- obj ) HOOK: db ( tuple class -- tuple ) +TUPLE: advanced-statement group order offset limit ; +HOOK: db ( tuple class group order offset limit -- tuple ) HOOK: insert-tuple* db ( tuple statement -- ) @@ -74,16 +76,16 @@ M: retryable execute-statement* ( statement type -- ) [ regenerate-params bind-statement* f ] cleanup ] curry 10 retry drop ; -: resulting-tuple ( row out-params -- tuple ) - dup first class>> new [ +: resulting-tuple ( class row out-params -- tuple ) + rot class new [ [ >r slot-name>> r> set-slot-named ] curry 2each ] keep ; -: query-tuples ( statement -- seq ) +: query-tuples ( exemplar-tuple statement -- seq ) [ out-params>> ] keep query-results [ - [ sql-row-typed swap resulting-tuple ] with query-map + [ sql-row-typed swap resulting-tuple ] with with query-map ] with-disposal ; : query-modify-tuple ( tuple statement -- ) @@ -110,8 +112,8 @@ M: retryable execute-statement* ( statement type -- ) : recreate-table ( class -- ) [ - drop-sql-statement make-nonthrowable - [ execute-statement ] with-disposals + [ drop-sql-statement [ execute-statement ] with-disposals + ] curry ignore-errors ] [ create-table ] bi ; : ensure-table ( class -- ) @@ -141,9 +143,12 @@ M: retryable execute-statement* ( statement type -- ) [ bind-tuple ] keep execute-statement ] with-disposal ; -: select-tuples ( tuple -- tuples ) - dup dup class [ - [ bind-tuple ] keep query-tuples - ] with-disposal ; +: do-select ( exemplar-tuple statement -- tuples ) + [ [ bind-tuple ] [ query-tuples ] 2bi ] with-disposal ; -: select-tuple ( tuple -- tuple/f ) select-tuples ?first ; +: select-tuples ( tuple -- tuples ) + dup dup class do-select ; + +: select-tuple ( tuple -- tuple/f ) + dup dup class f f f 1 + do-select ?first ; diff --git a/extra/db/types/types.factor b/extra/db/types/types.factor index 8dbf6786bc..03e6b15bdb 100755 --- a/extra/db/types/types.factor +++ b/extra/db/types/types.factor @@ -142,7 +142,8 @@ HOOK: bind% db ( spec -- ) HOOK: bind# db ( spec obj -- ) : offset-of-slot ( str obj -- n ) - class "slots" word-prop slot-named slot-spec-offset ; + class superclasses [ "slots" word-prop ] map concat + slot-named slot-spec-offset ; : get-slot-named ( name obj -- value ) tuck offset-of-slot slot ; diff --git a/extra/dns/cache/cache.factor b/extra/dns/cache/cache.factor index 75bbf9de9d..5c4539b913 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,11 @@ SYMBOL: NX ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +: 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 +115,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..6386655a4e 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,22 @@ 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 ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +ERROR: name-error name ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: fully-qualified ( name -- name ) + { + { [ dup empty? ] [ "." append ] } + { [ dup peek CHAR: . = ] [ ] } + { [ t ] [ "." append ] } + } + cond ; diff --git a/extra/dns/forwarding/forwarding.factor b/extra/dns/forwarding/forwarding.factor new file mode 100644 index 0000000000..1c60532bbc --- /dev/null +++ b/extra/dns/forwarding/forwarding.factor @@ -0,0 +1,109 @@ + +USING: kernel + combinators + vectors + sequences + io.sockets + accessors + combinators.lib + newfx + dns dns.cache dns.misc ; + +IN: dns.forwarding + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! DNS server - caching, forwarding +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: (socket) ( -- vec ) V{ f } ; + +: socket ( -- socket ) (socket) 1st ; + +: init-socket-on-port ( port -- ) + f swap 0 (socket) as-mutate ; + +: init-socket ( -- ) 53 init-socket-on-port ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: (upstream-server) ( -- vec ) V{ f } ; + +: upstream-server ( -- ip ) (upstream-server) 1st ; + +: set-upstream-server ( ip -- ) 0 (upstream-server) as-mutate ; + +: init-upstream-server ( -- ) + upstream-server not + [ resolv-conf-server set-upstream-server ] + when ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: 1&& <-&& ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: rrs? ( obj -- ? ) { [ NX = not ] [ f = not ] } 1&& ; + +: query->answer/cache ( query -- rrs/NX/f ) + dup cache-get* dup { [ rrs? ] [ NX = ] } 1|| + [ nip ] + [ + drop + dup clone CNAME >>type cache-get* dup { [ NX = ] [ f = ] } 1|| + [ nip ] + [ ! query rrs + tuck ! rrs query rrs + 1st ! rrs query rr/cname + rdata>> ! rrs query name + >r clone r> >>name ! rrs query + query->answer/cache ! rrs rrs/NX/f + dup rrs? [ append ] [ nip ] if + ] + if + ] + if ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: answer-from-cache ( message -- message/f ) + dup message-query ! message query + dup query->answer/cache ! message query rrs/NX/f + { + { [ dup f = ] [ 3drop f ] } + { [ dup NX = ] [ 2drop NAME-ERROR >>rcode ] } + { [ t ] [ nip >>answer-section ] } + } + cond ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: answer-from-server ( message -- message ) + upstream-server ask-server + cache-message ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: find-answer ( message -- message ) + dup answer-from-cache dup + [ nip ] + [ drop answer-from-server ] + if ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: loop ( -- ) + socket receive ! byte-array addr-spec + swap ! addr-spec byte-array + parse-message ! addr-spec message + find-answer ! addr-spec message + message->ba ! addr-spec byte-array + swap ! byte-array addr-spec + socket send + loop ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: start ( -- ) init-socket init-upstream-server loop ; + +MAIN: start \ No newline at end of file diff --git a/extra/dns/misc/misc.factor b/extra/dns/misc/misc.factor new file mode 100644 index 0000000000..90731cec43 --- /dev/null +++ b/extra/dns/misc/misc.factor @@ -0,0 +1,12 @@ + +USING: kernel sequences splitting io.files io.encodings.utf8 random newfx ; + +IN: dns.misc + +: resolv-conf-servers ( -- seq ) + "/etc/resolv.conf" utf8 file-lines + [ " " split ] map + [ 1st "nameserver" = ] filter + [ 2nd ] map ; + +: resolv-conf-server ( -- ip ) resolv-conf-servers random ; \ No newline at end of file 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..2dae43b5d4 100644 --- a/extra/dns/resolver/resolver.factor +++ b/extra/dns/resolver/resolver.factor @@ -6,34 +6,6 @@ IN: dns.resolver ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! Need to cache records even in the case of name error - -: cache-message ( message -- message ) - dup dup rcode>> NAME-ERROR = - [ - [ question-section>> 1st ] - [ authority-section>> [ type>> SOA = ] filter random ttl>> ] - bi - cache-nx - ] - [ - { - [ answer-section>> cache-add-rrs ] - [ authority-section>> cache-add-rrs ] - [ additional-section>> cache-add-rrs ] - } - cleave - ] - if ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -! Ask and cache the records - -: ask* ( message -- message ) ask cache-message ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - : canonical/cache ( name -- name ) dup CNAME IN query boa cache-get dup vector? ! name result ? [ nip 1st rdata>> ] @@ -43,26 +15,17 @@ IN: dns.resolver : name->ip/cache ( name -- ip ) canonical/cache dup A IN query boa cache-get ! name result - { { - [ dup NX = ] - [ 2drop f ] + { [ dup NX = ] [ 2drop f ] } + { [ dup f = ] [ 2drop f ] } + { [ t ] [ nip random rdata>> ] } } - { - [ dup f = ] - [ 2drop f ] - } - { - [ t ] - [ nip random rdata>> ] - } - } - cond ; + cond ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! : canonical/server ( name -- name ) - dup CNAME IN query boa ask* answer-section>> + dup CNAME IN query boa query->message ask cache-message answer-section>> [ type>> CNAME = ] filter dup empty? not [ nip 1st rdata>> ] [ drop ] @@ -70,7 +33,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 cache-message answer-section>> [ type>> A = ] filter dup empty? not [ nip random rdata>> ] [ 2drop f ] @@ -78,16 +41,6 @@ IN: dns.resolver ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -: fully-qualified ( name -- name ) - { - { [ dup empty? ] [ "." append ] } - { [ dup peek CHAR: . = ] [ ] } - { [ t ] [ "." append ] } - } - cond ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - : name->ip ( name -- ip ) fully-qualified dup name->ip/cache dup diff --git a/extra/dns/stub/stub.factor b/extra/dns/stub/stub.factor new file mode 100644 index 0000000000..a15feb5759 --- /dev/null +++ b/extra/dns/stub/stub.factor @@ -0,0 +1,20 @@ + +USING: kernel sequences random accessors dns ; + +IN: dns.stub + +! Stub resolver +! +! Generally useful, but particularly when running a forwarding, +! caching, nameserver on localhost with multiple Factor instances +! querying it. + +: name->ip ( name -- ip ) + A IN query boa + query->message + ask + dup rcode>> NAME-ERROR = + [ message-query name>> name-error ] + [ answer-section>> [ type>> A = ] filter random rdata>> ] + if ; + 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/io/windows/nt/backend/backend.factor b/extra/io/windows/nt/backend/backend.factor index 993aff5200..1a7462f304 100755 --- a/extra/io/windows/nt/backend/backend.factor +++ b/extra/io/windows/nt/backend/backend.factor @@ -64,9 +64,11 @@ M: winnt add-completion ( win32-handle -- ) : handle-overlapped ( timeout -- ? ) wait-for-overlapped [ - >r drop GetLastError - [ 1array ] [ expected-io-error? ] bi - [ r> 2drop f ] [ r> resume-callback t ] if + dup [ + >r drop GetLastError 1array r> resume-callback t + ] [ + 2drop f + ] if ] [ resume-callback t ] if ; 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/json/reader/reader-tests.factor b/extra/json/reader/reader-tests.factor new file mode 100644 index 0000000000..4b7bd56f01 --- /dev/null +++ b/extra/json/reader/reader-tests.factor @@ -0,0 +1,43 @@ +USING: arrays json.reader kernel multiline strings tools.test ; +IN: json.reader.tests + +{ f } [ "false" json> ] unit-test +{ t } [ "true" json> ] unit-test +{ json-null } [ "null" json> ] unit-test +{ 0 } [ "0" json> ] unit-test +{ 102 } [ "102" json> ] unit-test +{ -102 } [ "-102" json> ] unit-test +{ 102 } [ "+102" json> ] unit-test +{ 102.0 } [ "102.0" json> ] unit-test +{ 102.5 } [ "102.5" json> ] unit-test +{ 102.5 } [ "102.50" json> ] unit-test +{ -10250 } [ "-102.5e2" json> ] unit-test +{ -10250 } [ "-102.5E+2" json> ] unit-test +{ 10.25 } [ "1025e-2" json> ] unit-test +{ 0.125 } [ "0.125" json> ] unit-test +{ -0.125 } [ "-0.125" json> ] unit-test + +{ " fuzzy pickles " } [ <" " fuzzy pickles " "> json> ] unit-test +{ "while 1:\n\tpass" } [ <" "while 1:\n\tpass" "> json> ] unit-test +{ 8 9 10 12 13 34 47 92 } >string 1array [ <" "\b\t\n\f\r\"\/\\" "> json> ] unit-test +{ HEX: abcd } >string 1array [ <" "\uaBCd" "> json> ] unit-test + +{ { 1 "two" 3.0 } } [ <" [1, "two", 3.0] "> json> ] unit-test +{ H{ { "US$" 1.0 } { "EU€" 1.5 } } } [ <" { "US$":1.00, "EU\u20AC":1.50 } "> json> ] unit-test +{ H{ + { "fib" { 1 1 2 3 5 8 H{ { "etc" "etc" } } } } + { "prime" { 2 3 5 7 11 13 } } +} } [ <" { + "fib": [1, 1, 2, 3, 5, 8, + { "etc":"etc" } ], + "prime": + [ 2,3, 5,7, +11, +13 +] } +"> json> ] unit-test + +{ 0 } [ " 0" json> ] unit-test +{ 0 } [ "0 " json> ] unit-test +{ 0 } [ " 0 " json> ] unit-test + diff --git a/extra/json/reader/reader.factor b/extra/json/reader/reader.factor index 17c1b272df..5e6b16dc2f 100755 --- a/extra/json/reader/reader.factor +++ b/extra/json/reader/reader.factor @@ -7,6 +7,8 @@ IN: json.reader ! Grammar for JSON from RFC 4627 +SYMBOL: json-null + : [<&>] ( quot -- quot ) { } make unclip [ <&> ] reduce ; @@ -17,8 +19,7 @@ LAZY: 'ws' ( -- parser ) " " token "\n" token <|> "\r" token <|> - "\t" token <|> - "" token <|> ; + "\t" token <|> <*> ; LAZY: spaced ( parser -- parser ) 'ws' swap &> 'ws' <& ; @@ -42,24 +43,39 @@ LAZY: 'value-separator' ( -- parser ) "," token spaced ; LAZY: 'false' ( -- parser ) - "false" token ; + "false" token [ drop f ] <@ ; LAZY: 'null' ( -- parser ) - "null" token ; + "null" token [ drop json-null ] <@ ; LAZY: 'true' ( -- parser ) - "true" token ; + "true" token [ drop t ] <@ ; LAZY: 'quot' ( -- parser ) "\"" token ; +LAZY: 'hex-digit' ( -- parser ) + [ digit> ] satisfy [ digit> ] <@ ; + +: hex-digits>ch ( digits -- ch ) + 0 [ swap 16 * + ] reduce ; + +LAZY: 'string-char' ( -- parser ) + [ quotable? ] satisfy + "\\b" token [ drop 8 ] <@ <|> + "\\t" token [ drop CHAR: \t ] <@ <|> + "\\n" token [ drop CHAR: \n ] <@ <|> + "\\f" token [ drop 12 ] <@ <|> + "\\r" token [ drop CHAR: \r ] <@ <|> + "\\\"" token [ drop CHAR: " ] <@ <|> + "\\/" token [ drop CHAR: / ] <@ <|> + "\\\\" token [ drop CHAR: \\ ] <@ <|> + "\\u" token 'hex-digit' 4 exactly-n &> + [ hex-digits>ch ] <@ <|> ; + LAZY: 'string' ( -- parser ) 'quot' - [ - [ quotable? ] keep - [ CHAR: \\ = or ] keep - CHAR: " = not and - ] satisfy <*> &> + 'string-char' <*> &> 'quot' <& [ >string ] <@ ; DEFER: 'value' @@ -86,6 +102,9 @@ LAZY: 'minus' ( -- parser ) LAZY: 'plus' ( -- parser ) "+" token ; +LAZY: 'sign' ( -- parser ) + 'minus' 'plus' <|> ; + LAZY: 'zero' ( -- parser ) "0" token [ drop 0 ] <@ ; @@ -116,11 +135,11 @@ LAZY: 'e' ( -- parser ) : sign-number ( pair -- number ) #! Pair is { minus? num } #! Convert the json number value to a factor number - dup second swap first [ -1 * ] when ; + dup second swap first [ first "-" = [ -1 * ] when ] when* ; LAZY: 'exp' ( -- parser ) 'e' - 'minus' 'plus' <|> &> + 'sign' &> 'digit0-9' <+> [ decimal>integer ] <@ <&> [ sign-number ] <@ ; : sequence>frac ( seq -- num ) @@ -136,7 +155,7 @@ LAZY: 'frac' ( -- parser ) dup second dup [ 10 swap first ^ swap first * ] [ drop first ] if ; LAZY: 'number' ( -- parser ) - 'minus' + 'sign' [ 'int' , 'frac' 0 succeed <|> , ] [<&>] [ sum ] <@ 'exp' <&> [ raise-to-power ] <@ <&> [ sign-number ] <@ ; @@ -149,7 +168,7 @@ LAZY: 'value' ( -- parser ) 'object' , 'array' , 'number' , - ] [<|>] ; + ] [<|>] spaced ; : json> ( string -- object ) #! Parse a json formatted string to a factor object 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/logging/logging-tests.factor b/extra/logging/logging-tests.factor new file mode 100644 index 0000000000..796c8769fc --- /dev/null +++ b/extra/logging/logging-tests.factor @@ -0,0 +1,24 @@ +IN: logging.tests +USING: tools.test logging math ; + +: input-logging-test ( a b -- c ) + ; + +\ input-logging-test NOTICE add-input-logging + +: output-logging-test ( a b -- c ) + ; + +\ output-logging-test DEBUG add-output-logging + +: error-logging-test ( a b -- c ) / ; + +\ error-logging-test ERROR add-error-logging + +"logging-test" [ + [ 4 ] [ 1 3 input-logging-test ] unit-test + + [ 4 ] [ 1 3 output-logging-test ] unit-test + + [ 4/3 ] [ 4 3 error-logging-test ] unit-test + + [ f ] [ 1 0 error-logging-test ] unit-test +] with-logging diff --git a/extra/logging/logging.factor b/extra/logging/logging.factor index f54ab05bbd..df03bf320b 100755 --- a/extra/logging/logging.factor +++ b/extra/logging/logging.factor @@ -4,33 +4,26 @@ USING: logging.server sequences namespaces concurrency.messaging words kernel arrays shuffle tools.annotations prettyprint.config prettyprint debugger io.streams.string splitting continuations effects arrays.lib parser strings -combinators.lib quotations ; +combinators.lib quotations fry symbols accessors ; IN: logging -SYMBOL: DEBUG -SYMBOL: NOTICE -SYMBOL: WARNING -SYMBOL: ERROR -SYMBOL: CRITICAL +SYMBOLS: DEBUG NOTICE WARNING ERROR CRITICAL ; -: log-levels - { DEBUG NOTICE NOTICE WARNING ERROR CRITICAL } ; +: log-levels { DEBUG NOTICE NOTICE WARNING ERROR CRITICAL } ; : send-to-log-server ( array string -- ) prefix "log-server" get send ; SYMBOL: log-service -: check-log-message - pick string? - pick word? - pick word? and and - [ "Bad parameters to log-message" throw ] unless ; +: check-log-message ( msg word level -- msg word level ) + 3dup [ string? ] [ word? ] [ word? ] tri* and and + [ "Bad parameters to log-message" throw ] unless ; inline : log-message ( msg word level -- ) check-log-message log-service get dup [ - >r >r >r string-lines r> word-name r> word-name r> + [ [ string-lines ] [ word-name ] [ word-name ] tri* ] dip 4array "log-message" send-to-log-server ] [ 4drop @@ -69,7 +62,7 @@ SYMBOL: log-service PRIVATE> : (define-logging) ( word level quot -- ) - >r >r dup r> r> 2curry annotate ; + [ dup ] 2dip 2curry annotate ; : call-logging-quot ( quot word level -- quot' ) "called" -rot [ log-message ] 3curry prepose ; @@ -79,31 +72,30 @@ PRIVATE> : log-stack ( n word level -- ) log-service get [ - >r >r [ ndup ] keep narray stack>message - r> r> log-message + [ [ ndup ] keep narray stack>message ] 2dip log-message ] [ 3drop ] if ; inline -: input# stack-effect effect-in length ; +: input# stack-effect in>> length ; : input-logging-quot ( quot word level -- quot' ) - over input# -rot [ log-stack ] 3curry prepose ; + rot [ [ input# ] keep ] 2dip '[ , , , log-stack @ ] ; : add-input-logging ( word level -- ) [ input-logging-quot ] (define-logging) ; -: output# stack-effect effect-out length ; +: output# stack-effect out>> length ; : output-logging-quot ( quot word level -- quot' ) - over output# -rot [ log-stack ] 3curry compose ; + [ [ output# ] keep ] dip '[ @ , , , log-stack ] ; : add-output-logging ( word level -- ) [ output-logging-quot ] (define-logging) ; : (log-error) ( object word level -- ) log-service get [ - >r >r [ print-error ] with-string-writer r> r> log-message + [ [ print-error ] with-string-writer ] 2dip log-message ] [ 2drop rethrow ] if ; @@ -112,22 +104,21 @@ PRIVATE> : log-critical ( error word -- ) CRITICAL (log-error) ; -: stack-balancer ( effect word -- quot ) - >r dup effect-in length r> [ over >r ERROR log-stack r> ndrop ] 2curry - swap effect-out length f append >quotation ; +: stack-balancer ( effect -- quot ) + [ in>> length [ ndrop ] curry ] + [ out>> length f >quotation ] + bi append ; : error-logging-quot ( quot word -- quot' ) - [ [ log-error ] curry ] keep - [ stack-effect ] keep stack-balancer compose - [ recover ] 2curry ; + dup stack-effect stack-balancer + '[ , [ , log-error @ ] recover ] ; : add-error-logging ( word level -- ) - [ over >r input-logging-quot r> error-logging-quot ] + [ [ input-logging-quot ] 2keep drop error-logging-quot ] (define-logging) ; : LOG: #! Syntax: name level - CREATE-WORD - dup scan-word - [ >r >r 1array stack>message r> r> log-message ] 2curry + CREATE-WORD dup scan-word + '[ 1array stack>message , , log-message ] define ; parsing 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 6a223fdc7e..1c0491a7ab 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/namespaces/lib/lib.factor b/extra/namespaces/lib/lib.factor index 47b6b33a9a..851f60d126 100755 --- a/extra/namespaces/lib/lib.factor +++ b/extra/namespaces/lib/lib.factor @@ -2,7 +2,7 @@ ! USING: kernel quotations namespaces sequences assocs.lib ; USING: kernel namespaces namespaces.private quotations sequences - assocs.lib math.parser math sequences.lib locals ; + assocs.lib math.parser math sequences.lib locals mirrors ; IN: namespaces.lib @@ -58,3 +58,9 @@ MACRO:: nmake ( quot exemplars -- ) ] with-scope ] ] ; + +: make-object ( quot class -- object ) + new [ swap bind ] keep ; inline + +: with-object ( object quot -- ) + [ ] dip bind ; inline 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/gadgets/gadgets.factor b/extra/opengl/gadgets/gadgets.factor new file mode 100644 index 0000000000..1a15283048 --- /dev/null +++ b/extra/opengl/gadgets/gadgets.factor @@ -0,0 +1,72 @@ +! Copyright (C) 2008 Matthew Willis. +! See http://factorcode.org/license.txt for BSD license. +USING: locals math.functions math namespaces +opengl.gl accessors kernel opengl ui.gadgets +destructors sequences ui.render colors ; +IN: opengl.gadgets + +TUPLE: texture-gadget bytes format dim tex ; + +: 2^-ceil ( x -- y ) + dup 2 < [ 2 * ] [ 1- log2 1+ 2^ ] if ; foldable flushable + +: 2^-bounds ( dim -- dim' ) + [ 2^-ceil ] map ; foldable flushable + +: ( bytes format dim -- gadget ) + texture-gadget construct-gadget + swap >>dim + swap >>format + swap >>bytes ; + +:: render ( gadget -- ) + GL_ENABLE_BIT [ + GL_TEXTURE_2D glEnable + GL_TEXTURE_2D gadget tex>> glBindTexture + GL_TEXTURE_2D + 0 + GL_RGBA + gadget dim>> 2^-bounds first2 + 0 + gadget format>> + GL_UNSIGNED_BYTE + gadget bytes>> + glTexImage2D + init-texture + GL_TEXTURE_2D 0 glBindTexture + ] do-attribs ; + +:: four-corners ( dim -- ) + [let* | w [ dim first ] + h [ dim second ] + dim' [ dim dup 2^-bounds [ /f ] 2map ] + w' [ dim' first ] + h' [ dim' second ] | + 0 0 glTexCoord2d 0 0 glVertex2d + 0 h' glTexCoord2d 0 h glVertex2d + w' h' glTexCoord2d w h glVertex2d + w' 0 glTexCoord2d w 0 glVertex2d + ] ; + +M: texture-gadget draw-gadget* ( gadget -- ) + origin get [ + GL_ENABLE_BIT [ + white gl-color + 1.0 -1.0 glPixelZoom + GL_TEXTURE_2D glEnable + GL_TEXTURE_2D over tex>> glBindTexture + GL_QUADS [ + dim>> four-corners + ] do-state + GL_TEXTURE_2D 0 glBindTexture + ] do-attribs + ] with-translation ; + +M: texture-gadget graft* ( gadget -- ) + gen-texture >>tex [ render ] + [ f >>bytes f >>format drop ] bi ; + +M: texture-gadget ungraft* ( gadget -- ) + tex>> delete-texture ; + +M: texture-gadget pref-dim* ( gadget -- dim ) dim>> ; 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/openssl/openssl.factor b/extra/openssl/openssl.factor index ca5a4e8846..03343820db 100755 --- a/extra/openssl/openssl.factor +++ b/extra/openssl/openssl.factor @@ -38,15 +38,15 @@ M: TLSv1 ssl-method drop TLSv1_method ; OpenSSL_add_all_digests OpenSSL_add_all_ciphers ; -SYMBOL: ssl-initiazed? +SYMBOL: ssl-initialized? : maybe-init-ssl ( -- ) - ssl-initiazed? get-global [ + ssl-initialized? get-global [ init-ssl - t ssl-initiazed? set-global + t ssl-initialized? set-global ] unless ; -[ f ssl-initiazed? set-global ] "openssl" add-init-hook +[ f ssl-initialized? set-global ] "openssl" add-init-hook TUPLE: openssl-context < secure-context aliens ; diff --git a/extra/cairo/pango/pango.factor b/extra/pango/cairo/cairo.factor similarity index 96% rename from extra/cairo/pango/pango.factor rename to extra/pango/cairo/cairo.factor index 3f702769d8..889052c385 100644 --- a/extra/cairo/pango/pango.factor +++ b/extra/pango/cairo/cairo.factor @@ -4,8 +4,8 @@ ! pangocairo bindings, from pango/pangocairo.h USING: cairo.ffi alien.c-types math alien.syntax system combinators alien -pango pango.fonts ; -IN: cairo.pango +arrays pango pango.fonts ; +IN: pango.cairo << "pangocairo" { ! { [ os winnt? ] [ "libpangocairo-1.dll" ] } @@ -115,8 +115,8 @@ M: pango-layout dispose ( alien -- ) alien>> g_object_unref ; >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-size ( quot -- dim ) + [ layout pango-layout-get-pixel-size 2array ] compose dummy-pango ; inline : layout-font ( str -- ) pango_font_description_from_string diff --git a/extra/cairo/pango/gadgets/gadgets.factor b/extra/pango/cairo/gadgets/gadgets.factor similarity index 69% rename from extra/cairo/pango/gadgets/gadgets.factor rename to extra/pango/cairo/gadgets/gadgets.factor index fa12f96622..9e8a99515e 100644 --- a/extra/cairo/pango/gadgets/gadgets.factor +++ b/extra/pango/cairo/gadgets/gadgets.factor @@ -1,10 +1,12 @@ -USING: cairo.pango cairo cairo.ffi cairo.gadgets +! Copyright (C) 2008 Matthew Willis. +! See http://factorcode.org/license.txt for BSD license. +USING: pango.cairo cairo cairo.ffi cairo.gadgets alien.c-types kernel math ; -IN: cairo.pango.gadgets +IN: pango.cairo.gadgets : (pango-gadget) ( setup show -- gadget ) [ drop layout-size ] - [ compose [ with-pango ] curry ] 2bi ; + [ compose [ with-pango ] curry ] 2bi ; : ( quot -- gadget ) [ cr layout pango_cairo_show_layout ] (pango-gadget) ; @@ -21,7 +23,7 @@ threads io.backend io.encodings.utf8 io.files ; gadget. yield ] each [ - "resource:extra/cairo/pango/gadgets/gadgets.factor" + "resource:extra/pango/cairo/gadgets/gadgets.factor" normalize-path utf8 file-contents layout-text ] gadget. ; diff --git a/extra/pango/fonts/fonts.factor b/extra/pango/fonts/fonts.factor index 6076b6a254..d07c71226a 100644 --- a/extra/pango/fonts/fonts.factor +++ b/extra/pango/fonts/fonts.factor @@ -26,15 +26,15 @@ pango_font_face_list_sizes ( PangoFontFace* face, int** sizes, int* n_sizes ) ; : list-families ( PangoFontMap* -- PangoFontFamily*-seq ) 0 0 [ pango_font_map_list_families ] 2keep - *int >r *void* r> c-void*-array> ; + *int swap *void* [ swap c-void*-array> ] [ g_free ] bi ; : list-faces ( PangoFontFamily* -- PangoFontFace*-seq ) 0 0 [ pango_font_family_list_faces ] 2keep - *int >r *void* r> c-void*-array> ; + *int swap *void* [ swap c-void*-array> ] [ g_free ] bi ; : list-sizes ( PangoFontFace* -- ints ) 0 0 [ pango_font_face_list_sizes ] 2keep - *int >r *void* r> c-int-array> ; + *int swap *void* [ swap c-int-array> ] [ g_free ] bi ; : monospace? ( PangoFontFamily* -- ? ) pango_font_family_is_monospace 1 = ; diff --git a/extra/pango/pango.factor b/extra/pango/pango.factor index 3836a43e3f..3549d9abb4 100644 --- a/extra/pango/pango.factor +++ b/extra/pango/pango.factor @@ -48,7 +48,12 @@ pango_layout_get_pixel_size ( PangoLayout* layout, int* width, int* height ) ; FUNCTION: void pango_font_description_free ( PangoFontDescription* desc ) ; +! glib functions + TYPEDEF: void* gpointer FUNCTION: void g_object_unref ( gpointer object ) ; + +FUNCTION: void +g_free ( gpointer mem ) ; 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/tools/deploy/deploy-tests.factor b/extra/tools/deploy/deploy-tests.factor index 37689f749f..8ff22fb1ad 100755 --- a/extra/tools/deploy/deploy-tests.factor +++ b/extra/tools/deploy/deploy-tests.factor @@ -23,7 +23,7 @@ namespaces continuations layouts accessors ; [ ] [ "sudoku" shake-and-bake ] unit-test [ t ] [ - cell 8 = 30 15 ? 100000 * small-enough? + cell 8 = 20 10 ? 100000 * small-enough? ] unit-test [ ] [ "hello-ui" shake-and-bake ] unit-test @@ -37,6 +37,12 @@ namespaces continuations layouts accessors ; cell 8 = 40 20 ? 100000 * small-enough? ] unit-test +[ ] [ "maze" shake-and-bake ] unit-test + +[ t ] [ + cell 8 = 30 15 ? 100000 * small-enough? +] unit-test + [ ] [ "bunny" shake-and-bake ] unit-test [ t ] [ diff --git a/extra/tools/deploy/shaker/shaker.factor b/extra/tools/deploy/shaker/shaker.factor index 4f0d6ac036..e8675f5891 100755 --- a/extra/tools/deploy/shaker/shaker.factor +++ b/extra/tools/deploy/shaker/shaker.factor @@ -108,6 +108,8 @@ IN: tools.deploy.shaker : stripped-globals ( -- seq ) [ + "callbacks" "alien.compiler" lookup , + { bootstrap.stage2:bootstrap-time continuations:error @@ -142,6 +144,7 @@ IN: tools.deploy.shaker { gensym + name>char-hook classes:class-and-cache classes:class-not-cache classes:class-or-cache @@ -167,6 +170,8 @@ IN: tools.deploy.shaker vocabs:load-vocab-hook word } % + + { } { "optimizer.math.partial" } strip-vocab-globals % ] when strip-prettyprint? [ diff --git a/extra/tools/walker/walker.factor b/extra/tools/walker/walker.factor index ef6dac66f6..2417e7ac39 100755 --- a/extra/tools/walker/walker.factor +++ b/extra/tools/walker/walker.factor @@ -4,7 +4,7 @@ USING: threads kernel namespaces continuations combinators sequences math namespaces.private continuations.private concurrency.messaging quotations kernel.private words sequences.private assocs models arrays accessors -generic generic.standard ; +generic generic.standard definitions ; IN: tools.walker SYMBOL: show-walker-hook ! ( status continuation thread -- ) @@ -73,6 +73,7 @@ M: object add-breakpoint ; { [ dup "step-into" word-prop ] [ "step-into" word-prop call ] } { [ dup standard-generic? ] [ effective-method (step-into-execute) ] } { [ dup hook-generic? ] [ effective-method (step-into-execute) ] } + { [ dup uses \ suspend swap member? ] [ execute break ] } { [ dup primitive? ] [ execute break ] } [ word-def (step-into-quot) ] } cond ; @@ -89,7 +90,6 @@ SYMBOL: step-into SYMBOL: step-all SYMBOL: step-into-all SYMBOL: step-back -SYMBOL: detach SYMBOL: abandon SYMBOL: call-in @@ -137,7 +137,7 @@ SYMBOL: +stopped+ { >n ndrop >c c> continue continue-with - stop yield suspend sleep (spawn) + stop suspend (spawn) } [ dup [ execute break ] curry "step-into" set-word-prop @@ -168,10 +168,7 @@ SYMBOL: +stopped+ +running+ set-status ; : walker-stopped ( -- ) - +stopped+ set-status - [ status +stopped+ eq? ] - [ [ drop f ] handle-synchronous ] - [ ] while ; + +stopped+ set-status ; : step-into-all-loop ( -- ) +running+ set-status 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/urls/authors.txt b/extra/urls/authors.txt new file mode 100644 index 0000000000..1901f27a24 --- /dev/null +++ b/extra/urls/authors.txt @@ -0,0 +1 @@ +Slava Pestov diff --git a/extra/urls/summary.txt b/extra/urls/summary.txt new file mode 100644 index 0000000000..caeda3d21a --- /dev/null +++ b/extra/urls/summary.txt @@ -0,0 +1 @@ +Tools for working with URLs (uniform resource locators) diff --git a/extra/urls/tags.txt b/extra/urls/tags.txt new file mode 100644 index 0000000000..93e65ae758 --- /dev/null +++ b/extra/urls/tags.txt @@ -0,0 +1,2 @@ +web +network diff --git a/extra/urls/urls-tests.factor b/extra/urls/urls-tests.factor new file mode 100644 index 0000000000..e28816fdb3 --- /dev/null +++ b/extra/urls/urls-tests.factor @@ -0,0 +1,194 @@ +IN: urls.tests +USING: urls tools.test tuple-syntax arrays kernel assocs ; + +[ "hello%20world" ] [ "hello world" url-encode ] unit-test +[ "hello world" ] [ "hello%20world" url-decode ] unit-test +[ "~hello world" ] [ "%7ehello+world" url-decode ] unit-test +[ f ] [ "%XX%XX%XX" url-decode ] unit-test +[ f ] [ "%XX%XX%X" url-decode ] unit-test + +[ "hello world" ] [ "hello+world" url-decode ] unit-test +[ "hello world" ] [ "hello%20world" url-decode ] unit-test +[ " ! " ] [ "%20%21%20" url-decode ] unit-test +[ "hello world" ] [ "hello world%" url-decode ] unit-test +[ "hello world" ] [ "hello world%x" url-decode ] unit-test +[ "hello%20world" ] [ "hello world" url-encode ] unit-test +[ "%20%21%20" ] [ " ! " url-encode ] unit-test + +[ "\u001234hi\u002045" ] [ "\u001234hi\u002045" url-encode url-decode ] unit-test + +[ "a=b&a=c" ] [ { { "a" { "b" "c" } } } assoc>query ] unit-test + +[ H{ { "a" "b" } } ] [ "a=b" query>assoc ] unit-test + +[ H{ { "a" { "b" "c" } } } ] [ "a=b&a=c" query>assoc ] unit-test + +[ "a=3" ] [ { { "a" 3 } } assoc>query ] unit-test + +: urls + { + { + TUPLE{ url + protocol: "http" + host: "www.apple.com" + port: 1234 + path: "/a/path" + query: H{ { "a" "b" } } + anchor: "foo" + } + "http://www.apple.com:1234/a/path?a=b#foo" + } + { + TUPLE{ url + protocol: "http" + host: "www.apple.com" + path: "/a/path" + query: H{ { "a" "b" } } + anchor: "foo" + } + "http://www.apple.com/a/path?a=b#foo" + } + { + TUPLE{ url + protocol: "http" + host: "www.apple.com" + port: 1234 + path: "/another/fine/path" + anchor: "foo" + } + "http://www.apple.com:1234/another/fine/path#foo" + } + { + TUPLE{ url + path: "/a/relative/path" + anchor: "foo" + } + "/a/relative/path#foo" + } + { + TUPLE{ url + path: "/a/relative/path" + } + "/a/relative/path" + } + { + TUPLE{ url + path: "a/relative/path" + } + "a/relative/path" + } + } ; + +urls [ + [ 1array ] [ [ string>url ] curry ] bi* unit-test +] assoc-each + +urls [ + swap [ 1array ] [ [ url>string ] curry ] bi* unit-test +] assoc-each + +[ "b" ] [ "a" "b" url-append-path ] unit-test + +[ "a/b" ] [ "a/c" "b" url-append-path ] unit-test + +[ "a/b" ] [ "a/" "b" url-append-path ] unit-test + +[ "/b" ] [ "a" "/b" url-append-path ] unit-test + +[ "/b" ] [ "a/b/" "/b" url-append-path ] unit-test + +[ "/xxx/bar" ] [ "/xxx/baz" "bar" url-append-path ] unit-test + +[ + TUPLE{ url + protocol: "http" + host: "www.apple.com" + port: 1234 + path: "/a/path" + } +] [ + TUPLE{ url + protocol: "http" + host: "www.apple.com" + port: 1234 + path: "/foo" + } + + TUPLE{ url + path: "/a/path" + } + + derive-url +] unit-test + +[ + TUPLE{ url + protocol: "http" + host: "www.apple.com" + port: 1234 + path: "/a/path/relative/path" + query: H{ { "a" "b" } } + anchor: "foo" + } +] [ + TUPLE{ url + protocol: "http" + host: "www.apple.com" + port: 1234 + path: "/a/path/" + } + + TUPLE{ url + path: "relative/path" + query: H{ { "a" "b" } } + anchor: "foo" + } + + derive-url +] unit-test + +[ + TUPLE{ url + protocol: "http" + host: "www.apple.com" + port: 1234 + path: "/a/path/relative/path" + query: H{ { "a" "b" } } + anchor: "foo" + } +] [ + TUPLE{ url + protocol: "http" + host: "www.apple.com" + port: 1234 + path: "/a/path/" + } + + TUPLE{ url + path: "relative/path" + query: H{ { "a" "b" } } + anchor: "foo" + } + + derive-url +] unit-test + +[ + TUPLE{ url + protocol: "http" + host: "www.apple.com" + path: "/xxx/baz" + } +] [ + TUPLE{ url + protocol: "http" + host: "www.apple.com" + path: "/xxx/bar" + } + + TUPLE{ url + path: "baz" + } + + derive-url +] unit-test diff --git a/extra/urls/urls.factor b/extra/urls/urls.factor new file mode 100644 index 0000000000..e20df65656 --- /dev/null +++ b/extra/urls/urls.factor @@ -0,0 +1,160 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: kernel unicode.categories combinators sequences splitting +fry namespaces assocs arrays strings mirrors +io.encodings.string io.encodings.utf8 +math math.parser accessors namespaces.lib ; +IN: urls + +: url-quotable? ( ch -- ? ) + #! In a URL, can this character be used without + #! URL-encoding? + { + { [ dup letter? ] [ t ] } + { [ dup LETTER? ] [ t ] } + { [ dup digit? ] [ t ] } + { [ dup "/_-.:" member? ] [ t ] } + [ f ] + } cond nip ; foldable + +: push-utf8 ( ch -- ) + 1string utf8 encode + [ CHAR: % , >hex 2 CHAR: 0 pad-left % ] each ; + +: url-encode ( str -- str ) + [ + [ dup url-quotable? [ , ] [ push-utf8 ] if ] each + ] "" make ; + +: url-decode-hex ( index str -- ) + 2dup length 2 - >= [ + 2drop + ] [ + [ 1+ dup 2 + ] dip subseq hex> [ , ] when* + ] if ; + +: url-decode-% ( index str -- index str ) + 2dup url-decode-hex [ 3 + ] dip ; + +: url-decode-+-or-other ( index str ch -- index str ) + dup CHAR: + = [ drop CHAR: \s ] when , [ 1+ ] dip ; + +: url-decode-iter ( index str -- ) + 2dup length >= [ + 2drop + ] [ + 2dup nth dup CHAR: % = [ + drop url-decode-% + ] [ + url-decode-+-or-other + ] if url-decode-iter + ] if ; + +: url-decode ( str -- str ) + [ 0 swap url-decode-iter ] "" make utf8 decode ; + +: add-query-param ( value key assoc -- ) + [ + at [ + { + { [ dup string? ] [ swap 2array ] } + { [ dup array? ] [ swap suffix ] } + { [ dup not ] [ drop ] } + } cond + ] when* + ] 2keep set-at ; + +: query>assoc ( query -- assoc ) + dup [ + "&" split H{ } clone [ + [ + [ "=" split1 [ dup [ url-decode ] when ] bi@ swap ] dip + add-query-param + ] curry each + ] keep + ] when ; + +: assoc>query ( hash -- str ) + [ + { + { [ dup number? ] [ number>string 1array ] } + { [ dup string? ] [ 1array ] } + { [ dup sequence? ] [ ] } + } cond + ] assoc-map + [ + [ + [ url-encode ] dip + [ url-encode "=" swap 3append , ] with each + ] assoc-each + ] { } make "&" join ; + +TUPLE: url protocol host port path query anchor ; + +: query-param ( request key -- value ) + swap query>> at ; + +: set-query-param ( request value key -- request ) + pick query>> set-at ; + +: parse-host ( string -- host port ) + ":" split1 [ url-decode ] [ + dup [ + string>number + dup [ "Invalid port" throw ] unless + ] when + ] bi* ; + +: parse-host-part ( protocol rest -- string' ) + [ "protocol" set ] [ + "//" ?head [ "Invalid URL" throw ] unless + "/" split1 [ + parse-host [ "host" set ] [ "port" set ] bi* + ] [ "/" prepend ] bi* + ] bi* ; + +: string>url ( string -- url ) + [ + ":" split1 [ parse-host-part ] when* + "#" split1 [ + "?" split1 [ query>assoc "query" set ] when* + url-decode "path" set + ] [ + url-decode "anchor" set + ] bi* + ] url make-object ; + +: unparse-host-part ( protocol -- ) + % + "://" % + "host" get url-encode % + "port" get [ ":" % # ] when* + "path" get "/" head? [ "Invalid URL" throw ] unless ; + +: url>string ( url -- string ) + [ + [ + "protocol" get [ unparse-host-part ] when* + "path" get url-encode % + "query" get [ "?" % assoc>query % ] when* + "anchor" get [ "#" % url-encode % ] when* + ] bind + ] "" make ; + +: url-append-path ( path1 path2 -- path ) + { + { [ dup "/" head? ] [ nip ] } + { [ dup empty? ] [ drop ] } + { [ over "/" tail? ] [ append ] } + { [ "/" pick start not ] [ nip ] } + [ [ "/" last-split1 drop "/" ] dip 3append ] + } cond ; + +: derive-url ( base url -- url' ) + [ clone dup ] dip + 2dup [ path>> ] bi@ url-append-path + [ [ ] bi@ [ nip ] assoc-filter update ] dip + >>path ; + +: relative-url ( url -- url' ) + clone f >>protocol f >>host f >>port ; 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..43cae74ec8 100644 --- a/extra/webapps/pastebin/pastebin.factor +++ b/extra/webapps/pastebin/pastebin.factor @@ -1,29 +1,23 @@ +! 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: entity id summary author mode date contents ; -TUPLE: paste id summary author mode date contents annotations captcha ; - -paste "PASTE" +entity f { { "id" "ID" INTEGER +db-assigned-id+ } { "summary" "SUMMARY" { VARCHAR 256 } +not-null+ } @@ -33,205 +27,202 @@ paste "PASTE" { "contents" "CONTENTS" TEXT +not-null+ } } define-persistent +TUPLE: paste < entity annotations ; + +\ paste "PASTES" { } 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 < entity parent ; -annotation "ANNOTATION" +annotation "ANNOTATIONS" { - { "aid" "AID" INTEGER +db-assigned-id+ } - { "id" "ID" INTEGER +not-null+ } - { "summary" "SUMMARY" { VARCHAR 256 } +not-null+ } - { "author" "AUTHOR" { VARCHAR 256 } +not-null+ } - { "mode" "MODE" { VARCHAR 256 } +not-null+ } - { "date" "DATE" DATETIME +not-null+ } - { "contents" "CONTENTS" TEXT +not-null+ } + { "parent" "PARENT" INTEGER +not-null+ } } define-persistent -: ( id aid -- annotation ) +: ( parent id -- annotation ) annotation new - swap >>aid - swap >>id ; + swap >>id + swap >>parent ; : fetch-annotations ( paste -- paste ) dup annotations>> [ 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 + [ parent>> "parent" associate "$pastebin/paste" swap link>string ] + [ id>> 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-entity ( -- ) + { + { "summary" [ v-one-line ] } + { "author" [ v-one-line ] } + { "mode" [ v-mode ] } + { "contents" [ v-required ] } + { "captcha" [ v-captcha ] } + } validate-params ; + +: deposit-entity-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-entity - form validate-form + f + [ deposit-entity-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 ) + + [ + { { "id" [ v-integer ] } } validate-params + "id" value "$pastebin/paste" + ] >>display + + [ + { { "id" [ v-integer ] } } validate-params + validate-entity + ] >>validate + + [ + "id" value f + [ deposit-entity-slots ] + [ insert-tuple ] + [ + ! Add anchor here + parent>> "$pastebin/paste" + ] + tri + ] >>submit ; + +: ( -- action ) + + [ { { "id" [ v-number ] } } validate-params ] >>validate + + [ + f "id" value select-tuple + [ delete-tuples ] + [ parent>> "$pastebin/paste" ] + bi ] >>submit ; TUPLE: pastebin < dispatcher ; @@ -242,17 +233,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/callstack.c b/vm/callstack.c
index 25219d1569..df4063d149 100755
--- a/vm/callstack.c
+++ b/vm/callstack.c
@@ -109,9 +109,7 @@ CELL frame_executing(F_STACK_FRAME *frame)
 {
 	F_COMPILED *compiled = frame_code(frame);
 	CELL code_start = (CELL)(compiled + 1);
-	CELL literal_start = code_start
-		+ compiled->code_length
-		+ compiled->reloc_length;
+	CELL literal_start = code_start + compiled->code_length;
 
 	return get(literal_start);
 }
diff --git a/vm/code_gc.c b/vm/code_gc.c
index 141f4abbfe..e0abdc5a61 100755
--- a/vm/code_gc.c
+++ b/vm/code_gc.c
@@ -257,12 +257,13 @@ void iterate_code_heap(CODE_HEAP_ITERATOR iter)
 }
 
 /* Copy all literals referenced from a code block to newspace */
-void collect_literals_step(F_COMPILED *compiled, CELL code_start,
-	CELL reloc_start, CELL literals_start)
+void collect_literals_step(F_COMPILED *compiled, CELL code_start, CELL literals_start)
 {
 	CELL scan;
 	CELL literal_end = literals_start + compiled->literals_length;
 
+	copy_handle(&compiled->relocation);
+
 	for(scan = literals_start; scan < literal_end; scan += CELLS)
 		copy_handle((CELL*)scan);
 }
diff --git a/vm/code_gc.h b/vm/code_gc.h
index 658dc990ae..f93cba9c7a 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 {
@@ -47,16 +44,14 @@ INLINE F_BLOCK *next_block(F_HEAP *heap, F_BLOCK *block)
 /* compiled code */
 F_HEAP code_heap;
 
-typedef void (*CODE_HEAP_ITERATOR)(F_COMPILED *compiled, CELL code_start,
-	CELL reloc_start, CELL literals_start);
+typedef void (*CODE_HEAP_ITERATOR)(F_COMPILED *compiled, CELL code_start, CELL literals_start);
 
 INLINE void iterate_code_heap_step(F_COMPILED *compiled, CODE_HEAP_ITERATOR iter)
 {
 	CELL code_start = (CELL)(compiled + 1);
-	CELL reloc_start = code_start + compiled->code_length;
-	CELL literals_start = reloc_start + compiled->reloc_length;
+	CELL literals_start = code_start + compiled->code_length;
 
-	iter(compiled,code_start,reloc_start,literals_start);
+	iter(compiled,code_start,literals_start);
 }
 
 INLINE F_BLOCK *compiled_to_block(F_COMPILED *compiled)
diff --git a/vm/code_heap.c b/vm/code_heap.c
index 92915e49d1..69ffdeb2aa 100755
--- a/vm/code_heap.c
+++ b/vm/code_heap.c
@@ -139,13 +139,14 @@ void apply_relocation(CELL class, CELL offset, F_FIXNUM absolute_value)
 }
 
 /* Perform all fixups on a code block */
-void relocate_code_block(F_COMPILED *relocating, CELL code_start,
-	CELL reloc_start, CELL literals_start)
+void relocate_code_block(F_COMPILED *compiled, CELL code_start, CELL literals_start)
 {
-	if(reloc_start != literals_start)
+	if(compiled->relocation != F)
 	{
-		F_REL *rel = (F_REL *)reloc_start;
-		F_REL *rel_end = (F_REL *)literals_start;
+		F_BYTE_ARRAY *relocation = untag_object(compiled->relocation);
+
+		F_REL *rel = (F_REL *)(relocation + 1);
+		F_REL *rel_end = (F_REL *)((char *)rel + byte_array_capacity(relocation));
 
 		while(rel < rel_end)
 		{
@@ -160,7 +161,7 @@ void relocate_code_block(F_COMPILED *relocating, CELL code_start,
 		}
 	}
 
-	flush_icache(code_start,reloc_start - code_start);
+	flush_icache(code_start,literals_start - code_start);
 }
 
 /* Fixup labels. This is done at compile time, not image load time */
@@ -249,34 +250,32 @@ F_COMPILED *add_compiled_block(
 	CELL type,
 	F_ARRAY *code,
 	F_ARRAY *labels,
-	F_ARRAY *relocation,
+	CELL relocation,
 	F_ARRAY *literals)
 {
 	CELL code_format = compiled_code_format();
 
 	CELL code_length = align8(array_capacity(code) * code_format);
-	CELL rel_length = array_capacity(relocation) * sizeof(unsigned int);
 	CELL literals_length = array_capacity(literals) * CELLS;
 
+	REGISTER_ROOT(relocation);
 	REGISTER_UNTAGGED(code);
 	REGISTER_UNTAGGED(labels);
-	REGISTER_UNTAGGED(relocation);
 	REGISTER_UNTAGGED(literals);
 
-	CELL here = allot_code_block(sizeof(F_COMPILED) + code_length
-		+ rel_length + literals_length);
+	CELL here = allot_code_block(sizeof(F_COMPILED) + code_length + literals_length);
 
 	UNREGISTER_UNTAGGED(literals);
-	UNREGISTER_UNTAGGED(relocation);
 	UNREGISTER_UNTAGGED(labels);
 	UNREGISTER_UNTAGGED(code);
+	UNREGISTER_ROOT(relocation);
 
 	/* compiled header */
 	F_COMPILED *header = (void *)here;
 	header->type = type;
 	header->code_length = code_length;
-	header->reloc_length = rel_length;
 	header->literals_length = literals_length;
+	header->relocation = relocation;
 
 	here += sizeof(F_COMPILED);
 
@@ -286,10 +285,6 @@ F_COMPILED *add_compiled_block(
 	deposit_integers(here,code,code_format);
 	here += code_length;
 
-	/* relation info */
-	deposit_integers(here,relocation,sizeof(unsigned int));
-	here += rel_length;
-
 	/* literals */
 	deposit_objects(here,literals);
 	here += literals_length;
@@ -353,7 +348,7 @@ DEFINE_PRIMITIVE(modify_code_heap)
 			F_ARRAY *compiled_code = untag_array(data);
 
 			F_ARRAY *literals = untag_array(array_nth(compiled_code,0));
-			F_ARRAY *relocation = untag_array(array_nth(compiled_code,1));
+			CELL relocation = array_nth(compiled_code,1);
 			F_ARRAY *labels = untag_array(array_nth(compiled_code,2));
 			F_ARRAY *code = untag_array(array_nth(compiled_code,3));
 
diff --git a/vm/code_heap.h b/vm/code_heap.h
index 4e65313d3b..80605b1d28 100755
--- a/vm/code_heap.h
+++ b/vm/code_heap.h
@@ -53,8 +53,7 @@ typedef struct {
 	unsigned int offset;
 } F_REL;
 
-void relocate_code_block(F_COMPILED *relocating, CELL code_start,
-	CELL reloc_start, CELL literals_start);
+void relocate_code_block(F_COMPILED *relocating, CELL code_start, CELL literals_start);
 
 void default_word_code(F_WORD *word, bool relocate);
 
@@ -64,7 +63,7 @@ F_COMPILED *add_compiled_block(
 	CELL type,
 	F_ARRAY *code,
 	F_ARRAY *labels,
-	F_ARRAY *rel,
+	CELL relocation,
 	F_ARRAY *literals);
 
 CELL compiled_code_format(void);
diff --git a/vm/data_gc.c b/vm/data_gc.c
index a52f2490e9..54ad1168a0 100755
--- a/vm/data_gc.c
+++ b/vm/data_gc.c
@@ -930,22 +930,22 @@ DEFINE_PRIMITIVE(gc_stats)
 	for(i = 0; i < MAX_GEN_COUNT; i++)
 	{
 		F_GC_STATS *s = &gc_stats[i];
-		GROWABLE_ADD(stats,allot_cell(s->collections));
-		GROWABLE_ADD(stats,allot_cell(s->gc_time));
-		GROWABLE_ADD(stats,allot_cell(s->max_gc_time));
-		GROWABLE_ADD(stats,allot_cell(s->collections == 0 ? 0 : s->gc_time / s->collections));
-		GROWABLE_ADD(stats,allot_cell(s->object_count));
-		GROWABLE_ADD(stats,tag_bignum(long_long_to_bignum(s->bytes_copied)));
+		GROWABLE_ARRAY_ADD(stats,allot_cell(s->collections));
+		GROWABLE_ARRAY_ADD(stats,allot_cell(s->gc_time));
+		GROWABLE_ARRAY_ADD(stats,allot_cell(s->max_gc_time));
+		GROWABLE_ARRAY_ADD(stats,allot_cell(s->collections == 0 ? 0 : s->gc_time / s->collections));
+		GROWABLE_ARRAY_ADD(stats,allot_cell(s->object_count));
+		GROWABLE_ARRAY_ADD(stats,tag_bignum(long_long_to_bignum(s->bytes_copied)));
 
 		total_gc_time += s->gc_time;
 	}
 
-	GROWABLE_ADD(stats,allot_cell(total_gc_time));
-	GROWABLE_ADD(stats,tag_bignum(long_long_to_bignum(cards_scanned)));
-	GROWABLE_ADD(stats,tag_bignum(long_long_to_bignum(decks_scanned)));
-	GROWABLE_ADD(stats,allot_cell(code_heap_scans));
+	GROWABLE_ARRAY_ADD(stats,allot_cell(total_gc_time));
+	GROWABLE_ARRAY_ADD(stats,tag_bignum(long_long_to_bignum(cards_scanned)));
+	GROWABLE_ARRAY_ADD(stats,tag_bignum(long_long_to_bignum(decks_scanned)));
+	GROWABLE_ARRAY_ADD(stats,allot_cell(code_heap_scans));
 
-	GROWABLE_TRIM(stats);
+	GROWABLE_ARRAY_TRIM(stats);
 	dpush(stats);
 }
 
@@ -986,13 +986,13 @@ CELL find_all_words(void)
 	while((obj = next_object()) != F)
 	{
 		if(type_of(obj) == WORD_TYPE)
-			GROWABLE_ADD(words,obj);
+			GROWABLE_ARRAY_ADD(words,obj);
 	}
 
 	/* End heap scan */
 	gc_off = false;
 
-	GROWABLE_TRIM(words);
+	GROWABLE_ARRAY_TRIM(words);
 
 	return words;
 }
diff --git a/vm/debug.c b/vm/debug.c
index b86ec808bc..0278426895 100755
--- a/vm/debug.c
+++ b/vm/debug.c
@@ -296,8 +296,7 @@ void find_data_references(CELL look_for_)
 
 CELL look_for;
 
-void find_code_references_step(F_COMPILED *compiled, CELL code_start,
-		CELL reloc_start, CELL literals_start)
+void find_code_references_step(F_COMPILED *compiled, CELL code_start, CELL literals_start)
 {
 	CELL scan;
 	CELL literal_end = literals_start + compiled->literals_length;
@@ -305,9 +304,7 @@ void find_code_references_step(F_COMPILED *compiled, CELL code_start,
 	for(scan = literals_start; scan < literal_end; scan += CELLS)
 	{
 		CELL code_start = (CELL)(compiled + 1);
-		CELL literal_start = code_start
-			+ compiled->code_length
-			+ compiled->reloc_length;
+		CELL literal_start = code_start + compiled->code_length;
 
 		CELL obj = get(literal_start);
 
diff --git a/vm/image.c b/vm/image.c
index 653891fdfe..141594f01f 100755
--- a/vm/image.c
+++ b/vm/image.c
@@ -288,18 +288,18 @@ void relocate_data()
 	}
 }
 
-void fixup_code_block(F_COMPILED *relocating, CELL code_start,
-	CELL reloc_start, CELL literals_start)
+void fixup_code_block(F_COMPILED *compiled, CELL code_start, CELL literals_start)
 {
 	/* relocate literal table data */
 	CELL scan;
-	CELL literal_end = literals_start + relocating->literals_length;
+	CELL literal_end = literals_start + compiled->literals_length;
+
+	data_fixup(&compiled->relocation);
 
 	for(scan = literals_start; scan < literal_end; scan += CELLS)
 		data_fixup((CELL*)scan);
 
-	if(reloc_start != literals_start)
-		relocate_code_block(relocating,code_start,reloc_start,literals_start);
+	relocate_code_block(compiled,code_start,literals_start);
 }
 
 void relocate_code()
diff --git a/vm/layouts.h b/vm/layouts.h
index 89af0a306c..1aee94357b 100755
--- a/vm/layouts.h
+++ b/vm/layouts.h
@@ -113,8 +113,8 @@ typedef struct
 {
 	CELL type; /* this is WORD_TYPE or QUOTATION_TYPE */
 	CELL code_length; /* # bytes */
-	CELL reloc_length; /* # bytes */
 	CELL literals_length; /* # bytes */
+	CELL relocation; /* tagged pointer to byte-array or f */
 } F_COMPILED;
 
 /* Assembly code makes assumptions about the layout of this struct */
diff --git a/vm/os-unix.c b/vm/os-unix.c
index 6363ce68a9..1f63ea7ab1 100755
--- a/vm/os-unix.c
+++ b/vm/os-unix.c
@@ -73,14 +73,14 @@ DEFINE_PRIMITIVE(read_dir)
 		while((file = readdir(dir)) != NULL)
 		{
 			CELL pair = parse_dir_entry(file);
-			GROWABLE_ADD(result,pair);
+			GROWABLE_ARRAY_ADD(result,pair);
 		}
 
 		closedir(dir);
 	}
 
 	UNREGISTER_ROOT(result);
-	GROWABLE_TRIM(result);
+	GROWABLE_ARRAY_TRIM(result);
 
 	dpush(result);
 }
@@ -104,12 +104,12 @@ DEFINE_PRIMITIVE(os_envs)
 	while(*env)
 	{
 		CELL string = tag_object(from_char_string(*env));
-		GROWABLE_ADD(result,string);
+		GROWABLE_ARRAY_ADD(result,string);
 		env++;
 	}
 
 	UNREGISTER_ROOT(result);
-	GROWABLE_TRIM(result);
+	GROWABLE_ARRAY_TRIM(result);
 	dpush(result);
 }
 
diff --git a/vm/os-windows-nt.c b/vm/os-windows-nt.c
index cc7b128941..4f5778d0c4 100755
--- a/vm/os-windows-nt.c
+++ b/vm/os-windows-nt.c
@@ -25,7 +25,7 @@ DEFINE_PRIMITIVE(os_envs)
 			break;
 
 		CELL string = tag_object(from_u16_string(finger));
-		GROWABLE_ADD(result,string);
+		GROWABLE_ARRAY_ADD(result,string);
 
 		finger = scan + 1;
 	}
@@ -33,7 +33,7 @@ DEFINE_PRIMITIVE(os_envs)
 	FreeEnvironmentStrings(env);
 
 	UNREGISTER_ROOT(result);
-	GROWABLE_TRIM(result);
+	GROWABLE_ARRAY_TRIM(result);
 	dpush(result);
 }
 
diff --git a/vm/os-windows.c b/vm/os-windows.c
index 59c14d98f5..dc931d31c8 100755
--- a/vm/os-windows.c
+++ b/vm/os-windows.c
@@ -152,14 +152,14 @@ DEFINE_PRIMITIVE(read_dir)
 			CELL name = tag_object(from_u16_string(find_data.cFileName));
 			CELL dirp = tag_boolean(find_data.dwFileAttributes & FILE_ATTRIBUTE_DIRECTORY);
 			CELL pair = allot_array_2(name,dirp);
-			GROWABLE_ADD(result,pair);
+			GROWABLE_ARRAY_ADD(result,pair);
 		}
 		while (FindNextFile(dir, &find_data));
 		FindClose(dir);
 	}
 
 	UNREGISTER_ROOT(result);
-	GROWABLE_TRIM(result);
+	GROWABLE_ARRAY_TRIM(result);
 
 	dpush(result);
 }
diff --git a/vm/profiler.c b/vm/profiler.c
index 08bb846c85..58a4aa035e 100755
--- a/vm/profiler.c
+++ b/vm/profiler.c
@@ -11,11 +11,12 @@ F_COMPILED *compile_profiling_stub(F_WORD *word)
 	CELL code = array_nth(quadruple,0);
 	REGISTER_ROOT(code);
 
-	CELL rel_type = allot_cell(to_fixnum(array_nth(quadruple,2))
-		| (to_fixnum(array_nth(quadruple,1)) << 8));
-	CELL rel_offset = array_nth(quadruple,3) * compiled_code_format();
+	F_REL rel;
+	rel.type = to_fixnum(array_nth(quadruple,2)) | (to_fixnum(array_nth(quadruple,1)) << 8);
+	rel.offset = to_fixnum(array_nth(quadruple,3)) * compiled_code_format();
 
-	CELL relocation = allot_array_2(rel_type,rel_offset);
+	F_BYTE_ARRAY *relocation = allot_byte_array(sizeof(F_REL));
+	memcpy((void *)BREF(relocation,0),&rel,sizeof(F_REL));
 
 	UNREGISTER_ROOT(code);
 	UNREGISTER_ROOT(literals);
@@ -24,7 +25,7 @@ F_COMPILED *compile_profiling_stub(F_WORD *word)
 		WORD_TYPE,
 		untag_object(code),
 		NULL, /* no labels */
-		untag_object(relocation),
+		tag_object(relocation),
 		untag_object(literals));
 }
 
diff --git a/vm/quotations.c b/vm/quotations.c
index c3b50dbd47..e092aab4bf 100755
--- a/vm/quotations.c
+++ b/vm/quotations.c
@@ -60,14 +60,9 @@ F_REL rel_to_emit(CELL name, CELL code_format, CELL code_length,
 
 #define EMIT(name,rel_argument) { \
 		bool rel_p; \
-		F_REL rel = rel_to_emit(name,code_format,code_count, \
-			rel_argument,&rel_p); \
-		if(rel_p) \
-		{ \
-			GROWABLE_ADD(relocation,allot_cell(rel.type)); \
-			GROWABLE_ADD(relocation,allot_cell(rel.offset)); \
-		} \
-		GROWABLE_APPEND(code,code_to_emit(name)); \
+		F_REL rel = rel_to_emit(name,code_format,code_count,rel_argument,&rel_p); \
+		if(rel_p) GROWABLE_BYTE_ARRAY_APPEND(relocation,&rel,sizeof(F_REL)); \
+		GROWABLE_ARRAY_APPEND(code,code_to_emit(name)); \
 	}
 
 bool jit_stack_frame_p(F_ARRAY *array)
@@ -110,13 +105,13 @@ void jit_compile(CELL quot, bool relocate)
 	GROWABLE_ARRAY(code);
 	REGISTER_ROOT(code);
 
-	GROWABLE_ARRAY(relocation);
+	GROWABLE_BYTE_ARRAY(relocation);
 	REGISTER_ROOT(relocation);
 
 	GROWABLE_ARRAY(literals);
 	REGISTER_ROOT(literals);
 
-	GROWABLE_ADD(literals,stack_traces_p() ? quot : F);
+	GROWABLE_ARRAY_ADD(literals,stack_traces_p() ? quot : F);
 
 	bool stack_frame = jit_stack_frame_p(untag_object(array));
 
@@ -141,7 +136,7 @@ void jit_compile(CELL quot, bool relocate)
 			current stack frame. */
 			word = untag_object(obj);
 
-			GROWABLE_ADD(literals,array_nth(untag_object(array),i));
+			GROWABLE_ARRAY_ADD(literals,array_nth(untag_object(array),i));
 
 			if(i == length - 1)
 			{
@@ -157,7 +152,7 @@ void jit_compile(CELL quot, bool relocate)
 			break;
 		case WRAPPER_TYPE:
 			wrapper = untag_object(obj);
-			GROWABLE_ADD(literals,wrapper->object);
+			GROWABLE_ARRAY_ADD(literals,wrapper->object);
 			EMIT(JIT_PUSH_LITERAL,literals_count - 1);
 			break;
 		case FIXNUM_TYPE:
@@ -176,8 +171,8 @@ void jit_compile(CELL quot, bool relocate)
 				if(stack_frame)
 					EMIT(JIT_EPILOG,0);
 
-				GROWABLE_ADD(literals,array_nth(untag_object(array),i));
-				GROWABLE_ADD(literals,array_nth(untag_object(array),i + 1));
+				GROWABLE_ARRAY_ADD(literals,array_nth(untag_object(array),i));
+				GROWABLE_ARRAY_ADD(literals,array_nth(untag_object(array),i + 1));
 				EMIT(JIT_IF_JUMP,literals_count - 2);
 
 				i += 2;
@@ -191,7 +186,7 @@ void jit_compile(CELL quot, bool relocate)
 				if(stack_frame)
 					EMIT(JIT_EPILOG,0);
 
-				GROWABLE_ADD(literals,array_nth(untag_object(array),i));
+				GROWABLE_ARRAY_ADD(literals,array_nth(untag_object(array),i));
 				EMIT(JIT_DISPATCH,literals_count - 1);
 
 				i++;
@@ -200,7 +195,7 @@ void jit_compile(CELL quot, bool relocate)
 				break;
 			}
 		default:
-			GROWABLE_ADD(literals,obj);
+			GROWABLE_ARRAY_ADD(literals,obj);
 			EMIT(JIT_PUSH_LITERAL,literals_count - 1);
 			break;
 		}
@@ -214,15 +209,15 @@ void jit_compile(CELL quot, bool relocate)
 		EMIT(JIT_RETURN,0);
 	}
 
-	GROWABLE_TRIM(code);
-	GROWABLE_TRIM(relocation);
-	GROWABLE_TRIM(literals);
+	GROWABLE_ARRAY_TRIM(code);
+	GROWABLE_ARRAY_TRIM(literals);
+	GROWABLE_BYTE_ARRAY_TRIM(relocation);
 
 	F_COMPILED *compiled = add_compiled_block(
 		QUOTATION_TYPE,
 		untag_object(code),
 		NULL,
-		untag_object(relocation),
+		relocation,
 		untag_object(literals));
 
 	set_quot_xt(untag_object(quot),compiled);
diff --git a/vm/types.c b/vm/types.c
index b4e5269f4e..adfdea41a5 100755
--- a/vm/types.c
+++ b/vm/types.c
@@ -197,7 +197,7 @@ DEFINE_PRIMITIVE(resize_array)
 	dpush(tag_object(reallot_array(array,capacity,F)));
 }
 
-F_ARRAY *growable_add(F_ARRAY *result, CELL elt, CELL *result_count)
+F_ARRAY *growable_array_add(F_ARRAY *result, CELL elt, CELL *result_count)
 {
 	REGISTER_ROOT(elt);
 
@@ -209,12 +209,12 @@ F_ARRAY *growable_add(F_ARRAY *result, CELL elt, CELL *result_count)
 
 	UNREGISTER_ROOT(elt);
 	set_array_nth(result,*result_count,elt);
-	*result_count = *result_count + 1;
+	(*result_count)++;
 
 	return result;
 }
 
-F_ARRAY *growable_append(F_ARRAY *result, F_ARRAY *elts, CELL *result_count)
+F_ARRAY *growable_array_append(F_ARRAY *result, F_ARRAY *elts, CELL *result_count)
 {
 	REGISTER_UNTAGGED(elts);
 
@@ -228,7 +228,7 @@ F_ARRAY *growable_append(F_ARRAY *result, F_ARRAY *elts, CELL *result_count)
 
 	write_barrier((CELL)result);
 
-	memcpy((void*)AREF(result,*result_count),(void*)AREF(elts,0),elts_size * CELLS);
+	memcpy((void *)AREF(result,*result_count),(void *)AREF(elts,0),elts_size * CELLS);
 
 	*result_count += elts_size;
 
@@ -283,6 +283,33 @@ DEFINE_PRIMITIVE(resize_byte_array)
 	dpush(tag_object(reallot_byte_array(array,capacity)));
 }
 
+F_BYTE_ARRAY *growable_byte_array_add(F_BYTE_ARRAY *result, CELL elt, CELL *result_count)
+{
+	if(*result_count == byte_array_capacity(result))
+	{
+		result = reallot_byte_array(result,*result_count * 2);
+	}
+
+	bput(BREF(result,*result_count),elt);
+	*result_count++;
+
+	return result;
+}
+
+F_BYTE_ARRAY *growable_byte_array_append(F_BYTE_ARRAY *result, void *elts, CELL len, CELL *result_count)
+{
+	CELL new_size = *result_count + len;
+
+	if(new_size >= byte_array_capacity(result))
+		result = reallot_byte_array(result,new_size * 2);
+
+	memcpy((void *)BREF(result,*result_count),elts,len);
+
+	*result_count = new_size;
+
+	return result;
+}
+
 /* Bit arrays */
 
 /* size is in bits */
diff --git a/vm/types.h b/vm/types.h
index 3ce1838b8b..bbf7fb203d 100755
--- a/vm/types.h
+++ b/vm/types.h
@@ -146,6 +146,7 @@ DECLARE_PRIMITIVE(float_array);
 DECLARE_PRIMITIVE(clone);
 
 F_ARRAY *reallot_array(F_ARRAY* array, CELL capacity, CELL fill);
+F_BYTE_ARRAY *reallot_byte_array(F_BYTE_ARRAY *array, CELL capacity);
 DECLARE_PRIMITIVE(resize_array);
 DECLARE_PRIMITIVE(resize_byte_array);
 DECLARE_PRIMITIVE(resize_bit_array);
@@ -193,15 +194,33 @@ DECLARE_PRIMITIVE(wrapper);
 	CELL result##_count = 0; \
 	CELL result = tag_object(allot_array(ARRAY_TYPE,100,F))
 
-F_ARRAY *growable_add(F_ARRAY *result, CELL elt, CELL *result_count);
+F_ARRAY *growable_array_add(F_ARRAY *result, CELL elt, CELL *result_count);
 
-#define GROWABLE_ADD(result,elt) \
-	result = tag_object(growable_add(untag_object(result),elt,&result##_count))
+#define GROWABLE_ARRAY_ADD(result,elt) \
+	result = tag_object(growable_array_add(untag_object(result),elt,&result##_count))
 
-F_ARRAY *growable_append(F_ARRAY *result, F_ARRAY *elts, CELL *result_count);
+F_ARRAY *growable_array_append(F_ARRAY *result, F_ARRAY *elts, CELL *result_count);
 
-#define GROWABLE_APPEND(result,elts) \
-	result = tag_object(growable_append(untag_object(result),elts,&result##_count))
+#define GROWABLE_ARRAY_APPEND(result,elts) \
+	result = tag_object(growable_array_append(untag_object(result),elts,&result##_count))
 
-#define GROWABLE_TRIM(result) \
+#define GROWABLE_ARRAY_TRIM(result) \
 	result = tag_object(reallot_array(untag_object(result),result##_count,F))
+
+/* Macros to simulate a byte vector in C */
+#define GROWABLE_BYTE_ARRAY(result) \
+	CELL result##_count = 0; \
+	CELL result = tag_object(allot_byte_array(100))
+
+F_ARRAY *growable_byte_array_add(F_BYTE_ARRAY *result, CELL elt, CELL *result_count);
+
+#define GROWABLE_BYTE_ARRAY_ADD(result,elt) \
+	result = tag_object(growable_byte_array_add(untag_object(result),elt,&result##_count))
+
+F_ARRAY *growable_byte_array_append(F_BYTE_ARRAY *result, void *elts, CELL len, CELL *result_count);
+
+#define GROWABLE_BYTE_ARRAY_APPEND(result,elts,len) \
+	result = tag_object(growable_byte_array_append(untag_object(result),elts,len,&result##_count))
+
+#define GROWABLE_BYTE_ARRAY_TRIM(result) \
+	result = tag_object(reallot_byte_array(untag_object(result),result##_count))