Merge branch 'master' of git://factorcode.org/git/factor
Matthew Willis
commit
4f9c3d720a
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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 )
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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* } ":"
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
<definitions> new-definitions set
|
||||
<definitions> old-definitions set
|
||||
[ finish-compilation-unit ]
|
||||
[ ] cleanup
|
||||
[
|
||||
finish-compilation-unit
|
||||
updated-definitions
|
||||
notify-definition-observers
|
||||
] [ ] cleanup
|
||||
] with-scope ; inline
|
||||
|
||||
: compile-call ( quot -- )
|
||||
|
|
|
|||
|
|
@ -1,4 +1,4 @@
|
|||
USING: help.markup help.syntax kernel quotations ;
|
||||
USING: help.markup help.syntax kernel quotations dlists.private ;
|
||||
IN: dlists
|
||||
|
||||
ARTICLE: "dlists" "Doubly-linked lists"
|
||||
|
|
@ -51,38 +51,52 @@ HELP: dlist-empty?
|
|||
HELP: push-front
|
||||
{ $values { "obj" "an object" } { "dlist" dlist } }
|
||||
{ $description "Push the object onto the front of the " { $link dlist } "." }
|
||||
{ $notes "This operation is O(1)." }
|
||||
{ $see-also push-back pop-front pop-front* pop-back pop-back* } ;
|
||||
{ $notes "This operation is O(1)." } ;
|
||||
|
||||
HELP: push-front*
|
||||
{ $values { "obj" "an object" } { "dlist" dlist } { "dlist-node" dlist-node } }
|
||||
{ $description "Push the object onto the front of the " { $link dlist } " and return the newly created " { $snippet "dlist-node" } "." }
|
||||
{ $notes "This operation is O(1)." } ;
|
||||
|
||||
HELP: push-back
|
||||
{ $values { "obj" "an object" } { "dlist" dlist } }
|
||||
{ $description "Push the object onto the back of the " { $link dlist } "." }
|
||||
{ $notes "This operation is O(1)." }
|
||||
{ $see-also push-front pop-front pop-front* pop-back pop-back* } ;
|
||||
{ $notes "This operation is O(1)." } ;
|
||||
|
||||
HELP: push-back*
|
||||
{ $values { "obj" "an object" } { "dlist" dlist } { "dlist-node" dlist-node } }
|
||||
{ $description "Push the object onto the back of the " { $link dlist } " and return the newly created " { $snippet "dlist-node" } "." }
|
||||
{ $notes "This operation is O(1)." } ;
|
||||
|
||||
HELP: peek-front
|
||||
{ $values { "dlist" dlist } { "obj" "an object" } }
|
||||
{ $description "Returns the object at the front of the " { $link dlist } "." } ;
|
||||
|
||||
HELP: pop-front
|
||||
{ $values { "dlist" dlist } { "obj" "an object" } }
|
||||
{ $description "Pop the object off the front of the " { $link dlist } " and return the object." }
|
||||
{ $notes "This operation is O(1)." }
|
||||
{ $see-also push-front push-back pop-front* pop-back pop-back* } ;
|
||||
{ $notes "This operation is O(1)." } ;
|
||||
|
||||
HELP: pop-front*
|
||||
{ $values { "dlist" dlist } }
|
||||
{ $description "Pop the object off the front of the " { $link dlist } "." }
|
||||
{ $notes "This operation is O(1)." }
|
||||
{ $see-also push-front push-back pop-front pop-back pop-back* } ;
|
||||
{ $notes "This operation is O(1)." } ;
|
||||
|
||||
HELP: peek-back
|
||||
{ $values { "dlist" dlist } { "obj" "an object" } }
|
||||
{ $description "Returns the object at the back of the " { $link dlist } "." } ;
|
||||
|
||||
HELP: pop-back
|
||||
{ $values { "dlist" dlist } { "obj" "an object" } }
|
||||
{ $description "Pop the object off the back of the " { $link dlist } " and return the object." }
|
||||
{ $notes "This operation is O(1)." }
|
||||
{ $see-also push-front push-back pop-front pop-front* pop-back* } ;
|
||||
{ $notes "This operation is O(1)." } ;
|
||||
|
||||
HELP: pop-back*
|
||||
{ $values { "dlist" dlist } }
|
||||
{ $description "Pop the object off the back of the " { $link dlist } "." }
|
||||
{ $notes "This operation is O(1)." }
|
||||
{ $see-also push-front push-back pop-front pop-front* pop-back } ;
|
||||
{ $notes "This operation is O(1)." } ;
|
||||
|
||||
{ push-front push-front* push-back push-back* peek-front pop-front pop-front* peek-back pop-back pop-back* } related-words
|
||||
|
||||
HELP: dlist-find
|
||||
{ $values { "dlist" { $link dlist } } { "quot" quotation } { "obj/f" "an object or " { $link f } } { "?" "a boolean" } }
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
USING: dlists dlists.private kernel tools.test random assocs
|
||||
sets sequences namespaces sorting debugger io prettyprint
|
||||
math ;
|
||||
math accessors classes ;
|
||||
IN: dlists.tests
|
||||
|
||||
[ t ] [ <dlist> dlist-empty? ] unit-test
|
||||
|
|
@ -65,20 +65,17 @@ IN: dlists.tests
|
|||
: assert-same-elements
|
||||
[ prune natural-sort ] bi@ assert= ;
|
||||
|
||||
: dlist-push-all [ push-front ] curry each ;
|
||||
|
||||
: dlist-delete-all [ dlist-delete drop ] curry each ;
|
||||
|
||||
: dlist>array [ [ , ] dlist-slurp ] { } make ;
|
||||
|
||||
[ ] [
|
||||
5 [ drop 30 random >fixnum ] map prune
|
||||
6 [ drop 30 random >fixnum ] map prune 2dup nl . . nl
|
||||
[
|
||||
6 [ drop 30 random >fixnum ] map prune [
|
||||
<dlist>
|
||||
[ dlist-push-all ] keep
|
||||
[ dlist-delete-all ] keep
|
||||
dlist>array
|
||||
[ push-all-front ]
|
||||
[ dlist-delete-all ]
|
||||
[ dlist>array ] tri
|
||||
] 2keep swap diff assert-same-elements
|
||||
] unit-test
|
||||
|
||||
|
|
@ -95,3 +92,13 @@ IN: dlists.tests
|
|||
|
||||
[ 1 ] [ "d" get dlist-length ] unit-test
|
||||
[ 1 ] [ "d" get dlist>array length ] unit-test
|
||||
|
||||
[ t ] [ <dlist> 4 over push-back 5 over push-back [ obj>> 4 = ] dlist-find-node drop class dlist-node = ] unit-test
|
||||
[ t ] [ <dlist> 4 over push-back 5 over push-back [ obj>> 5 = ] dlist-find-node drop class dlist-node = ] unit-test
|
||||
[ t ] [ <dlist> 4 over push-back 5 over push-back* [ = ] curry dlist-find-node drop class dlist-node = ] unit-test
|
||||
[ ] [ <dlist> 4 over push-back 5 over push-back [ drop ] dlist-each ] unit-test
|
||||
|
||||
[ <dlist> peek-front ] must-fail
|
||||
[ <dlist> peek-back ] must-fail
|
||||
[ <dlist> pop-front ] [ empty-dlist? ] must-fail-with
|
||||
[ <dlist> pop-back ] [ empty-dlist? ] must-fail-with
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
! Copyright (C) 2007, 2008 Mackenzie Straight, Doug Coleman,
|
||||
! Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: combinators kernel math sequences accessors ;
|
||||
USING: combinators kernel math sequences accessors inspector ;
|
||||
IN: dlists
|
||||
|
||||
TUPLE: dlist front back length ;
|
||||
|
|
@ -47,7 +47,7 @@ C: <dlist-node> dlist-node
|
|||
|
||||
: (dlist-find-node) ( dlist-node quot -- node/f ? )
|
||||
over [
|
||||
[ >r obj>> r> call ] 2keep rot
|
||||
[ call ] 2keep rot
|
||||
[ drop t ] [ >r next>> r> (dlist-find-node) ] if
|
||||
] [ 2drop f f ] if ; inline
|
||||
|
||||
|
|
@ -55,7 +55,7 @@ C: <dlist-node> dlist-node
|
|||
>r front>> r> (dlist-find-node) ; inline
|
||||
|
||||
: dlist-each-node ( dlist quot -- )
|
||||
[ t ] compose dlist-find-node 2drop ; inline
|
||||
[ f ] compose dlist-find-node 2drop ; inline
|
||||
|
||||
PRIVATE>
|
||||
|
||||
|
|
@ -84,11 +84,17 @@ PRIVATE>
|
|||
: push-all-back ( seq dlist -- )
|
||||
[ push-back ] curry each ;
|
||||
|
||||
ERROR: empty-dlist ;
|
||||
|
||||
M: empty-dlist summary ( dlist -- )
|
||||
drop "Emtpy dlist" ;
|
||||
|
||||
: peek-front ( dlist -- obj )
|
||||
front>> obj>> ;
|
||||
front>> [ empty-dlist ] unless* obj>> ;
|
||||
|
||||
: pop-front ( dlist -- obj )
|
||||
dup front>> [
|
||||
dup front>> [ empty-dlist ] unless*
|
||||
[
|
||||
dup next>>
|
||||
f rot (>>next)
|
||||
f over set-prev-when
|
||||
|
|
@ -96,13 +102,15 @@ PRIVATE>
|
|||
] 2keep obj>>
|
||||
swap [ normalize-back ] keep dec-length ;
|
||||
|
||||
: pop-front* ( dlist -- ) pop-front drop ;
|
||||
: pop-front* ( dlist -- )
|
||||
pop-front drop ;
|
||||
|
||||
: peek-back ( dlist -- obj )
|
||||
back>> obj>> ;
|
||||
back>> [ empty-dlist ] unless* obj>> ;
|
||||
|
||||
: pop-back ( dlist -- obj )
|
||||
dup back>> [
|
||||
dup back>> [ empty-dlist ] unless*
|
||||
[
|
||||
dup prev>>
|
||||
f rot (>>prev)
|
||||
f over set-next-when
|
||||
|
|
@ -110,9 +118,11 @@ PRIVATE>
|
|||
] 2keep obj>>
|
||||
swap [ normalize-front ] keep dec-length ;
|
||||
|
||||
: pop-back* ( dlist -- ) pop-back drop ;
|
||||
: pop-back* ( dlist -- )
|
||||
pop-back drop ;
|
||||
|
||||
: dlist-find ( dlist quot -- obj/f ? )
|
||||
[ obj>> ] prepose
|
||||
dlist-find-node [ obj>> t ] [ drop f f ] if ; inline
|
||||
|
||||
: dlist-contains? ( dlist quot -- ? )
|
||||
|
|
@ -141,6 +151,7 @@ PRIVATE>
|
|||
] if ; inline
|
||||
|
||||
: delete-node-if ( dlist quot -- obj/f )
|
||||
[ obj>> ] prepose
|
||||
delete-node-if* drop ; inline
|
||||
|
||||
: dlist-delete ( obj dlist -- obj/f )
|
||||
|
|
|
|||
|
|
@ -1,12 +1,12 @@
|
|||
USING: help.syntax help.markup generator.fixup math kernel
|
||||
words strings alien ;
|
||||
words strings alien byte-array ;
|
||||
|
||||
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" } }
|
||||
{ $values { "arg" integer } { "class" "a relocation class" } { "type" "a relocation type" } { "offset" integer } { "byte-array" byte-array } }
|
||||
{ $description "Creates a relocation instruction for the VM's runtime compiled code linker." } ;
|
||||
|
||||
HELP: add-literal
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
|
|
|||
|
|
@ -22,8 +22,7 @@ C: <predicate-dispatch-engine> 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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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."
|
||||
|
|
|
|||
|
|
@ -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"
|
||||
<string-reader> "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 ;"
|
||||
<string-reader> "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 ;"
|
||||
<string-reader> "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
|
||||
|
|
|
|||
|
|
@ -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 {
|
||||
|
|
|
|||
|
|
@ -342,3 +342,5 @@ INTERSECTION: intersection-see-test sequence number ;
|
|||
|
||||
[ ] [ \ compose see ] unit-test
|
||||
[ ] [ \ curry see ] unit-test
|
||||
|
||||
[ "POSTPONE: [" ] [ \ [ unparse ] unit-test
|
||||
|
|
|
|||
|
|
@ -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 } }
|
||||
|
|
|
|||
|
|
@ -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 <sbuf> dup "1234" swap push-all dup dup swap push-all
|
||||
|
|
|
|||
|
|
@ -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 )
|
||||
|
|
|
|||
|
|
@ -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." }
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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 <hashtable> ] [ length <vector> ] 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 <hashtable> [ (all-unique?) ] curry all? ;
|
||||
|
|
|
|||
|
|
@ -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 <groups> }
|
||||
{ $subsection <sliced-groups> }
|
||||
"A virtual sequence for splitting a sequence into overlapping, fixed-length subsequences:"
|
||||
{ $subsection clumps }
|
||||
{ $subsection <clumps> }
|
||||
{ $subsection <sliced-clumps> }
|
||||
"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 <groups> }
|
||||
{ $subsection <sliced-groups> }
|
||||
"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 <groups> } " and " { $link <sliced-groups> } "." }
|
||||
{ $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: <groups>
|
||||
{ $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: <groups>
|
|||
|
||||
HELP: <sliced-groups>
|
||||
{ $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: <sliced-groups>
|
|||
}
|
||||
} ;
|
||||
|
||||
{ group <groups> <sliced-groups> } 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 <clumps> } " and " { $link <sliced-clumps> } "." } ;
|
||||
|
||||
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: <clumps>
|
||||
{ $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 <clumps> [ [ sum ] [ length ] bi / ] map ."
|
||||
"{ 113/400 167/400 201/400 241/400 243/400 91/200 1/4 }"
|
||||
}
|
||||
} ;
|
||||
|
||||
HELP: <sliced-clumps>
|
||||
{ $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
|
||||
|
||||
{ <clumps> <groups> } related-words
|
||||
|
||||
{ <sliced-clumps> <sliced-groups> } related-words
|
||||
|
||||
HELP: ?head
|
||||
{ $values { "seq" "a sequence" } { "begin" "a sequence" } { "newseq" "a new sequence" } { "?" "a boolean" } }
|
||||
|
|
|
|||
|
|
@ -44,7 +44,7 @@ M: sliced-groups nth group@ <slice> ;
|
|||
|
||||
TUPLE: clumps < abstract-groups ;
|
||||
|
||||
: <clumps> ( seq n -- groups )
|
||||
: <clumps> ( seq n -- clumps )
|
||||
clumps construct-groups ; inline
|
||||
|
||||
M: clumps length
|
||||
|
|
@ -58,7 +58,7 @@ M: clumps group@
|
|||
|
||||
TUPLE: sliced-clumps < groups ;
|
||||
|
||||
: <sliced-clumps> ( seq n -- groups )
|
||||
: <sliced-clumps> ( seq n -- clumps )
|
||||
sliced-clumps construct-groups ; inline
|
||||
|
||||
M: sliced-clumps nth group@ <slice> ;
|
||||
|
|
|
|||
|
|
@ -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" [
|
||||
|
|
|
|||
|
|
@ -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"
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
<timestamp> ;
|
||||
|
||||
|
|
|
|||
|
|
@ -27,3 +27,15 @@ circular strings ;
|
|||
! This no longer fails
|
||||
! [ "test" <circular> 5 swap nth ] must-fail
|
||||
! [ "foo" <circular> CHAR: b 3 rot set-nth ] must-fail
|
||||
|
||||
[ { } ] [ 3 <growing-circular> >array ] unit-test
|
||||
[ { 1 2 } ] [
|
||||
3 <growing-circular>
|
||||
[ 1 swap push-growing-circular ] keep
|
||||
[ 2 swap push-growing-circular ] keep >array
|
||||
] unit-test
|
||||
[ { 3 4 5 } ] [
|
||||
3 <growing-circular> dup { 1 2 3 4 5 } [
|
||||
swap push-growing-circular
|
||||
] with each >array
|
||||
] unit-test
|
||||
|
|
|
|||
|
|
@ -19,10 +19,6 @@ M: circular length seq>> length ;
|
|||
|
||||
M: circular virtual@ circular-wrap seq>> ;
|
||||
|
||||
M: circular nth virtual@ nth ;
|
||||
|
||||
M: circular set-nth virtual@ set-nth ;
|
||||
|
||||
M: circular virtual-seq seq>> ;
|
||||
|
||||
: change-circular-start ( n circular -- )
|
||||
|
|
@ -36,3 +32,20 @@ M: circular virtual-seq seq>> ;
|
|||
0 <string> <circular> ;
|
||||
|
||||
INSTANCE: circular virtual-sequence
|
||||
|
||||
TUPLE: growing-circular < circular length ;
|
||||
|
||||
M: growing-circular length length>> ;
|
||||
|
||||
: full? ( circular -- ? )
|
||||
[ length ] [ seq>> length ] bi = ;
|
||||
|
||||
: set-peek ( elt seq -- )
|
||||
[ length 1- ] keep set-nth ;
|
||||
|
||||
: push-growing-circular ( elt circular -- )
|
||||
dup full? [ push-circular ]
|
||||
[ [ 1+ ] change-length set-peek ] if ;
|
||||
|
||||
: <growing-circular> ( capacity -- growing-circular )
|
||||
{ } new-sequence 0 0 growing-circular boa ;
|
||||
|
|
|
|||
|
|
@ -23,7 +23,7 @@ HELP: ndip
|
|||
{ $example "USING: combinators.lib kernel prettyprint ;" "1 2 [ dup ] 1 ndip .s" "1\n1\n2" }
|
||||
{ $example "USING: combinators.lib kernel prettyprint ;" "1 2 3 [ drop ] 2 ndip .s" "2\n3" }
|
||||
}
|
||||
{ $see-also dip dipd } ;
|
||||
{ $see-also dip 2dip } ;
|
||||
|
||||
HELP: nslip
|
||||
{ $values { "n" number } }
|
||||
|
|
|
|||
|
|
@ -5,9 +5,6 @@ IN: combinators.lib.tests
|
|||
[ 5 ] [ [ 10 random ] [ 5 = ] generate ] unit-test
|
||||
[ t ] [ [ 10 random ] [ even? ] generate even? ] unit-test
|
||||
|
||||
{ 6 2 } [ 1 2 [ 5 + ] dip ] unit-test
|
||||
{ 6 2 1 } [ 1 2 1 [ 5 + ] dipd ] unit-test
|
||||
|
||||
[ [ 99 ] 1 2 3 4 5 5 nslip ] must-infer
|
||||
{ 99 1 2 3 4 5 } [ [ 99 ] 1 2 3 4 5 5 nslip ] unit-test
|
||||
[ 1 2 3 4 5 [ drop drop drop drop drop 2 ] 5 nkeep ] must-infer
|
||||
|
|
|
|||
|
|
@ -38,8 +38,6 @@ MACRO: napply ( n -- )
|
|||
|
||||
: 3apply ( obj obj obj quot -- ) 3 napply ; inline
|
||||
|
||||
: dipd ( x y quot -- y ) 2 ndip ; inline
|
||||
|
||||
: 2with ( param1 param2 obj quot -- obj curry )
|
||||
with with ; inline
|
||||
|
||||
|
|
@ -79,8 +77,21 @@ MACRO: <--&& ( quots -- )
|
|||
[ [ 2dup ] prepend [ not ] append [ f ] ] t short-circuit
|
||||
[ 2nip ] append ;
|
||||
|
||||
! or
|
||||
|
||||
MACRO: || ( quots -- ? ) [ [ t ] ] f short-circuit ;
|
||||
|
||||
MACRO: 0|| ( quots -- ? ) [ [ t ] ] f short-circuit ;
|
||||
|
||||
MACRO: 1|| ( quots -- ? )
|
||||
[ [ dup ] prepend [ t ] ] f short-circuit [ nip ] append ;
|
||||
|
||||
MACRO: 2|| ( quots -- ? )
|
||||
[ [ 2dup ] prepend [ t ] ] f short-circuit [ 2nip ] append ;
|
||||
|
||||
MACRO: 3|| ( quots -- ? )
|
||||
[ [ 2dup ] prepend [ t ] ] f short-circuit [ 2nip ] append ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
! ifte
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
|
|
|||
|
|
@ -127,7 +127,7 @@ M: nonthrowable execute-statement* ( statement type -- )
|
|||
: query-map ( statement quot -- seq )
|
||||
accumulator >r query-each r> { } like ; inline
|
||||
|
||||
: with-db ( db seq quot -- )
|
||||
: with-db ( seq class quot -- )
|
||||
>r make-db db-open db r>
|
||||
[ db get swap [ drop ] prepose with-disposal ] curry with-variable ;
|
||||
inline
|
||||
|
|
|
|||
|
|
@ -6,16 +6,16 @@ IN: db.pools
|
|||
|
||||
TUPLE: db-pool < pool db params ;
|
||||
|
||||
: <db-pool> ( db params -- pool )
|
||||
: <db-pool> ( params db -- pool )
|
||||
db-pool <pool>
|
||||
swap >>params
|
||||
swap >>db ;
|
||||
swap >>db
|
||||
swap >>params ;
|
||||
|
||||
: with-db-pool ( db params quot -- )
|
||||
>r <db-pool> 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
|
||||
|
|
|
|||
|
|
@ -414,6 +414,25 @@ TUPLE: does-not-persist ;
|
|||
[ class \ not-persistent = ] must-fail-with
|
||||
] test-postgresql
|
||||
|
||||
|
||||
TUPLE: suparclass a ;
|
||||
|
||||
suparclass f {
|
||||
{ "id" "ID" +db-assigned-id+ }
|
||||
{ "a" "A" INTEGER }
|
||||
} define-persistent
|
||||
|
||||
TUPLE: subbclass < suparclass b ;
|
||||
|
||||
subbclass "SUBCLASS" {
|
||||
{ "b" "B" TEXT }
|
||||
} define-persistent
|
||||
|
||||
: test-db-inheritance ( -- )
|
||||
[ ] [ subbclass ensure-table ] unit-test ;
|
||||
|
||||
[ test-db-inheritance ] test-sqlite
|
||||
|
||||
! Don't comment these out. These words must infer
|
||||
\ bind-tuple must-infer
|
||||
\ insert-tuple must-infer
|
||||
|
|
|
|||
|
|
@ -19,7 +19,7 @@ ERROR: not-persistent ;
|
|||
"db-table" word-prop [ not-persistent ] unless* ;
|
||||
|
||||
: db-columns ( class -- obj )
|
||||
"db-columns" word-prop ;
|
||||
superclasses [ "db-columns" word-prop ] map concat ;
|
||||
|
||||
: db-relations ( class -- obj )
|
||||
"db-relations" word-prop ;
|
||||
|
|
|
|||
|
|
@ -47,15 +47,9 @@ TUPLE: entry time data ;
|
|||
|
||||
SYMBOL: NX
|
||||
|
||||
: cache-nx ( query ttl -- )
|
||||
ttl->time NX entry boa
|
||||
table-add ;
|
||||
: cache-nx ( query ttl -- ) ttl->time NX entry boa table-add ;
|
||||
|
||||
: nx? ( obj -- ? )
|
||||
dup entry?
|
||||
[ data>> NX = ]
|
||||
[ drop f ]
|
||||
if ;
|
||||
: nx? ( obj -- ? ) dup entry? [ data>> NX = ] [ drop f ] if ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
|
|
@ -72,32 +66,29 @@ SYMBOL: NX
|
|||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: entry-expired? ( entry -- ? ) time>> time->ttl 0 <= ;
|
||||
: expired? ( entry -- ? ) time>> time->ttl 0 <= ;
|
||||
|
||||
: cache-get ( query -- result )
|
||||
: cache-get* ( query -- rrs/NX/f )
|
||||
dup table-get ! query result
|
||||
{
|
||||
{
|
||||
[ dup f = ] ! not in the cache
|
||||
[ 2drop f ]
|
||||
}
|
||||
{
|
||||
[ dup entry-expired? ] ! here but expired
|
||||
[ drop table-rem f ]
|
||||
}
|
||||
{
|
||||
[ dup nx? ] ! negative result has been cached
|
||||
[ 2drop NX ]
|
||||
}
|
||||
{
|
||||
[ t ]
|
||||
[ query+entry->rrs ]
|
||||
}
|
||||
{ [ dup f = ] [ 2drop f ] } ! not in the cache
|
||||
{ [ dup expired? ] [ drop table-rem f ] } ! here but expired
|
||||
{ [ dup nx? ] [ 2drop NX ] } ! negative result cached
|
||||
{ [ t ] [ query+entry->rrs ] } ! good to go
|
||||
}
|
||||
cond ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
ERROR: name-error name ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: cache-get ( query -- rrs/f )
|
||||
dup cache-get* dup NX = [ drop name>> name-error ] [ nip ] if ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: rr->entry ( rr -- entry )
|
||||
[ ttl>> ttl->time ] [ rdata>> {1} >vector ] bi entry boa ;
|
||||
|
||||
|
|
@ -114,22 +105,10 @@ SYMBOL: NX
|
|||
: cache-add ( query rr -- )
|
||||
over table-get ! query rr entry
|
||||
{
|
||||
{
|
||||
[ dup f = ] ! not in the cache
|
||||
[ drop rr->entry table-add ]
|
||||
}
|
||||
{
|
||||
[ dup nx? ]
|
||||
[ drop over table-rem rr->entry table-add ]
|
||||
}
|
||||
{
|
||||
[ dup entry-expired? ]
|
||||
[ drop rr->entry table-add ]
|
||||
}
|
||||
{
|
||||
[ t ]
|
||||
[ rot drop add-rr-to-entry ]
|
||||
}
|
||||
{ [ dup f = ] [ drop rr->entry table-add ] }
|
||||
{ [ dup nx? ] [ drop over table-rem rr->entry table-add ] }
|
||||
{ [ dup expired? ] [ drop rr->entry table-add ] }
|
||||
{ [ t ] [ rot drop add-rr-to-entry ] }
|
||||
}
|
||||
cond ;
|
||||
|
||||
|
|
@ -140,3 +119,31 @@ SYMBOL: NX
|
|||
: cache-add-rr ( rr -- ) [ rr->query ] [ ] bi cache-add ;
|
||||
|
||||
: cache-add-rrs ( rrs -- ) [ cache-add-rr ] each ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
! cache-name-error
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: message-soa ( message -- rr/soa )
|
||||
authority-section>> [ type>> SOA = ] filter 1st ;
|
||||
|
||||
: cache-name-error ( message -- message )
|
||||
dup
|
||||
[ message-query ] [ message-soa ttl>> ] bi
|
||||
cache-nx ;
|
||||
|
||||
: cache-message-records ( message -- message )
|
||||
dup
|
||||
{
|
||||
[ answer-section>> cache-add-rrs ]
|
||||
[ authority-section>> cache-add-rrs ]
|
||||
[ additional-section>> cache-add-rrs ]
|
||||
}
|
||||
cleave ;
|
||||
|
||||
: cache-message ( message -- message )
|
||||
dup rcode>> NAME-ERROR = [ cache-name-error ] when
|
||||
cache-message-records ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
|
|
|
|||
|
|
@ -38,7 +38,7 @@ TUPLE: message
|
|||
! TYPE
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
SYMBOLS: A NS MD MF CNAME SOA MB MG MR NULL WKS PTR HINFO MINFO MX TXT ;
|
||||
SYMBOLS: A NS MD MF CNAME SOA MB MG MR NULL WKS PTR HINFO MINFO MX TXT AAAA ;
|
||||
|
||||
: type-table ( -- table )
|
||||
{
|
||||
|
|
@ -58,6 +58,7 @@ SYMBOLS: A NS MD MF CNAME SOA MB MG MR NULL WKS PTR HINFO MINFO MX TXT ;
|
|||
{ MINFO 14 }
|
||||
{ MX 15 }
|
||||
{ TXT 16 }
|
||||
{ AAAA 28 }
|
||||
} ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
|
@ -126,6 +127,8 @@ SYMBOLS: NO-ERROR FORMAT-ERROR SERVER-FAILURE NAME-ERROR NOT-IMPLEMENTED
|
|||
|
||||
: ip->ba ( ip -- ba ) "." split [ string>number ] map >byte-array ;
|
||||
|
||||
: ipv6->ba ( ip -- ba ) ":" split [ 16 base> ] map [ 2 >be ] map concat ;
|
||||
|
||||
: label->ba ( label -- ba ) [ >byte-array ] [ length ] bi prefix ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
|
@ -330,6 +333,13 @@ SYMBOLS: NO-ERROR FORMAT-ERROR SERVER-FAILURE NAME-ERROR NOT-IMPLEMENTED
|
|||
|
||||
: get-ip ( ba i -- ip ) dup 4 + subseq >array [ number>string ] map "." join ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: get-ipv6 ( ba i -- ip )
|
||||
dup 16 + subseq 2 group [ be> 16 >base ] map ":" join ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: get-rdata ( ba i type -- rdata )
|
||||
{
|
||||
{ CNAME [ get-name ] }
|
||||
|
|
@ -338,6 +348,7 @@ SYMBOLS: NO-ERROR FORMAT-ERROR SERVER-FAILURE NAME-ERROR NOT-IMPLEMENTED
|
|||
{ MX [ get-mx ] }
|
||||
{ SOA [ get-soa ] }
|
||||
{ A [ get-ip ] }
|
||||
{ AAAA [ get-ipv6 ] }
|
||||
}
|
||||
case ;
|
||||
|
||||
|
|
@ -459,4 +470,9 @@ SYMBOLS: NO-ERROR FORMAT-ERROR SERVER-FAILURE NAME-ERROR NOT-IMPLEMENTED
|
|||
|
||||
: ask ( message -- message ) dns-server ask-server ;
|
||||
|
||||
: <query-message> ( query -- message ) <message> swap {1} >>question-section ;
|
||||
: query->message ( query -- message ) <message> swap {1} >>question-section ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: message-query ( message -- query ) question-section>> 1st ;
|
||||
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
|
@ -6,6 +6,8 @@ IN: dns.resolver
|
|||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
! Need to cache records even in the case of name error
|
||||
|
||||
: cache-message ( message -- message )
|
||||
dup dup rcode>> NAME-ERROR =
|
||||
[
|
||||
|
|
@ -60,7 +62,7 @@ IN: dns.resolver
|
|||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: canonical/server ( name -- name )
|
||||
dup CNAME IN query boa <query-message> ask* answer-section>>
|
||||
dup CNAME IN query boa query->message ask* answer-section>>
|
||||
[ type>> CNAME = ] filter dup empty? not
|
||||
[ nip 1st rdata>> ]
|
||||
[ drop ]
|
||||
|
|
@ -68,7 +70,7 @@ IN: dns.resolver
|
|||
|
||||
: name->ip/server ( name -- ip )
|
||||
canonical/server
|
||||
dup A IN query boa <query-message> ask* answer-section>>
|
||||
dup A IN query boa query->message ask* answer-section>>
|
||||
[ type>> A = ] filter dup empty? not
|
||||
[ nip random rdata>> ]
|
||||
[ 2drop f ]
|
||||
|
|
|
|||
|
|
@ -16,10 +16,18 @@ IN: farkup.tests
|
|||
[ "<p>**</p>" ] [ "\\**" convert-farkup ] unit-test
|
||||
|
||||
[ "" ] [ "\n\n" convert-farkup ] unit-test
|
||||
[ "" ] [ "\r\n\r\n" convert-farkup ] unit-test
|
||||
[ "" ] [ "\r\r\r\r" convert-farkup ] unit-test
|
||||
[ "\n" ] [ "\r\r\r" convert-farkup ] unit-test
|
||||
[ "\n" ] [ "\n\n\n" convert-farkup ] unit-test
|
||||
[ "<p>foo</p><p>bar</p>" ] [ "foo\n\nbar" convert-farkup ] unit-test
|
||||
[ "<p>foo</p><p>bar</p>" ] [ "foo\r\n\r\nbar" convert-farkup ] unit-test
|
||||
[ "<p>foo</p><p>bar</p>" ] [ "foo\r\rbar" convert-farkup ] unit-test
|
||||
[ "<p>foo</p><p>bar</p>" ] [ "foo\r\r\nbar" convert-farkup ] unit-test
|
||||
|
||||
[ "\n<p>bar\n</p>" ] [ "\nbar\n" convert-farkup ] unit-test
|
||||
[ "\n<p>bar\n</p>" ] [ "\rbar\r" convert-farkup ] unit-test
|
||||
[ "\n<p>bar\n</p>" ] [ "\r\nbar\r\n" convert-farkup ] unit-test
|
||||
|
||||
[ "<p>foo</p>\n<p>bar</p>" ] [ "foo\n\n\nbar" convert-farkup ] unit-test
|
||||
|
||||
|
|
@ -28,17 +36,17 @@ IN: farkup.tests
|
|||
[ "<p>|a</p>" ]
|
||||
[ "|a" convert-farkup ] unit-test
|
||||
|
||||
[ "<p>|a|</p>" ]
|
||||
[ "<table><tr><td>a</td></tr></table>" ]
|
||||
[ "|a|" convert-farkup ] unit-test
|
||||
|
||||
[ "<table><tr><td>a</td><td>b</td></tr></table>" ]
|
||||
[ "a|b" convert-farkup ] unit-test
|
||||
[ "|a|b|" convert-farkup ] unit-test
|
||||
|
||||
[ "<table><tr><td>a</td><td>b</td></tr></table>\n<table><tr><td>c</td><td>d</td></tr></table>" ]
|
||||
[ "a|b\nc|d" convert-farkup ] unit-test
|
||||
[ "<table><tr><td>a</td><td>b</td></tr><tr><td>c</td><td>d</td></tr></table>" ]
|
||||
[ "|a|b|\n|c|d|" convert-farkup ] unit-test
|
||||
|
||||
[ "<table><tr><td>a</td><td>b</td></tr></table>\n<table><tr><td>c</td><td>d</td></tr></table>\n" ]
|
||||
[ "a|b\nc|d\n" convert-farkup ] unit-test
|
||||
[ "<table><tr><td>a</td><td>b</td></tr><tr><td>c</td><td>d</td></tr></table>" ]
|
||||
[ "|a|b|\n|c|d|\n" convert-farkup ] unit-test
|
||||
|
||||
[ "<p><strong>foo</strong>\n</p><h1>aheading</h1>\n<p>adfasd</p>" ]
|
||||
[ "*foo*\n=aheading=\nadfasd" convert-farkup ] unit-test
|
||||
|
|
@ -54,12 +62,23 @@ IN: farkup.tests
|
|||
[ "<p>=</p><h2>foo</h2>" ] [ "===foo==" convert-farkup ] unit-test
|
||||
[ "<h1>foo</h1><p>=</p>" ] [ "=foo==" convert-farkup ] unit-test
|
||||
|
||||
[ "<div style='white-space: pre; font-family: monospace; '><span class='KEYWORD3'>int</span> <span class='FUNCTION'>main</span><span class='OPERATOR'>(</span><span class='OPERATOR'>)</span><br/></div>" ]
|
||||
[ "<pre><span class='KEYWORD3'>int</span> <span class='FUNCTION'>main</span><span class='OPERATOR'>(</span><span class='OPERATOR'>)</span>\n</pre>" ]
|
||||
[ "[c{int main()}]" convert-farkup ] unit-test
|
||||
|
||||
[ "<p><img src=\"lol.jpg\"/></p>" ] [ "[[image:lol.jpg]]" convert-farkup ] unit-test
|
||||
[ "<p><img src=\"lol.jpg\" alt=\"teh lol\"/></p>" ] [ "[[image:lol.jpg|teh lol]]" convert-farkup ] unit-test
|
||||
[ "<p><a href=\"lol.com\"></a></p>" ] [ "[[lol.com]]" convert-farkup ] unit-test
|
||||
[ "<p><a href=\"lol.com\">lol.com</a></p>" ] [ "[[lol.com]]" convert-farkup ] unit-test
|
||||
[ "<p><a href=\"lol.com\">haha</a></p>" ] [ "[[lol.com|haha]]" convert-farkup ] unit-test
|
||||
|
||||
[ ] [ "[{}]" convert-farkup drop ] unit-test
|
||||
|
||||
[
|
||||
"<p>Feature comparison:\n<table><tr><td>a</td><td>Factor</td><td>Java</td><td>Lisp</td></tr><tr><td>Coolness</td><td>Yes</td><td>No</td><td>No</td></tr><tr><td>Badass</td><td>Yes</td><td>No</td><td>No</td></tr><tr><td>Enterprise</td><td>Yes</td><td>Yes</td><td>No</td></tr><tr><td>Kosher</td><td>Yes</td><td>No</td><td>Yes</td></tr></table></p>"
|
||||
] [ "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
|
||||
|
||||
[
|
||||
"<p>Feature comparison:\n\n<table><tr><td>a</td><td>Factor</td><td>Java</td><td>Lisp</td></tr><tr><td>Coolness</td><td>Yes</td><td>No</td><td>No</td></tr><tr><td>Badass</td><td>Yes</td><td>No</td><td>No</td></tr><tr><td>Enterprise</td><td>Yes</td><td>Yes</td><td>No</td></tr><tr><td>Kosher</td><td>Yes</td><td>No</td><td>Yes</td></tr></table></p>"
|
||||
] [ "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
|
||||
|
||||
[ "<p>a-b</p>" ] [ "a-b" convert-farkup ] unit-test
|
||||
[ "<ul><li>a-b</li></ul>" ] [ "-a-b" convert-farkup ] unit-test
|
||||
|
|
|
|||
|
|
@ -2,21 +2,24 @@
|
|||
! 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?
|
||||
|
||||
<PRIVATE
|
||||
|
||||
: delimiters ( -- string )
|
||||
"*_^~%[-=|\\\n" ; inline
|
||||
"*_^~%[-=|\\\r\n" ; inline
|
||||
|
||||
MEMO: text ( -- parser )
|
||||
[ delimiters member? not ] satisfy repeat1
|
||||
[ >string escape-string ] action ;
|
||||
|
||||
MEMO: delimiter ( -- parser )
|
||||
[ dup delimiters member? swap "\n=" member? not and ] satisfy
|
||||
[ dup delimiters member? swap "\r\n=" member? not and ] satisfy
|
||||
[ 1string ] action ;
|
||||
|
||||
: surround-with-foo ( string tag -- seq )
|
||||
|
|
@ -37,8 +40,11 @@ MEMO: emphasis ( -- parser ) "_" "em" delimited ;
|
|||
MEMO: superscript ( -- parser ) "^" "sup" delimited ;
|
||||
MEMO: subscript ( -- parser ) "~" "sub" delimited ;
|
||||
MEMO: inline-code ( -- parser ) "%" "code" delimited ;
|
||||
MEMO: nl ( -- parser ) "\n" token ;
|
||||
MEMO: 2nl ( -- parser ) "\n\n" token hide ;
|
||||
MEMO: nl ( -- parser )
|
||||
"\r\n" token [ drop "\n" ] action
|
||||
"\r" token [ drop "\n" ] action
|
||||
"\n" token 3choice ;
|
||||
MEMO: 2nl ( -- parser ) nl hide nl hide 2seq ;
|
||||
MEMO: h1 ( -- parser ) "=" "h1" delimited ;
|
||||
MEMO: h2 ( -- parser ) "==" "h2" delimited ;
|
||||
MEMO: h3 ( -- parser ) "===" "h3" delimited ;
|
||||
|
|
@ -56,25 +62,30 @@ MEMO: eq ( -- parser )
|
|||
: render-code ( string mode -- string' )
|
||||
>r string-lines r>
|
||||
[
|
||||
[
|
||||
H{ { wrap-margin f } } [
|
||||
htmlize-lines
|
||||
] with-nesting
|
||||
] with-html-stream
|
||||
<pre>
|
||||
htmlize-lines
|
||||
</pre>
|
||||
] 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
|
||||
[ "<a href=\"" , >r , r> "\">" , [ , ] when* "</a>" , ] { } make ;
|
||||
[
|
||||
"<a" ,
|
||||
" href=\"" , >r , r>
|
||||
link-no-follow? get [ " nofollow=\"true\"" , ] when
|
||||
"\">" , , "</a>" ,
|
||||
] { } make ;
|
||||
|
||||
: make-image-link ( href alt -- seq )
|
||||
escape-link
|
||||
|
|
@ -99,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 )
|
||||
[
|
||||
|
|
@ -110,28 +121,32 @@ 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 )
|
||||
list-item "\n" token hide list-of
|
||||
list-item nl hide list-of
|
||||
[ "ul" surround-with-foo ] action ;
|
||||
|
||||
MEMO: table-column ( -- parser )
|
||||
text [ "td" surround-with-foo ] action ;
|
||||
|
||||
MEMO: table-row ( -- parser )
|
||||
[
|
||||
table-column "|" token hide list-of-many ,
|
||||
] seq* [ "tr" surround-with-foo ] action ;
|
||||
"|" token hide
|
||||
table-column "|" token hide list-of
|
||||
"|" token hide nl hide optional 4seq
|
||||
[ "tr" surround-with-foo ] action ;
|
||||
|
||||
MEMO: table ( -- parser )
|
||||
table-row repeat1 [ "table" surround-with-foo ] action ;
|
||||
table-row repeat1
|
||||
[ "table" surround-with-foo ] action ;
|
||||
|
||||
MEMO: code ( -- parser )
|
||||
[
|
||||
|
|
@ -144,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 ,
|
||||
|
|
@ -151,8 +168,8 @@ MEMO: line ( -- parser )
|
|||
|
||||
MEMO: paragraph ( -- parser )
|
||||
line
|
||||
"\n" token over 2seq repeat0
|
||||
"\n" token "\n" token ensure-not 2seq optional 3seq
|
||||
nl over 2seq repeat0
|
||||
nl nl ensure-not 2seq optional 3seq
|
||||
[
|
||||
dup [ dup string? not swap [ blank? ] all? or ] deep-all?
|
||||
[ "<p>" swap "</p>" 3array ] unless
|
||||
|
|
@ -163,7 +180,7 @@ PRIVATE>
|
|||
PEG: parse-farkup ( -- parser )
|
||||
[
|
||||
list , table , h1 , h2 , h3 , h4 , code , paragraph , 2nl , nl ,
|
||||
] choice* repeat0 "\n" token optional 2seq ;
|
||||
] choice* repeat0 nl optional 2seq ;
|
||||
|
||||
: write-farkup ( parse-result -- )
|
||||
[ dup string? [ write ] [ drop ] if ] deep-each ;
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
\ , <repetition> %
|
||||
]
|
||||
[ fry % ] bi
|
||||
[ count-inputs \ , <repetition> % ] [ fry % ] bi
|
||||
] [ namespaces:, ] if
|
||||
] each
|
||||
] [ ] make deep-fry ;
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
||||
[ ] [ "<jimmy>" "red" set-value ] unit-test
|
||||
|
||||
[ "<jimmy>" ] [
|
||||
[
|
||||
"red" label render
|
||||
] with-string-writer
|
||||
] unit-test
|
||||
|
||||
[ "<input type='hidden' name='red' value='<jimmy>'/>" ] [
|
||||
[
|
||||
"red" hidden render
|
||||
] with-string-writer
|
||||
] unit-test
|
||||
|
||||
[ ] [ "'jimmy'" "red" set-value ] unit-test
|
||||
|
||||
[ "<input type='text' size='5' name='red' value=''jimmy''/>" ] [
|
||||
[
|
||||
"red" <field> 5 >>size render
|
||||
] with-string-writer
|
||||
] unit-test
|
||||
|
||||
[ "<input type='password' size='5' name='red' value=''/>" ] [
|
||||
[
|
||||
"red" <password> 5 >>size render
|
||||
] with-string-writer
|
||||
] unit-test
|
||||
|
||||
[ ] [
|
||||
[
|
||||
"green" <textarea> render
|
||||
] with-null-writer
|
||||
] unit-test
|
||||
|
||||
[ ] [
|
||||
[
|
||||
"green" <textarea> 25 >>rows 30 >>cols render
|
||||
] with-null-writer
|
||||
] unit-test
|
||||
|
||||
[ ] [ blank-values ] unit-test
|
||||
|
||||
[ ] [ "new york" "city1" set-value ] unit-test
|
||||
|
||||
[ ] [ { "new york" "los angeles" "chicago" } "cities" set-value ] unit-test
|
||||
|
||||
[ ] [
|
||||
[
|
||||
"city1"
|
||||
<choice>
|
||||
"cities" >>choices
|
||||
render
|
||||
] with-null-writer
|
||||
] unit-test
|
||||
|
||||
[ ] [ { "los angeles" "new york" } "city2" set-value ] unit-test
|
||||
|
||||
[ ] [
|
||||
[
|
||||
"city2"
|
||||
<choice>
|
||||
"cities" >>choices
|
||||
t >>multiple
|
||||
render
|
||||
] with-null-writer
|
||||
] unit-test
|
||||
|
||||
[ ] [
|
||||
[
|
||||
"city2"
|
||||
<choice>
|
||||
"cities" >>choices
|
||||
t >>multiple
|
||||
5 >>size
|
||||
render
|
||||
] with-null-writer
|
||||
] unit-test
|
||||
|
||||
[ ] [ blank-values ] unit-test
|
||||
|
||||
[ ] [ t "delivery" set-value ] unit-test
|
||||
|
||||
[ "<input type='checkbox' name='delivery' selected='true'>Delivery</input>" ] [
|
||||
[
|
||||
"delivery"
|
||||
<checkbox>
|
||||
"Delivery" >>label
|
||||
render
|
||||
] with-string-writer
|
||||
] unit-test
|
||||
|
||||
[ ] [ f "delivery" set-value ] unit-test
|
||||
|
||||
[ "<input type='checkbox' name='delivery'>Delivery</input>" ] [
|
||||
[
|
||||
"delivery"
|
||||
<checkbox>
|
||||
"Delivery" >>label
|
||||
render
|
||||
] with-string-writer
|
||||
] unit-test
|
||||
|
||||
SINGLETON: link-test
|
||||
|
||||
M: link-test link-title drop "<Link Title>" ;
|
||||
|
||||
M: link-test link-href drop "http://www.apple.com/foo&bar" ;
|
||||
|
||||
[ ] [ link-test "link" set-value ] unit-test
|
||||
|
||||
[ "<a href='http://www.apple.com/foo&bar'><Link Title></a>" ] [
|
||||
[ "link" link render ] with-string-writer
|
||||
] unit-test
|
||||
|
||||
[ ] [
|
||||
"<html>arbitrary <b>markup</b> for the win!</html>" "html" set-value
|
||||
] unit-test
|
||||
|
||||
[ "<html>arbitrary <b>markup</b> for the win!</html>" ] [
|
||||
[ "html" html render ] with-string-writer
|
||||
] unit-test
|
||||
|
||||
[ ] [ "int x = 4;" "code" set-value ] unit-test
|
||||
|
||||
[ ] [ "java" "mode" set-value ] unit-test
|
||||
|
||||
[ "<span class='KEYWORD3'>int</span> x <span class='OPERATOR'>=</span> <span class='DIGIT'>4</span>;\n" ] [
|
||||
[ "code" <code> "mode" >>mode render ] with-string-writer
|
||||
] unit-test
|
||||
|
||||
[ ] [ "-foo\n-bar" "farkup" set-value ] unit-test
|
||||
|
||||
[ "<ul><li>foo</li><li>bar</li></ul>" ] [
|
||||
[ "farkup" farkup render ] with-string-writer
|
||||
] unit-test
|
||||
|
||||
[ ] [ { 1 2 3 } "object" set-value ] unit-test
|
||||
|
||||
[ t ] [
|
||||
[ "object" inspector render ] with-string-writer
|
||||
[ "object" value [ describe ] with-html-stream ] with-string-writer
|
||||
=
|
||||
] unit-test
|
||||
|
||||
[ ] [ blank-values ] unit-test
|
||||
|
||||
[ ] [
|
||||
"factor" [
|
||||
"concatenative" "model" set-value
|
||||
] nest-values
|
||||
] unit-test
|
||||
|
||||
[ H{ { "factor" H{ { "model" "concatenative" } } } } ] [ values get ] unit-test
|
||||
|
|
@ -0,0 +1,224 @@
|
|||
! Copyright (C) 2008 Slava Pestov
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors kernel namespaces io math.parser assocs classes
|
||||
classes.tuple words arrays sequences sequences.lib splitting
|
||||
mirrors hashtables combinators continuations math strings
|
||||
fry locals calendar calendar.format xml.entities validators
|
||||
html.elements html.streams xmode.code2html farkup inspector
|
||||
lcs.diff2html ;
|
||||
IN: html.components
|
||||
|
||||
SYMBOL: values
|
||||
|
||||
: value values get at ;
|
||||
|
||||
: set-value values get set-at ;
|
||||
|
||||
: blank-values H{ } clone values set ;
|
||||
|
||||
: prepare-value ( name object -- value name object )
|
||||
[ [ value ] keep ] dip ; inline
|
||||
|
||||
: from-assoc ( assoc -- ) values get swap update ;
|
||||
|
||||
: from-tuple ( tuple -- ) <mirror> from-assoc ;
|
||||
|
||||
: deposit-values ( destination names -- )
|
||||
[ dup value ] H{ } map>assoc update ;
|
||||
|
||||
: deposit-slots ( destination names -- )
|
||||
[ <mirror> ] dip deposit-values ;
|
||||
|
||||
: with-each-index ( seq quot -- )
|
||||
'[
|
||||
[
|
||||
blank-values 1+ "index" set-value @
|
||||
] with-scope
|
||||
] each-index ; inline
|
||||
|
||||
: with-each-value ( seq quot -- )
|
||||
'[ "value" set-value @ ] with-each-index ; inline
|
||||
|
||||
: with-each-assoc ( seq quot -- )
|
||||
'[ from-assoc @ ] with-each-index ; inline
|
||||
|
||||
: with-each-tuple ( seq quot -- )
|
||||
'[ from-tuple @ ] with-each-index ; inline
|
||||
|
||||
: with-assoc-values ( assoc quot -- )
|
||||
'[ blank-values , from-assoc @ ] with-scope ; inline
|
||||
|
||||
: with-tuple-values ( assoc quot -- )
|
||||
'[ blank-values , from-tuple @ ] with-scope ; inline
|
||||
|
||||
: nest-values ( name quot -- )
|
||||
swap [
|
||||
[
|
||||
H{ } clone [ values set call ] keep
|
||||
] with-scope
|
||||
] dip set-value ; inline
|
||||
|
||||
: nest-tuple ( name quot -- )
|
||||
swap [
|
||||
[
|
||||
H{ } clone [ <mirror> values set call ] keep
|
||||
] with-scope
|
||||
] dip set-value ; inline
|
||||
|
||||
: object>string ( object -- string )
|
||||
{
|
||||
{ [ dup real? ] [ number>string ] }
|
||||
{ [ dup timestamp? ] [ timestamp>string ] }
|
||||
{ [ dup string? ] [ ] }
|
||||
{ [ dup word? ] [ word-name ] }
|
||||
{ [ dup not ] [ drop "" ] }
|
||||
} cond ;
|
||||
|
||||
GENERIC: render* ( value name render -- )
|
||||
|
||||
: render ( name renderer -- )
|
||||
over named-validation-messages get at [
|
||||
[ value>> ] [ message>> ] bi
|
||||
[ -rot render* ] dip
|
||||
render-error
|
||||
] [
|
||||
prepare-value render*
|
||||
] if* ;
|
||||
|
||||
<PRIVATE
|
||||
|
||||
: render-input ( value name type -- )
|
||||
<input =type =name object>string =value input/> ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
SINGLETON: label
|
||||
|
||||
M: label render* 2drop object>string escape-string write ;
|
||||
|
||||
SINGLETON: hidden
|
||||
|
||||
M: hidden render* drop "hidden" render-input ;
|
||||
|
||||
: render-field ( value name size type -- )
|
||||
<input
|
||||
=type
|
||||
[ object>string =size ] when*
|
||||
=name
|
||||
object>string =value
|
||||
input/> ;
|
||||
|
||||
TUPLE: field size ;
|
||||
|
||||
: <field> ( -- field )
|
||||
field new ;
|
||||
|
||||
M: field render* size>> "text" render-field ;
|
||||
|
||||
TUPLE: password size ;
|
||||
|
||||
: <password> ( -- password )
|
||||
password new ;
|
||||
|
||||
M: password render*
|
||||
#! Don't send passwords back to the user
|
||||
[ drop "" ] 2dip size>> "password" render-field ;
|
||||
|
||||
! Text areas
|
||||
TUPLE: textarea rows cols ;
|
||||
|
||||
: <textarea> ( -- renderer )
|
||||
textarea new ;
|
||||
|
||||
M: textarea render*
|
||||
<textarea
|
||||
[ rows>> [ object>string =rows ] when* ]
|
||||
[ cols>> [ object>string =cols ] when* ] bi
|
||||
=name
|
||||
textarea>
|
||||
object>string escape-string write
|
||||
</textarea> ;
|
||||
|
||||
! Choice
|
||||
TUPLE: choice size multiple choices ;
|
||||
|
||||
: <choice> ( -- choice )
|
||||
choice new ;
|
||||
|
||||
: render-option ( text selected? -- )
|
||||
<option [ "true" =selected ] when option>
|
||||
object>string escape-string write
|
||||
</option> ;
|
||||
|
||||
: render-options ( options selected -- )
|
||||
'[ dup , member? render-option ] each ;
|
||||
|
||||
M: choice render*
|
||||
<select
|
||||
swap =name
|
||||
dup size>> [ object>string =size ] when*
|
||||
dup multiple>> [ "true" =multiple ] when
|
||||
select>
|
||||
[ choices>> value ] [ multiple>> ] bi
|
||||
[ swap ] [ swap 1array ] if
|
||||
render-options
|
||||
</select> ;
|
||||
|
||||
! Checkboxes
|
||||
TUPLE: checkbox label ;
|
||||
|
||||
: <checkbox> ( -- checkbox )
|
||||
checkbox new ;
|
||||
|
||||
M: checkbox render*
|
||||
<input
|
||||
"checkbox" =type
|
||||
swap =name
|
||||
swap [ "true" =selected ] when
|
||||
input>
|
||||
label>> escape-string write
|
||||
</input> ;
|
||||
|
||||
! Link components
|
||||
GENERIC: link-title ( obj -- string )
|
||||
GENERIC: link-href ( obj -- url )
|
||||
|
||||
SINGLETON: link
|
||||
|
||||
M: link render*
|
||||
2drop
|
||||
<a dup link-href =href a>
|
||||
link-title object>string escape-string write
|
||||
</a> ;
|
||||
|
||||
! XMode code component
|
||||
TUPLE: code mode ;
|
||||
|
||||
: <code> ( -- 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 ;
|
||||
|
|
@ -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 ;
|
||||
|
||||
[ "<a href='h&o'>" ]
|
||||
[ [ <a "h&o" =href a> ] make-html-string ] unit-test
|
||||
[ [ <a "h&o" =href a> ] with-string-writer ] unit-test
|
||||
|
|
|
|||
|
|
@ -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 ( -- )
|
||||
"<?xml version=\"1.0\"?>" write-html
|
||||
"<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.0 Strict//EN\" \"http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd\">" 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
|
||||
<html "http://www.w3.org/1999/xhtml" =xmlns "en" =xml:lang "en" =lang html>
|
||||
<head> <title> swap write </title> </head>
|
||||
<body> call </body>
|
||||
</html> ;
|
||||
|
||||
: render-error ( message -- )
|
||||
<span "error" =class span> escape-string write </span> ;
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
||||
: <html-stream> ( stream -- stream )
|
||||
html-stream construct-delegate ;
|
||||
|
||||
<PRIVATE
|
||||
|
||||
TUPLE: html-sub-stream style stream ;
|
||||
|
||||
: (html-sub-stream) ( style stream -- stream )
|
||||
html-sub-stream boa
|
||||
512 <sbuf> <html-stream> over set-delegate ;
|
||||
|
||||
: <html-sub-stream> ( 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 [
|
||||
<a =href a> call </a>
|
||||
] [ 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
|
||||
] [
|
||||
<span =style span> call </span>
|
||||
] 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
|
||||
] [
|
||||
<div =style div> call </div>
|
||||
] 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 <html-sub-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 <html-sub-stream> ;
|
||||
|
||||
M: html-stream stream-write-table ( grid style stream -- )
|
||||
a-div [
|
||||
<table dup table-attrs table> swap [
|
||||
<tr> [
|
||||
<td "top" =valign swap table-style =style td>
|
||||
>string write-html
|
||||
</td>
|
||||
] with each </tr>
|
||||
] with each </table>
|
||||
] 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 ] [ [ <br/> ] with-output-stream* ] if ;
|
||||
|
||||
! Utilities
|
||||
: with-html-stream ( quot -- )
|
||||
output-stream get <html-stream> swap with-output-stream* ; inline
|
||||
|
||||
: xhtml-preamble
|
||||
"<?xml version=\"1.0\"?>" write-html
|
||||
"<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.0 Strict//EN\" \"http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd\">" 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
|
||||
<html "http://www.w3.org/1999/xhtml" =xmlns "en" =xml:lang "en" =lang html>
|
||||
<head> call </head>
|
||||
<body> call </body>
|
||||
</html> ;
|
||||
|
||||
: default-css ( -- )
|
||||
<link
|
||||
"stylesheet" =rel "text/css" =type
|
||||
"/responder/resources/extra/html/stylesheet.css" =href
|
||||
link/> ;
|
||||
|
||||
: simple-html-document ( title quot -- )
|
||||
swap [
|
||||
<title> write </title>
|
||||
default-css
|
||||
] html-document ;
|
||||
|
||||
: vertical-layout ( list -- )
|
||||
#! Given a list of HTML components, arrange them vertically.
|
||||
<table>
|
||||
[ <tr> <td> call </td> </tr> ] each
|
||||
</table> ;
|
||||
|
||||
: horizontal-layout ( list -- )
|
||||
#! Given a list of HTML components, arrange them horizontally.
|
||||
<table>
|
||||
<tr "top" =valign tr> [ <td> call </td> ] each </tr>
|
||||
</table> ;
|
||||
|
||||
: button ( label -- )
|
||||
#! Output an HTML submit button with the given label.
|
||||
<input "submit" =type =value input/> ;
|
||||
|
||||
: paragraph ( str -- )
|
||||
#! Output the string as an html paragraph
|
||||
<p> write </p> ;
|
||||
|
||||
: simple-page ( title quot -- )
|
||||
#! Call the quotation, with all output going to the
|
||||
#! body of an html page with the given title.
|
||||
<html>
|
||||
<head> <title> swap write </title> </head>
|
||||
<body> call </body>
|
||||
</html> ;
|
||||
|
||||
: 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.
|
||||
<html>
|
||||
<head>
|
||||
<title> rot write </title>
|
||||
swap call
|
||||
</head>
|
||||
<body> call </body>
|
||||
</html> ;
|
||||
|
||||
: render-error ( message -- )
|
||||
<span "error" =class span> escape-string write </span> ;
|
||||
|
|
@ -3,25 +3,27 @@ arrays shuffle unicode.case namespaces splitting http
|
|||
sequences.lib accessors io combinators http.client ;
|
||||
IN: html.parser.analyzer
|
||||
|
||||
TUPLE: link attributes clickable ;
|
||||
|
||||
: scrape-html ( url -- vector )
|
||||
http-get parse-html ;
|
||||
|
||||
: (find-relative)
|
||||
[ >r + dup r> ?nth* [ 2drop f f ] unless ] [ 2drop f ] if ;
|
||||
[ >r + dup r> ?nth* [ 2drop f f ] unless ] [ 2drop f ] if ; inline
|
||||
|
||||
: find-relative ( seq quot n -- i elt )
|
||||
>r over [ find drop ] dip r> swap pick
|
||||
(find-relative) ;
|
||||
(find-relative) ; inline
|
||||
|
||||
: (find-all) ( n seq quot -- )
|
||||
2dup >r >r find-from [
|
||||
dupd 2array , 1+ r> r> (find-all)
|
||||
] [
|
||||
r> r> 3drop
|
||||
] if* ;
|
||||
] if* ; inline
|
||||
|
||||
: find-all ( seq quot -- alist )
|
||||
[ 0 -rot (find-all) ] { } make ;
|
||||
[ 0 -rot (find-all) ] { } make ; inline
|
||||
|
||||
: (find-nth) ( offset seq quot n count -- obj )
|
||||
>r >r [ find-from ] 2keep 4 npick [
|
||||
|
|
@ -33,14 +35,14 @@ IN: html.parser.analyzer
|
|||
] if
|
||||
] [
|
||||
2drop r> r> 2drop
|
||||
] if ;
|
||||
] if ; inline
|
||||
|
||||
: find-nth ( seq quot n -- i elt )
|
||||
0 -roll 0 (find-nth) ;
|
||||
0 -roll 0 (find-nth) ; inline
|
||||
|
||||
: find-nth-relative ( seq quot n offest -- i elt )
|
||||
>r [ find-nth ] 3keep 2drop nip r> swap pick
|
||||
(find-relative) ;
|
||||
(find-relative) ; inline
|
||||
|
||||
: remove-blank-text ( vector -- vector' )
|
||||
[
|
||||
|
|
@ -120,9 +122,14 @@ IN: html.parser.analyzer
|
|||
[ [ name>> "a" = ] [ attributes>> "href" swap at ] bi and ]
|
||||
find-between-all ;
|
||||
|
||||
: <link> ( vector -- link )
|
||||
[ first attributes>> ]
|
||||
[ [ name>> { text "img" } member? ] filter ] bi
|
||||
link boa ;
|
||||
|
||||
: link. ( vector -- )
|
||||
[ second text>> write bl ]
|
||||
[ first tag-link write nl ] bi ;
|
||||
[ attributes>> "href" swap at write nl ]
|
||||
[ clickable>> [ bl bl text>> print ] each nl ] bi ;
|
||||
|
||||
: find-by-text ( seq quot -- tag )
|
||||
[ dup name>> text = ] prepose find drop ;
|
||||
|
|
@ -136,12 +143,12 @@ IN: html.parser.analyzer
|
|||
|
||||
: find-forms ( vector -- vector' )
|
||||
"form" over find-opening-tags-by-name
|
||||
over [ >r first2 r> find-between* ] curry map
|
||||
swap [ >r first2 r> find-between* ] curry map
|
||||
[ [ name>> { "form" "input" } member? ] filter ] map ;
|
||||
|
||||
: find-html-objects ( string vector -- vector' )
|
||||
find-opening-tags-by-name
|
||||
over [ >r first2 r> find-between* ] curry map ;
|
||||
[ find-opening-tags-by-name ] keep
|
||||
[ >r first2 r> find-between* ] curry map ;
|
||||
|
||||
: form-action ( vector -- string )
|
||||
[ name>> "form" = ] find nip
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
||||
: <html-stream> ( stream -- stream )
|
||||
f html-stream boa ;
|
||||
|
||||
<PRIVATE
|
||||
|
||||
TUPLE: html-sub-stream < html-stream style parent ;
|
||||
|
||||
: new-html-sub-stream ( style stream class -- stream )
|
||||
new
|
||||
512 <sbuf> >>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 [
|
||||
<a =href a> call </a>
|
||||
] [ 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
|
||||
] [
|
||||
<span =style span> call </span>
|
||||
] 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
|
||||
] [
|
||||
<div =style div> call </div>
|
||||
] 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 ] [ [ <br/> ] 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>> [
|
||||
<table dup table-attrs table> swap [
|
||||
<tr> [
|
||||
<td "top" =valign swap table-style =style td>
|
||||
stream>> >string write
|
||||
</td>
|
||||
] with each </tr>
|
||||
] with each </table>
|
||||
] with-output-stream* ;
|
||||
|
||||
M: html-stream dispose stream>> dispose ;
|
||||
|
||||
: with-html-stream ( quot -- )
|
||||
output-stream get <html-stream> swap with-output-stream* ; inline
|
||||
|
|
@ -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; }
|
||||
|
|
@ -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 <chloe> ;
|
||||
|
||||
[ "Hello world" ] [
|
||||
[
|
||||
"test1" test-template call-template
|
||||
] run-template
|
||||
] unit-test
|
||||
|
||||
[ "Blah blah" "Hello world" ] [
|
||||
[
|
||||
<box> title set
|
||||
[
|
||||
"test2" test-template call-template
|
||||
] run-template
|
||||
title get box>
|
||||
] with-scope
|
||||
] unit-test
|
||||
|
||||
[ "<html><head><title>Hello world</title></head><body>Blah blah</body></html>" ] [
|
||||
[
|
||||
[
|
||||
"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 "<Link Title>" ;
|
||||
|
||||
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
|
||||
|
||||
[ ] [ "<p>a paragraph</p>" "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
|
||||
|
||||
[ "<ul><li>1</li><li>2</li><li>3</li></ul>" ] [
|
||||
[
|
||||
"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
|
||||
|
||||
[ "<table><tr><td>RBaxter</td><td>Unknown</td></tr><tr><td>Doug</td><td>Coleman</td></tr></table>" ] [
|
||||
[
|
||||
"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
|
||||
|
||||
[ "<table><tr><td>RBaxter</td><td>Unknown</td></tr><tr><td>Doug</td><td>Coleman</td></tr></table>" ] [
|
||||
[
|
||||
"test11" test-template call-template
|
||||
] run-template [ blank? not ] filter
|
||||
] unit-test
|
||||
|
|
@ -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>> ] [ <mirror> ] 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 -- )
|
||||
|
|
@ -0,0 +1,14 @@
|
|||
<?xml version='1.0' ?>
|
||||
|
||||
<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
|
||||
|
||||
<table>
|
||||
<t:each-tuple t:values="people">
|
||||
<tr>
|
||||
<td><t:label t:name="first-name"/></td>
|
||||
<td><t:label t:name="last-name"/></td>
|
||||
</tr>
|
||||
</t:each-tuple>
|
||||
</table>
|
||||
|
||||
</t:chloe>
|
||||
|
|
@ -0,0 +1,14 @@
|
|||
<?xml version='1.0' ?>
|
||||
|
||||
<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
|
||||
|
||||
<table>
|
||||
<t:each-assoc t:values="people">
|
||||
<tr>
|
||||
<td><t:label t:name="first-name"/></td>
|
||||
<td><t:label t:name="last-name"/></td>
|
||||
</tr>
|
||||
</t:each-assoc>
|
||||
</table>
|
||||
|
||||
</t:chloe>
|
||||
|
|
@ -2,7 +2,7 @@
|
|||
|
||||
<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
|
||||
|
||||
<t:if t:code="http.server.templating.chloe.tests:test4-aux?">
|
||||
<t:if t:code="html.templates.chloe.tests:test4-aux?">
|
||||
True
|
||||
</t:if>
|
||||
|
||||
|
|
@ -2,7 +2,7 @@
|
|||
|
||||
<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
|
||||
|
||||
<t:if t:code="http.server.templating.chloe.tests:test5-aux?">
|
||||
<t:if t:code="html.templates.chloe.tests:test5-aux?">
|
||||
True
|
||||
</t:if>
|
||||
|
||||
|
|
@ -2,7 +2,7 @@
|
|||
|
||||
<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
|
||||
|
||||
<t:if t:var="http.server.templating.chloe.tests:test6-aux?">
|
||||
<t:if t:var="html.templates.chloe.tests:test6-aux?">
|
||||
True
|
||||
</t:if>
|
||||
|
||||
|
|
@ -2,7 +2,7 @@
|
|||
|
||||
<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
|
||||
|
||||
<t:if t:var="http.server.templating.chloe.tests:test7-aux?">
|
||||
<t:if t:var="html.templates.chloe.tests:test7-aux?">
|
||||
True
|
||||
</t:if>
|
||||
|
||||
|
|
@ -0,0 +1,27 @@
|
|||
<?xml version='1.0' ?>
|
||||
|
||||
<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
|
||||
|
||||
<t:label t:name="label" />
|
||||
|
||||
<t:link t:name="link" />
|
||||
|
||||
<t:code t:name="code" mode="mode" />
|
||||
|
||||
<t:farkup t:name="farkup" />
|
||||
|
||||
<t:inspector t:name="inspector" />
|
||||
|
||||
<t:html t:name="html" />
|
||||
|
||||
<t:field t:name="field" t:size="13" />
|
||||
|
||||
<t:password t:name="password" t:size="10" />
|
||||
|
||||
<t:textarea t:name="textarea" t:rows="5" t:cols="10" />
|
||||
|
||||
<t:choice t:name="choice" t:choices="choices" />
|
||||
|
||||
<t:checkbox t:name="checkbox">Checkbox</t:checkbox>
|
||||
|
||||
</t:chloe>
|
||||
|
|
@ -0,0 +1,11 @@
|
|||
<?xml version='1.0' ?>
|
||||
|
||||
<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
|
||||
|
||||
<ul>
|
||||
<t:each t:values="numbers">
|
||||
<li><t:label t:name="value"/></li>
|
||||
</t:each>
|
||||
</ul>
|
||||
|
||||
</t:chloe>
|
||||
|
|
@ -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 <fhtml> [ call-template ] with-string-writer
|
||||
|
|
@ -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 -- )
|
||||
<pre> error. </pre> ;
|
||||
: eval-template ( string -- )
|
||||
parse-template call ;
|
||||
|
||||
TUPLE: fhtml path ;
|
||||
|
||||
C: <fhtml> 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 )
|
||||
[ <fhtml> serve-template ]
|
||||
"application/x-factor-server-page"
|
||||
pick special>> set-at ;
|
||||
'[ , path>> utf8 file-contents eval-template ] assert-depth ;
|
||||
|
||||
INSTANCE: fhtml template
|
||||
|
|
@ -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>> [
|
||||
<link "alternate" =rel "application/atom+xml" =type
|
||||
[ first =title ] [ second =href ] bi
|
||||
link/>
|
||||
] 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 [ <box> title set ] unless
|
||||
atom-feed get [ <box> 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 ;
|
||||
|
|
@ -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 ;
|
||||
|
|
|
|||
|
|
@ -237,7 +237,7 @@ test-db [
|
|||
[ ] [
|
||||
[
|
||||
<dispatcher>
|
||||
<action> [ "text/plain" <content> [ "Hi" write ] >>body ] >>display
|
||||
<action> [ [ "Hi" write ] <text-content> ] >>display
|
||||
<login>
|
||||
<sessions>
|
||||
"" add-responder
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
||||
<action>
|
||||
[ "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 ;
|
||||
|
|
|
|||
|
|
@ -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>> [
|
||||
<span "error" =class span>
|
||||
escape-string write
|
||||
</span>
|
||||
] when* ;
|
||||
|
||||
TUPLE: action init display submit get-params post-params ;
|
||||
|
||||
: <action>
|
||||
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 ] [
|
||||
<ul "errors" =class ul>
|
||||
[ <li> message>> escape-string write </li> ] each
|
||||
</ul>
|
||||
] 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 )
|
||||
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
|
||||
<box> 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-action> ( -- page )
|
||||
page-action new-action
|
||||
dup '[ , template>> <html-content> ] >>display ;
|
||||
|
||||
TUPLE: feed-action < action feed ;
|
||||
|
||||
: <feed-action> ( -- feed )
|
||||
feed-action new
|
||||
dup '[ , feed>> call <feed-content> ] >>display ;
|
||||
|
|
|
|||
|
|
@ -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 <chloe> ;
|
||||
|
||||
: words>strings ( seq -- seq' )
|
||||
[ [ word-vocabulary ] [ drop ":" ] [ word-name ] tri 3append ] map ;
|
||||
|
||||
: strings>words ( seq -- seq' )
|
||||
[ ":" split1 swap lookup ] map ;
|
||||
|
||||
: <capabilities> ( id -- component )
|
||||
capabilities get words>strings <menu> ;
|
||||
|
||||
: <new-user-form> ( -- form )
|
||||
"user" <form>
|
||||
"new-user" admin-template >>edit-template
|
||||
"username" <string> add-field
|
||||
"realname" <string> add-field
|
||||
"new-password" <password> t >>required add-field
|
||||
"verify-password" <password> t >>required add-field
|
||||
"email" <email> add-field
|
||||
"capabilities" <capabilities> add-field ;
|
||||
|
||||
: <edit-user-form> ( -- form )
|
||||
"user" <form>
|
||||
"edit-user" admin-template >>edit-template
|
||||
"user-summary" admin-template >>summary-template
|
||||
"username" <string> hidden >>renderer add-field
|
||||
"realname" <string> add-field
|
||||
"new-password" <password> add-field
|
||||
"verify-password" <password> add-field
|
||||
"email" <email> add-field
|
||||
"profile" <inspector> add-field
|
||||
"capabilities" <capabilities> add-field ;
|
||||
|
||||
: <user-list-form> ( -- form )
|
||||
"user-list" <form>
|
||||
"user-list" admin-template >>view-template
|
||||
"list" <edit-user-form> +unordered+ <list> add-field ;
|
||||
|
||||
:: <new-user-action> ( form ctor next -- action )
|
||||
<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 <user>
|
||||
"realname" value >>realname
|
||||
"email" value >>email
|
||||
"new-password" value >>encoded-password
|
||||
H{ } clone >>profile
|
||||
|
||||
insert-tuple
|
||||
|
||||
next f <standard-redirect>
|
||||
] >>submit ;
|
||||
|
||||
:: <edit-user-action> ( form ctor next -- action )
|
||||
<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 <user> 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 <standard-redirect>
|
||||
] >>submit ;
|
||||
|
||||
:: <delete-user-action> ( ctor next -- action )
|
||||
<action>
|
||||
{ { "username" [ ] } } >>post-params
|
||||
|
||||
[
|
||||
"username" get
|
||||
[ <user> select-tuple 1 >>deleted update-tuple ]
|
||||
[ logout-all-sessions ]
|
||||
bi
|
||||
|
||||
next f <standard-redirect>
|
||||
] >>submit ;
|
||||
|
||||
TUPLE: user-admin < dispatcher ;
|
||||
|
||||
SYMBOL: can-administer-users?
|
||||
|
||||
can-administer-users? define-capability
|
||||
|
||||
:: <user-admin> ( -- responder )
|
||||
[let | ctor [ [ <user> ] ] |
|
||||
user-admin new-dispatcher
|
||||
<user-list-form> ctor <list-action> "" add-responder
|
||||
<new-user-form> ctor "$user-admin" <new-user-action> "new" add-responder
|
||||
<edit-user-form> ctor "$user-admin" <edit-user-action> "edit" add-responder
|
||||
ctor "$user-admin" <delete-user-action> "delete" add-responder
|
||||
<boilerplate>
|
||||
"admin" admin-template >>template
|
||||
{ can-administer-users? } <protected>
|
||||
] ;
|
||||
|
||||
: make-admin ( username -- )
|
||||
<user>
|
||||
select-tuple
|
||||
[ can-administer-users? suffix ] change-capabilities
|
||||
update-tuple ;
|
||||
|
|
@ -1,9 +0,0 @@
|
|||
<?xml version='1.0' ?>
|
||||
|
||||
<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
|
||||
|
||||
<t:title>Users</t:title>
|
||||
|
||||
<t:summary t:component="list" />
|
||||
|
||||
</t:chloe>
|
||||
|
|
@ -1,9 +0,0 @@
|
|||
<?xml version='1.0' ?>
|
||||
|
||||
<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
|
||||
|
||||
<t:a t:href="$user-admin/edit" t:query="username">
|
||||
<t:view t:component="username" />
|
||||
</t:a>
|
||||
|
||||
</t:chloe>
|
||||
|
|
@ -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 ;
|
||||
|
|
|
|||
|
|
@ -10,12 +10,12 @@
|
|||
|
||||
<tr>
|
||||
<th class="field-label">User name:</th>
|
||||
<td><t:view t:component="username" /></td>
|
||||
<td><t:label t:name="username" /></td>
|
||||
</tr>
|
||||
|
||||
<tr>
|
||||
<th class="field-label">Real name:</th>
|
||||
<td><t:edit t:component="realname" /></td>
|
||||
<td><t:field t:name="realname" /></td>
|
||||
</tr>
|
||||
|
||||
<tr>
|
||||
|
|
@ -25,7 +25,7 @@
|
|||
|
||||
<tr>
|
||||
<th class="field-label">Current password:</th>
|
||||
<td><t:edit t:component="password" /></td>
|
||||
<td><t:password t:name="password" /></td>
|
||||
</tr>
|
||||
|
||||
<tr>
|
||||
|
|
@ -35,12 +35,12 @@
|
|||
|
||||
<tr>
|
||||
<th class="field-label">New password:</th>
|
||||
<td><t:edit t:component="new-password" /></td>
|
||||
<td><t:password t:name="new-password" /></td>
|
||||
</tr>
|
||||
|
||||
<tr>
|
||||
<th class="field-label">Verify:</th>
|
||||
<td><t:edit t:component="verify-password" /></td>
|
||||
<td><t:password t:name="verify-password" /></td>
|
||||
</tr>
|
||||
|
||||
<tr>
|
||||
|
|
@ -50,7 +50,7 @@
|
|||
|
||||
<tr>
|
||||
<th class="field-label">E-mail:</th>
|
||||
<td><t:edit t:component="email" /></td>
|
||||
<td><t:field t:name="email" /></td>
|
||||
</tr>
|
||||
|
||||
<tr>
|
||||
|
|
@ -62,7 +62,7 @@
|
|||
|
||||
<p>
|
||||
<input type="submit" value="Update" />
|
||||
<t:validation-message />
|
||||
<t:validation-messages />
|
||||
</p>
|
||||
|
||||
</t:form>
|
||||
|
|
|
|||
|
|
@ -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 <chloe> ;
|
||||
|
||||
! ! ! Login
|
||||
|
||||
: <login-form>
|
||||
"login" <form>
|
||||
"login" login-template >>edit-template
|
||||
"username" <username>
|
||||
t >>required
|
||||
add-field
|
||||
"password" <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 ;
|
||||
|
||||
:: <login-action> ( -- action )
|
||||
[let | form [ <login-form> ] |
|
||||
<action>
|
||||
[ blank-values ] >>init
|
||||
: <login-action> ( -- action )
|
||||
<action>
|
||||
[ "login" login-template <html-content> ] >>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
|
||||
|
||||
: <register-form> ( -- form )
|
||||
"register" <form>
|
||||
"register" login-template >>edit-template
|
||||
"username" <username>
|
||||
t >>required
|
||||
add-field
|
||||
"realname" <string> add-field
|
||||
"new-password" <password>
|
||||
t >>required
|
||||
add-field
|
||||
"verify-password" <password>
|
||||
t >>required
|
||||
add-field
|
||||
"email" <email> add-field
|
||||
"captcha" <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 ;
|
||||
|
||||
:: <register-action> ( -- action )
|
||||
[let | form [ <register-form> ] |
|
||||
<action>
|
||||
[ blank-values ] >>init
|
||||
: <register-action> ( -- action )
|
||||
<page-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 <user>
|
||||
"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 <user>
|
||||
"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
|
||||
|
||||
: <edit-profile-form> ( -- form )
|
||||
"edit-profile" <form>
|
||||
"edit-profile" login-template >>edit-template
|
||||
"username" <username> add-field
|
||||
"realname" <string> add-field
|
||||
"password" <password> add-field
|
||||
"new-password" <password> add-field
|
||||
"verify-password" <password> add-field
|
||||
"email" <email> add-field ;
|
||||
: <edit-profile-action> ( -- action )
|
||||
<action>
|
||||
[
|
||||
logged-in-user get
|
||||
[ username>> "username" set-value ]
|
||||
[ realname>> "realname" set-value ]
|
||||
[ email>> "email" set-value ]
|
||||
tri
|
||||
] >>init
|
||||
|
||||
:: <edit-profile-action> ( -- action )
|
||||
[let | form [ <edit-profile-form> ] |
|
||||
<action>
|
||||
[
|
||||
blank-values
|
||||
[ "edit-profile" login-template <html-content> ] >>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 ;
|
||||
|
||||
: <recover-form-1> ( -- form )
|
||||
"register" <form>
|
||||
"recover-1" login-template >>edit-template
|
||||
"username" <username>
|
||||
t >>required
|
||||
add-field
|
||||
"email" <email>
|
||||
t >>required
|
||||
add-field
|
||||
"captcha" <captcha> add-field ;
|
||||
: <recover-action-1> ( -- action )
|
||||
<action>
|
||||
[ "recover-1" login-template <html-content> ] >>display
|
||||
|
||||
:: <recover-action-1> ( -- action )
|
||||
[let | form [ <recover-form-1> ] |
|
||||
<action>
|
||||
[ 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 <html-content>
|
||||
] >>submit ;
|
||||
|
||||
form validate-form
|
||||
|
||||
"email" value "username" value
|
||||
users issue-ticket [
|
||||
send-password-email
|
||||
] when*
|
||||
|
||||
"recover-2" login-template serve-template
|
||||
] >>submit
|
||||
] ;
|
||||
|
||||
: <recover-form-3>
|
||||
"new-password" <form>
|
||||
"recover-3" login-template >>edit-template
|
||||
"username" <username>
|
||||
hidden >>renderer
|
||||
t >>required
|
||||
add-field
|
||||
"new-password" <password>
|
||||
t >>required
|
||||
add-field
|
||||
"verify-password" <password>
|
||||
t >>required
|
||||
add-field
|
||||
"ticket" <string>
|
||||
hidden >>renderer
|
||||
t >>required
|
||||
add-field ;
|
||||
|
||||
:: <recover-action-3> ( -- action )
|
||||
[let | form [ <recover-form-3> ] |
|
||||
<action>
|
||||
[
|
||||
{ "username" [ v-required ] }
|
||||
: <recover-action-3> ( -- action )
|
||||
<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 <html-content> ] >>display
|
||||
|
||||
[ <recover-form-3> 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 <html-content>
|
||||
] [
|
||||
<400>
|
||||
] if*
|
||||
] >>submit ;
|
||||
|
||||
! ! ! Logout
|
||||
: <logout-action> ( -- action )
|
||||
|
|
|
|||
|
|
@ -10,12 +10,12 @@
|
|||
|
||||
<tr>
|
||||
<th class="field-label">User name:</th>
|
||||
<td><t:edit t:component="username" /></td>
|
||||
<td><t:field t:name="username" /></td>
|
||||
</tr>
|
||||
|
||||
<tr>
|
||||
<th class="field-label">Password:</th>
|
||||
<td><t:edit t:component="password" /></td>
|
||||
<td><t:password t:name="password" /></td>
|
||||
</tr>
|
||||
|
||||
</table>
|
||||
|
|
@ -23,7 +23,7 @@
|
|||
<p>
|
||||
|
||||
<input type="submit" value="Log in" />
|
||||
<t:validation-message />
|
||||
<t:validation-messages />
|
||||
|
||||
</p>
|
||||
|
||||
|
|
|
|||
Some files were not shown because too many files have changed in this diff Show More
Loading…
Reference in New Issue