Merge branch 'master' of git://factorcode.org/git/factor
Matthew Willis
commit
863e3df8e4
|
|
@ -7,7 +7,7 @@ math.parser classes alien.arrays alien.c-types alien.strings
|
|||
alien.structs alien.syntax cpu.architecture alien inspector
|
||||
quotations assocs kernel.private threads continuations.private
|
||||
libc combinators compiler.errors continuations layouts accessors
|
||||
;
|
||||
init ;
|
||||
IN: alien.compiler
|
||||
|
||||
TUPLE: #alien-node < node return parameters abi ;
|
||||
|
|
@ -336,7 +336,7 @@ M: #alien-indirect generate-node
|
|||
! this hashtable, they will all be blown away by code GC, beware
|
||||
SYMBOL: callbacks
|
||||
|
||||
callbacks global [ H{ } assoc-like ] change-at
|
||||
[ H{ } clone callbacks set-global ] "alien.compiler" add-init-hook
|
||||
|
||||
: register-callback ( word -- ) dup callbacks get set-at ;
|
||||
|
||||
|
|
@ -344,7 +344,7 @@ M: alien-callback-error summary
|
|||
drop "Words calling ``alien-callback'' must be compiled with the optimizing compiler." ;
|
||||
|
||||
: callback-bottom ( node -- )
|
||||
xt>> [ word-xt drop <alien> ] curry
|
||||
xt>> [ [ register-callback ] [ word-xt drop <alien> ] bi ] curry
|
||||
recursive-state get infer-quot ;
|
||||
|
||||
\ alien-callback [
|
||||
|
|
@ -354,7 +354,7 @@ M: alien-callback-error summary
|
|||
pop-literal nip >>abi
|
||||
pop-parameters >>parameters
|
||||
pop-literal nip >>return
|
||||
gensym dup register-callback >>xt
|
||||
gensym >>xt
|
||||
callback-bottom
|
||||
] "infer" set-word-prop
|
||||
|
||||
|
|
|
|||
|
|
@ -91,6 +91,6 @@ $nl
|
|||
ARTICLE: "c-unions" "C unions"
|
||||
"A " { $snippet "union" } " in C defines a type large enough to hold its largest member. This is usually used to allocate a block of memory which can hold one of several types of values."
|
||||
{ $subsection POSTPONE: C-UNION: }
|
||||
"C structure objects can be allocated by calling " { $link <c-object> } " or " { $link malloc-object } "."
|
||||
"C union objects can be allocated by calling " { $link <c-object> } " or " { $link malloc-object } "."
|
||||
$nl
|
||||
"Arrays of C unions can be created by calling " { $link <c-array> } " or " { $link malloc-array } ". Elements can be read and written using words named " { $snippet { $emphasis "type" } "-nth" } " and " { $snippet "set-" { $emphasis "type" } "-nth" } "; these words are automatically generated by " { $link POSTPONE: C-UNION: } "." ;
|
||||
|
|
|
|||
|
|
@ -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,14 +1,11 @@
|
|||
USING: help.syntax help.markup generator.fixup math kernel
|
||||
USING: help.syntax help.markup math kernel
|
||||
words strings alien ;
|
||||
IN: generator.fixup
|
||||
|
||||
HELP: frame-required
|
||||
{ $values { "n" "a non-negative integer" } }
|
||||
{ $description "Notify the code generator that the currently compiling code block needs a stack frame with room for at least " { $snippet "n" } " parameters." } ;
|
||||
|
||||
HELP: (rel-fixup)
|
||||
{ $values { "arg" integer } { "class" "a relocation class" } { "type" "a relocation type" } { "offset" integer } { "pair" "a pair of integers" } }
|
||||
{ $description "Creates a relocation instruction for the VM's runtime compiled code linker." } ;
|
||||
|
||||
HELP: add-literal
|
||||
{ $values { "obj" object } { "n" integer } }
|
||||
{ $description "Adds a literal to the " { $link literal-table } ", if it is not already there, and outputs the index of the literal in the table. This literal can then be used as an argument for a " { $link rt-literal } " relocation with " { $link rel-fixup } "." } ;
|
||||
|
|
|
|||
|
|
@ -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 -- )
|
||||
{
|
||||
[
|
||||
class-usages [
|
||||
drop
|
||||
[ forget-methods ]
|
||||
[ update-map- ]
|
||||
[ reset-class ]
|
||||
[ call-next-method ]
|
||||
} cleave ;
|
||||
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 ;
|
||||
|
|
|
|||
|
|
@ -35,10 +35,8 @@ IN: bunny.model
|
|||
[ normalize ] map ;
|
||||
|
||||
: read-model ( stream -- model )
|
||||
"Reading model" print flush [
|
||||
ascii [ parse-model ] with-file-reader
|
||||
[ normals ] 2keep 3array
|
||||
] time ;
|
||||
[ normals ] 2keep 3array ;
|
||||
|
||||
: model-path "bun_zipper.ply" temp-file ;
|
||||
|
||||
|
|
|
|||
|
|
@ -1,100 +1,39 @@
|
|||
! Copyright (C) 2008 Matthew Willis.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: cairo cairo.ffi ui.render kernel opengl.gl opengl
|
||||
math byte-arrays ui.gadgets accessors arrays
|
||||
namespaces io.backend memoize colors ;
|
||||
USING: sequences math opengl.gadgets kernel
|
||||
byte-arrays cairo.ffi cairo io.backend
|
||||
opengl.gl arrays ;
|
||||
|
||||
IN: cairo.gadgets
|
||||
|
||||
! We need two kinds of gadgets:
|
||||
! one performs the cairo ops once and caches the bytes, the other
|
||||
! performs cairo ops every refresh
|
||||
|
||||
TUPLE: cairo-gadget width height quot cache? texture ;
|
||||
PREDICATE: cached-cairo < cairo-gadget cache?>> ;
|
||||
: <cairo-gadget> ( width height quot -- cairo-gadget )
|
||||
cairo-gadget construct-gadget
|
||||
swap >>quot
|
||||
swap >>height
|
||||
swap >>width ;
|
||||
|
||||
: <cached-cairo> ( width height quot -- cairo-gadget )
|
||||
<cairo-gadget> t >>cache? ;
|
||||
|
||||
: width>stride ( width -- stride ) 4 * ;
|
||||
|
||||
: copy-cairo ( width height quot -- byte-array )
|
||||
>r over width>stride
|
||||
: copy-cairo ( dim quot -- byte-array )
|
||||
>r first2 over width>stride
|
||||
[ * nip <byte-array> dup CAIRO_FORMAT_ARGB32 ]
|
||||
[ cairo_image_surface_create_for_data ] 3bi
|
||||
r> with-cairo-from-surface ;
|
||||
|
||||
: cairo>bytes ( gadget -- byte-array )
|
||||
[ width>> ] [ height>> ] [ quot>> ] tri copy-cairo ;
|
||||
: <cairo-gadget> ( dim quot -- )
|
||||
over 2^-bounds swap copy-cairo
|
||||
GL_BGRA rot <texture-gadget> ;
|
||||
|
||||
: cairo>png ( gadget path -- )
|
||||
>r [ cairo>bytes CAIRO_FORMAT_ARGB32 ] [ width>> ]
|
||||
[ height>> ] tri over width>stride
|
||||
cairo_image_surface_create_for_data
|
||||
r> [ cairo_surface_write_to_png check-cairo ] curry with-surface ;
|
||||
|
||||
: with-cairo-gl ( quot -- )
|
||||
>r origin get [
|
||||
0 0 glRasterPos2i
|
||||
1.0 -1.0 glPixelZoom
|
||||
] r> compose with-translation ;
|
||||
|
||||
M: cairo-gadget draw-gadget* ( gadget -- )
|
||||
[
|
||||
[ width>> ] [ height>> GL_BGRA GL_UNSIGNED_BYTE ]
|
||||
[ cairo>bytes ] tri glDrawPixels
|
||||
] with-cairo-gl ;
|
||||
|
||||
MEMO: render-to-texture ( gadget -- )
|
||||
GL_TEXTURE_BIT [
|
||||
GL_TEXTURE_2D over texture>> glBindTexture
|
||||
>r GL_TEXTURE_2D 0 GL_RGBA r>
|
||||
[ width>> ] [ height>> 0 GL_BGRA GL_UNSIGNED_BYTE ]
|
||||
[ cairo>bytes ] tri glTexImage2D
|
||||
init-texture
|
||||
GL_TEXTURE_2D 0 glBindTexture
|
||||
] do-attribs ;
|
||||
|
||||
M: cached-cairo draw-gadget* ( gadget -- )
|
||||
GL_TEXTURE_2D [
|
||||
[
|
||||
dup render-to-texture
|
||||
white gl-color
|
||||
GL_TEXTURE_2D over texture>> glBindTexture
|
||||
GL_QUADS [
|
||||
[ width>> ] [ height>> ] bi 2array four-sides
|
||||
] do-state
|
||||
GL_TEXTURE_2D 0 glBindTexture
|
||||
] with-cairo-gl
|
||||
] do-enabled ;
|
||||
|
||||
M: cached-cairo graft* ( gadget -- )
|
||||
gen-texture >>texture drop ;
|
||||
|
||||
M: cached-cairo ungraft* ( gadget -- )
|
||||
[ texture>> delete-texture ]
|
||||
[ \ render-to-texture invalidate-memoized ] bi ;
|
||||
|
||||
M: cairo-gadget pref-dim* ( gadget -- rect )
|
||||
[ width>> ] [ height>> ] bi 2array ;
|
||||
! maybe also texture>png
|
||||
! : cairo>png ( gadget path -- )
|
||||
! >r [ cairo>bytes CAIRO_FORMAT_ARGB32 ] [ width>> ]
|
||||
! [ height>> ] tri over width>stride
|
||||
! cairo_image_surface_create_for_data
|
||||
! r> [ cairo_surface_write_to_png check-cairo ] curry with-surface ;
|
||||
|
||||
: copy-surface ( surface -- )
|
||||
cr swap 0 0 cairo_set_source_surface
|
||||
cr cairo_paint ;
|
||||
|
||||
: <bytes-gadget> ( width height bytes -- cairo-gadget )
|
||||
>r [ ] <cached-cairo> r> >>texture ;
|
||||
|
||||
: <png-gadget> ( path -- gadget )
|
||||
normalize-path cairo_image_surface_create_from_png
|
||||
[ cairo_image_surface_get_width ]
|
||||
[ cairo_image_surface_get_height 2dup ]
|
||||
[ cairo_image_surface_get_height 2array dup 2^-bounds ]
|
||||
[ [ copy-surface ] curry copy-cairo ] tri
|
||||
<bytes-gadget> ;
|
||||
GL_BGRA rot <texture-gadget> ;
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -142,6 +142,6 @@ IN: cairo.samples
|
|||
USING: quotations cairo.gadgets ui.gadgets.panes sequences ;
|
||||
: samples ( -- )
|
||||
{ arc clip clip-image dash gradient text utf8 }
|
||||
[ 256 256 rot 1quotation <cached-cairo> gadget. ] each ;
|
||||
[ { 256 256 } swap 1quotation <cairo-gadget> gadget. ] each ;
|
||||
|
||||
MAIN: samples
|
||||
|
|
@ -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> ;
|
||||
|
||||
|
|
|
|||
|
|
@ -77,8 +77,21 @@ MACRO: <--&& ( quots -- )
|
|||
[ [ 2dup ] prepend [ not ] append [ f ] ] t short-circuit
|
||||
[ 2nip ] append ;
|
||||
|
||||
! or
|
||||
|
||||
MACRO: || ( quots -- ? ) [ [ t ] ] f short-circuit ;
|
||||
|
||||
MACRO: 0|| ( quots -- ? ) [ [ t ] ] f short-circuit ;
|
||||
|
||||
MACRO: 1|| ( quots -- ? )
|
||||
[ [ dup ] prepend [ t ] ] f short-circuit [ nip ] append ;
|
||||
|
||||
MACRO: 2|| ( quots -- ? )
|
||||
[ [ 2dup ] prepend [ t ] ] f short-circuit [ 2nip ] append ;
|
||||
|
||||
MACRO: 3|| ( quots -- ? )
|
||||
[ [ 3dup ] prepend [ t ] ] f short-circuit [ 3nip ] append ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
! ifte
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
|
|
|||
|
|
@ -39,31 +39,13 @@ TUPLE: statement handle sql in-params out-params bind-params bound? type ;
|
|||
TUPLE: simple-statement < statement ;
|
||||
TUPLE: prepared-statement < statement ;
|
||||
|
||||
SINGLETON: throwable
|
||||
SINGLETON: nonthrowable
|
||||
|
||||
: make-throwable ( obj -- obj' )
|
||||
dup sequence? [
|
||||
[ make-throwable ] map
|
||||
] [
|
||||
throwable >>type
|
||||
] if ;
|
||||
|
||||
: make-nonthrowable ( obj -- obj' )
|
||||
dup sequence? [
|
||||
[ make-nonthrowable ] map
|
||||
] [
|
||||
nonthrowable >>type
|
||||
] if ;
|
||||
|
||||
TUPLE: result-set sql in-params out-params handle n max ;
|
||||
|
||||
: construct-statement ( sql in out class -- statement )
|
||||
new
|
||||
swap >>out-params
|
||||
swap >>in-params
|
||||
swap >>sql
|
||||
throwable >>type ;
|
||||
swap >>sql ;
|
||||
|
||||
HOOK: <simple-statement> db ( str in out -- statement )
|
||||
HOOK: <prepared-statement> db ( str in out -- statement )
|
||||
|
|
@ -81,12 +63,9 @@ GENERIC: more-rows? ( result-set -- ? )
|
|||
|
||||
GENERIC: execute-statement* ( statement type -- )
|
||||
|
||||
M: throwable execute-statement* ( statement type -- )
|
||||
M: object execute-statement* ( statement type -- )
|
||||
drop query-results dispose ;
|
||||
|
||||
M: nonthrowable execute-statement* ( statement type -- )
|
||||
drop [ query-results dispose ] [ 2drop ] recover ;
|
||||
|
||||
: execute-statement ( statement -- )
|
||||
dup sequence? [
|
||||
[ execute-statement ] each
|
||||
|
|
@ -127,7 +106,7 @@ M: nonthrowable execute-statement* ( statement type -- )
|
|||
: query-map ( statement quot -- seq )
|
||||
accumulator >r query-each r> { } like ; inline
|
||||
|
||||
: with-db ( db seq quot -- )
|
||||
: with-db ( seq class quot -- )
|
||||
>r make-db db-open db r>
|
||||
[ db get swap [ drop ] prepose with-disposal ] curry with-variable ;
|
||||
inline
|
||||
|
|
|
|||
|
|
@ -0,0 +1,11 @@
|
|||
! Copyright (C) 2008 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel ;
|
||||
IN: db.errors
|
||||
|
||||
ERROR: db-error ;
|
||||
ERROR: sql-error ;
|
||||
|
||||
|
||||
ERROR: table-exists ;
|
||||
ERROR: bad-schema ;
|
||||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -175,7 +175,7 @@ M: postgresql-db create-sql-statement ( class -- seq )
|
|||
|
||||
: drop-table-sql ( table -- statement )
|
||||
[
|
||||
"drop table " 0% 0% ";" 0% drop
|
||||
"drop table " 0% 0% drop
|
||||
] query-make ;
|
||||
|
||||
M: postgresql-db drop-sql-statement ( class -- seq )
|
||||
|
|
|
|||
|
|
@ -1,21 +1,19 @@
|
|||
! Copyright (C) 2008 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors kernel math namespaces sequences random
|
||||
strings
|
||||
math.bitfields.lib namespaces.lib db db.tuples db.types
|
||||
math.intervals ;
|
||||
strings math.parser math.intervals combinators
|
||||
math.bitfields.lib namespaces.lib db db.tuples db.types ;
|
||||
IN: db.queries
|
||||
|
||||
GENERIC: where ( specs obj -- )
|
||||
|
||||
: maybe-make-retryable ( statement -- statement )
|
||||
dup in-params>> [ generator-bind? ] contains? [
|
||||
make-retryable
|
||||
] when ;
|
||||
dup in-params>> [ generator-bind? ] contains?
|
||||
[ make-retryable ] when ;
|
||||
|
||||
: query-make ( class quot -- )
|
||||
>r sql-props r>
|
||||
[ 0 sql-counter rot with-variable ";" 0% ] { "" { } { } } nmake
|
||||
[ 0 sql-counter rot with-variable ] { "" { } { } } nmake
|
||||
<simple-statement> maybe-make-retryable ; inline
|
||||
|
||||
M: db begin-transaction ( -- ) "BEGIN" sql-command ;
|
||||
|
|
@ -127,3 +125,36 @@ M: db <select-by-slots-statement> ( tuple class -- statement )
|
|||
" from " 0% 0%
|
||||
where-clause
|
||||
] query-make ;
|
||||
|
||||
: do-group ( tuple groups -- )
|
||||
[
|
||||
", " join " group by " prepend append
|
||||
] curry change-sql drop ;
|
||||
|
||||
: do-order ( tuple order -- )
|
||||
[
|
||||
", " join " order by " prepend append
|
||||
] curry change-sql drop ;
|
||||
|
||||
: do-offset ( tuple n -- )
|
||||
[
|
||||
number>string " offset " prepend append
|
||||
] curry change-sql drop ;
|
||||
|
||||
: do-limit ( tuple n -- )
|
||||
[
|
||||
number>string " limit " prepend append
|
||||
] curry change-sql drop ;
|
||||
|
||||
: make-advanced-statement ( tuple advanced -- tuple' )
|
||||
dupd
|
||||
{
|
||||
[ group>> [ do-group ] [ drop ] if* ]
|
||||
[ order>> [ do-order ] [ drop ] if* ]
|
||||
[ limit>> [ do-limit ] [ drop ] if* ]
|
||||
[ offset>> [ do-offset ] [ drop ] if* ]
|
||||
} 2cleave ;
|
||||
|
||||
M: db <advanced-select-statement> ( tuple class group order limit offset -- tuple )
|
||||
advanced-statement boa
|
||||
[ <select-by-slots-statement> ] dip make-advanced-statement ;
|
||||
|
|
|
|||
|
|
@ -4,9 +4,11 @@ IN: db.sql.tests
|
|||
! TUPLE: person name age ;
|
||||
: insert-1
|
||||
{ insert
|
||||
{
|
||||
{ table "person" }
|
||||
{ columns "name" "age" }
|
||||
{ values "erg" 26 }
|
||||
}
|
||||
} ;
|
||||
|
||||
: update-1
|
||||
|
|
|
|||
|
|
@ -4,24 +4,25 @@ USING: alien.c-types arrays assocs kernel math math.parser
|
|||
namespaces sequences db.sqlite.ffi db combinators
|
||||
continuations db.types calendar.format serialize
|
||||
io.streams.byte-array byte-arrays io.encodings.binary
|
||||
io.backend ;
|
||||
io.backend db.errors ;
|
||||
IN: db.sqlite.lib
|
||||
|
||||
: sqlite-error ( n -- * )
|
||||
sqlite-error-messages nth throw ;
|
||||
ERROR: sqlite-error < db-error n string ;
|
||||
ERROR: sqlite-sql-error < sql-error n string ;
|
||||
|
||||
: sqlite-statement-error-string ( -- str )
|
||||
db get db-handle sqlite3_errmsg ;
|
||||
: throw-sqlite-error ( n -- * )
|
||||
dup sqlite-error-messages nth sqlite-error ;
|
||||
|
||||
: sqlite-statement-error ( -- * )
|
||||
sqlite-statement-error-string throw ;
|
||||
SQLITE_ERROR
|
||||
db get db-handle sqlite3_errmsg sqlite-sql-error ;
|
||||
|
||||
: sqlite-check-result ( n -- )
|
||||
{
|
||||
{ [ dup SQLITE_OK = ] [ drop ] }
|
||||
{ [ dup SQLITE_ERROR = ] [ sqlite-statement-error ] }
|
||||
[ sqlite-error ]
|
||||
} cond ;
|
||||
{ SQLITE_OK [ ] }
|
||||
{ SQLITE_ERROR [ sqlite-statement-error ] }
|
||||
[ throw-sqlite-error ]
|
||||
} case ;
|
||||
|
||||
: sqlite-open ( path -- db )
|
||||
normalize-path
|
||||
|
|
@ -158,12 +159,11 @@ IN: db.sqlite.lib
|
|||
dup sqlite-#columns [ sqlite-column ] with map ;
|
||||
|
||||
: sqlite-step-has-more-rows? ( prepared -- bool )
|
||||
dup SQLITE_ROW = [
|
||||
drop t
|
||||
] [
|
||||
dup SQLITE_DONE =
|
||||
[ drop ] [ sqlite-check-result ] if f
|
||||
] if ;
|
||||
{
|
||||
{ SQLITE_ROW [ t ] }
|
||||
{ SQLITE_DONE [ f ] }
|
||||
[ sqlite-check-result f ]
|
||||
} case ;
|
||||
|
||||
: sqlite-next ( prepared -- ? )
|
||||
sqlite3_step sqlite-step-has-more-rows? ;
|
||||
|
|
|
|||
|
|
@ -16,7 +16,7 @@ M: sqlite-db make-db* ( path db -- db )
|
|||
swap >>path ;
|
||||
|
||||
M: sqlite-db db-open ( db -- db )
|
||||
[ path>> sqlite-open ] [ swap >>handle ] bi ;
|
||||
dup path>> sqlite-open >>handle ;
|
||||
|
||||
M: sqlite-db db-close ( handle -- ) sqlite-close ;
|
||||
M: sqlite-db dispose ( db -- ) dispose-db ;
|
||||
|
|
@ -197,4 +197,3 @@ M: sqlite-db compound ( str seq -- str' )
|
|||
{ "default" [ first number>string join-space ] }
|
||||
[ 2drop ]
|
||||
} case ;
|
||||
|
||||
|
|
|
|||
|
|
@ -3,7 +3,8 @@
|
|||
USING: io.files kernel tools.test db db.tuples classes
|
||||
db.types continuations namespaces math math.ranges
|
||||
prettyprint calendar sequences db.sqlite math.intervals
|
||||
db.postgresql accessors random math.bitfields.lib ;
|
||||
db.postgresql accessors random math.bitfields.lib
|
||||
math.ranges strings sequences.lib ;
|
||||
IN: db.tuples.tests
|
||||
|
||||
TUPLE: person the-id the-name the-number the-real
|
||||
|
|
@ -198,7 +199,7 @@ TUPLE: annotation n paste-id summary author mode contents ;
|
|||
: test-sqlite ( quot -- )
|
||||
>r "tuples-test.db" temp-file sqlite-db r> with-db ;
|
||||
|
||||
: test-postgresql ( -- )
|
||||
: test-postgresql ( quot -- )
|
||||
>r { "localhost" "postgres" "foob" "factor-test" } postgresql-db r> with-db ;
|
||||
|
||||
: test-repeated-insert
|
||||
|
|
@ -224,6 +225,12 @@ TUPLE: serialize-me id data ;
|
|||
|
||||
TUPLE: exam id name score ;
|
||||
|
||||
: random-exam ( -- exam )
|
||||
f
|
||||
6 [ CHAR: a CHAR: b [a,b] random ] replicate >string
|
||||
100 random
|
||||
exam boa ;
|
||||
|
||||
: test-intervals ( -- )
|
||||
exam "EXAM"
|
||||
{
|
||||
|
|
@ -414,6 +421,43 @@ TUPLE: does-not-persist ;
|
|||
[ class \ not-persistent = ] must-fail-with
|
||||
] test-postgresql
|
||||
|
||||
|
||||
TUPLE: suparclass id a ;
|
||||
|
||||
suparclass f {
|
||||
{ "id" "ID" +db-assigned-id+ }
|
||||
{ "a" "A" INTEGER }
|
||||
} define-persistent
|
||||
|
||||
TUPLE: subbclass < suparclass b ;
|
||||
|
||||
subbclass "SUBCLASS" {
|
||||
{ "b" "B" TEXT }
|
||||
} define-persistent
|
||||
|
||||
TUPLE: fubbclass < subbclass ;
|
||||
|
||||
fubbclass "FUBCLASS" { } define-persistent
|
||||
|
||||
: test-db-inheritance ( -- )
|
||||
[ ] [ subbclass ensure-table ] unit-test
|
||||
[ ] [ fubbclass ensure-table ] unit-test
|
||||
|
||||
[ ] [
|
||||
subbclass new 5 >>a "hi" >>b dup insert-tuple id>> "id" set
|
||||
] unit-test
|
||||
|
||||
[ t "hi" 5 ] [
|
||||
subbclass new "id" get >>id select-tuple
|
||||
[ subbclass? ] [ b>> ] [ a>> ] tri
|
||||
] unit-test
|
||||
|
||||
[ ] [ fubbclass new 0 >>a "hi" >>b insert-tuple ] unit-test
|
||||
|
||||
[ t ] [ fubbclass new select-tuples [ fubbclass? ] all? ] unit-test ;
|
||||
|
||||
[ test-db-inheritance ] test-sqlite
|
||||
|
||||
! Don't comment these out. These words must infer
|
||||
\ bind-tuple must-infer
|
||||
\ insert-tuple must-infer
|
||||
|
|
|
|||
|
|
@ -13,13 +13,13 @@ IN: db.tuples
|
|||
"db-columns" set-word-prop
|
||||
"db-relations" set-word-prop ;
|
||||
|
||||
ERROR: not-persistent ;
|
||||
ERROR: not-persistent class ;
|
||||
|
||||
: db-table ( class -- obj )
|
||||
"db-table" word-prop [ not-persistent ] unless* ;
|
||||
dup "db-table" word-prop [ ] [ not-persistent ] ?if ;
|
||||
|
||||
: db-columns ( class -- obj )
|
||||
"db-columns" word-prop ;
|
||||
superclasses [ "db-columns" word-prop ] map concat ;
|
||||
|
||||
: db-relations ( class -- obj )
|
||||
"db-relations" word-prop ;
|
||||
|
|
@ -42,6 +42,8 @@ HOOK: <insert-user-assigned-statement> db ( class -- obj )
|
|||
HOOK: <update-tuple-statement> db ( class -- obj )
|
||||
HOOK: <delete-tuples-statement> db ( tuple class -- obj )
|
||||
HOOK: <select-by-slots-statement> db ( tuple class -- tuple )
|
||||
TUPLE: advanced-statement group order offset limit ;
|
||||
HOOK: <advanced-select-statement> db ( tuple class group order offset limit -- tuple )
|
||||
|
||||
HOOK: insert-tuple* db ( tuple statement -- )
|
||||
|
||||
|
|
@ -74,16 +76,16 @@ M: retryable execute-statement* ( statement type -- )
|
|||
[ regenerate-params bind-statement* f ] cleanup
|
||||
] curry 10 retry drop ;
|
||||
|
||||
: resulting-tuple ( row out-params -- tuple )
|
||||
dup first class>> new [
|
||||
: resulting-tuple ( class row out-params -- tuple )
|
||||
rot class new [
|
||||
[
|
||||
>r slot-name>> r> set-slot-named
|
||||
] curry 2each
|
||||
] keep ;
|
||||
|
||||
: query-tuples ( statement -- seq )
|
||||
: query-tuples ( exemplar-tuple statement -- seq )
|
||||
[ out-params>> ] keep query-results [
|
||||
[ sql-row-typed swap resulting-tuple ] with query-map
|
||||
[ sql-row-typed swap resulting-tuple ] with with query-map
|
||||
] with-disposal ;
|
||||
|
||||
: query-modify-tuple ( tuple statement -- )
|
||||
|
|
@ -110,8 +112,8 @@ M: retryable execute-statement* ( statement type -- )
|
|||
|
||||
: recreate-table ( class -- )
|
||||
[
|
||||
drop-sql-statement make-nonthrowable
|
||||
[ execute-statement ] with-disposals
|
||||
[ drop-sql-statement [ execute-statement ] with-disposals
|
||||
] curry ignore-errors
|
||||
] [ create-table ] bi ;
|
||||
|
||||
: ensure-table ( class -- )
|
||||
|
|
@ -141,9 +143,12 @@ M: retryable execute-statement* ( statement type -- )
|
|||
[ bind-tuple ] keep execute-statement
|
||||
] with-disposal ;
|
||||
|
||||
: select-tuples ( tuple -- tuples )
|
||||
dup dup class <select-by-slots-statement> [
|
||||
[ bind-tuple ] keep query-tuples
|
||||
] with-disposal ;
|
||||
: do-select ( exemplar-tuple statement -- tuples )
|
||||
[ [ bind-tuple ] [ query-tuples ] 2bi ] with-disposal ;
|
||||
|
||||
: select-tuple ( tuple -- tuple/f ) select-tuples ?first ;
|
||||
: select-tuples ( tuple -- tuples )
|
||||
dup dup class <select-by-slots-statement> do-select ;
|
||||
|
||||
: select-tuple ( tuple -- tuple/f )
|
||||
dup dup class f f f 1 <advanced-select-statement>
|
||||
do-select ?first ;
|
||||
|
|
|
|||
|
|
@ -142,7 +142,8 @@ HOOK: bind% db ( spec -- )
|
|||
HOOK: bind# db ( spec obj -- )
|
||||
|
||||
: offset-of-slot ( str obj -- n )
|
||||
class "slots" word-prop slot-named slot-spec-offset ;
|
||||
class superclasses [ "slots" word-prop ] map concat
|
||||
slot-named slot-spec-offset ;
|
||||
|
||||
: get-slot-named ( name obj -- value )
|
||||
tuck offset-of-slot slot ;
|
||||
|
|
|
|||
|
|
@ -68,7 +68,7 @@ SYMBOL: NX
|
|||
|
||||
: expired? ( entry -- ? ) time>> time->ttl 0 <= ;
|
||||
|
||||
: cache-get ( query -- result )
|
||||
: cache-get* ( query -- rrs/NX/f )
|
||||
dup table-get ! query result
|
||||
{
|
||||
{ [ dup f = ] [ 2drop f ] } ! not in the cache
|
||||
|
|
@ -80,6 +80,11 @@ SYMBOL: NX
|
|||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: cache-get ( query -- rrs/f )
|
||||
dup cache-get* dup NX = [ drop name>> name-error ] [ nip ] if ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: rr->entry ( rr -- entry )
|
||||
[ ttl>> ttl->time ] [ rdata>> {1} >vector ] bi entry boa ;
|
||||
|
||||
|
|
@ -110,3 +115,31 @@ SYMBOL: NX
|
|||
: cache-add-rr ( rr -- ) [ rr->query ] [ ] bi cache-add ;
|
||||
|
||||
: cache-add-rrs ( rrs -- ) [ cache-add-rr ] each ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
! cache-name-error
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: message-soa ( message -- rr/soa )
|
||||
authority-section>> [ type>> SOA = ] filter 1st ;
|
||||
|
||||
: cache-name-error ( message -- message )
|
||||
dup
|
||||
[ message-query ] [ message-soa ttl>> ] bi
|
||||
cache-nx ;
|
||||
|
||||
: cache-message-records ( message -- message )
|
||||
dup
|
||||
{
|
||||
[ answer-section>> cache-add-rrs ]
|
||||
[ authority-section>> cache-add-rrs ]
|
||||
[ additional-section>> cache-add-rrs ]
|
||||
}
|
||||
cleave ;
|
||||
|
||||
: cache-message ( message -- message )
|
||||
dup rcode>> NAME-ERROR = [ cache-name-error ] when
|
||||
cache-message-records ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
|
|
|
|||
|
|
@ -38,7 +38,7 @@ TUPLE: message
|
|||
! TYPE
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
SYMBOLS: A NS MD MF CNAME SOA MB MG MR NULL WKS PTR HINFO MINFO MX TXT ;
|
||||
SYMBOLS: A NS MD MF CNAME SOA MB MG MR NULL WKS PTR HINFO MINFO MX TXT AAAA ;
|
||||
|
||||
: type-table ( -- table )
|
||||
{
|
||||
|
|
@ -58,6 +58,7 @@ SYMBOLS: A NS MD MF CNAME SOA MB MG MR NULL WKS PTR HINFO MINFO MX TXT ;
|
|||
{ MINFO 14 }
|
||||
{ MX 15 }
|
||||
{ TXT 16 }
|
||||
{ AAAA 28 }
|
||||
} ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
|
@ -126,6 +127,8 @@ SYMBOLS: NO-ERROR FORMAT-ERROR SERVER-FAILURE NAME-ERROR NOT-IMPLEMENTED
|
|||
|
||||
: ip->ba ( ip -- ba ) "." split [ string>number ] map >byte-array ;
|
||||
|
||||
: ipv6->ba ( ip -- ba ) ":" split [ 16 base> ] map [ 2 >be ] map concat ;
|
||||
|
||||
: label->ba ( label -- ba ) [ >byte-array ] [ length ] bi prefix ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
|
@ -330,6 +333,13 @@ SYMBOLS: NO-ERROR FORMAT-ERROR SERVER-FAILURE NAME-ERROR NOT-IMPLEMENTED
|
|||
|
||||
: get-ip ( ba i -- ip ) dup 4 + subseq >array [ number>string ] map "." join ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: get-ipv6 ( ba i -- ip )
|
||||
dup 16 + subseq 2 group [ be> 16 >base ] map ":" join ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: get-rdata ( ba i type -- rdata )
|
||||
{
|
||||
{ CNAME [ get-name ] }
|
||||
|
|
@ -338,6 +348,7 @@ SYMBOLS: NO-ERROR FORMAT-ERROR SERVER-FAILURE NAME-ERROR NOT-IMPLEMENTED
|
|||
{ MX [ get-mx ] }
|
||||
{ SOA [ get-soa ] }
|
||||
{ A [ get-ip ] }
|
||||
{ AAAA [ get-ipv6 ] }
|
||||
}
|
||||
case ;
|
||||
|
||||
|
|
@ -459,4 +470,22 @@ SYMBOLS: NO-ERROR FORMAT-ERROR SERVER-FAILURE NAME-ERROR NOT-IMPLEMENTED
|
|||
|
||||
: ask ( message -- message ) dns-server ask-server ;
|
||||
|
||||
: <query-message> ( query -- message ) <message> swap {1} >>question-section ;
|
||||
: query->message ( query -- message ) <message> swap {1} >>question-section ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: message-query ( message -- query ) question-section>> 1st ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
ERROR: name-error name ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: fully-qualified ( name -- name )
|
||||
{
|
||||
{ [ dup empty? ] [ "." append ] }
|
||||
{ [ dup peek CHAR: . = ] [ ] }
|
||||
{ [ t ] [ "." append ] }
|
||||
}
|
||||
cond ;
|
||||
|
|
|
|||
|
|
@ -0,0 +1,109 @@
|
|||
|
||||
USING: kernel
|
||||
combinators
|
||||
vectors
|
||||
sequences
|
||||
io.sockets
|
||||
accessors
|
||||
combinators.lib
|
||||
newfx
|
||||
dns dns.cache dns.misc ;
|
||||
|
||||
IN: dns.forwarding
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
! DNS server - caching, forwarding
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: (socket) ( -- vec ) V{ f } ;
|
||||
|
||||
: socket ( -- socket ) (socket) 1st ;
|
||||
|
||||
: init-socket-on-port ( port -- )
|
||||
f swap <inet4> <datagram> 0 (socket) as-mutate ;
|
||||
|
||||
: init-socket ( -- ) 53 init-socket-on-port ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: (upstream-server) ( -- vec ) V{ f } ;
|
||||
|
||||
: upstream-server ( -- ip ) (upstream-server) 1st ;
|
||||
|
||||
: set-upstream-server ( ip -- ) 0 (upstream-server) as-mutate ;
|
||||
|
||||
: init-upstream-server ( -- )
|
||||
upstream-server not
|
||||
[ resolv-conf-server set-upstream-server ]
|
||||
when ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: 1&& <-&& ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: rrs? ( obj -- ? ) { [ NX = not ] [ f = not ] } 1&& ;
|
||||
|
||||
: query->answer/cache ( query -- rrs/NX/f )
|
||||
dup cache-get* dup { [ rrs? ] [ NX = ] } 1||
|
||||
[ nip ]
|
||||
[
|
||||
drop
|
||||
dup clone CNAME >>type cache-get* dup { [ NX = ] [ f = ] } 1||
|
||||
[ nip ]
|
||||
[ ! query rrs
|
||||
tuck ! rrs query rrs
|
||||
1st ! rrs query rr/cname
|
||||
rdata>> ! rrs query name
|
||||
>r clone r> >>name ! rrs query
|
||||
query->answer/cache ! rrs rrs/NX/f
|
||||
dup rrs? [ append ] [ nip ] if
|
||||
]
|
||||
if
|
||||
]
|
||||
if ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: answer-from-cache ( message -- message/f )
|
||||
dup message-query ! message query
|
||||
dup query->answer/cache ! message query rrs/NX/f
|
||||
{
|
||||
{ [ dup f = ] [ 3drop f ] }
|
||||
{ [ dup NX = ] [ 2drop NAME-ERROR >>rcode ] }
|
||||
{ [ t ] [ nip >>answer-section ] }
|
||||
}
|
||||
cond ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: answer-from-server ( message -- message )
|
||||
upstream-server ask-server
|
||||
cache-message ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: find-answer ( message -- message )
|
||||
dup answer-from-cache dup
|
||||
[ nip ]
|
||||
[ drop answer-from-server ]
|
||||
if ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: loop ( -- )
|
||||
socket receive ! byte-array addr-spec
|
||||
swap ! addr-spec byte-array
|
||||
parse-message ! addr-spec message
|
||||
find-answer ! addr-spec message
|
||||
message->ba ! addr-spec byte-array
|
||||
swap ! byte-array addr-spec
|
||||
socket send
|
||||
loop ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: start ( -- ) init-socket init-upstream-server loop ;
|
||||
|
||||
MAIN: start
|
||||
|
|
@ -0,0 +1,12 @@
|
|||
|
||||
USING: kernel sequences splitting io.files io.encodings.utf8 random newfx ;
|
||||
|
||||
IN: dns.misc
|
||||
|
||||
: resolv-conf-servers ( -- seq )
|
||||
"/etc/resolv.conf" utf8 file-lines
|
||||
[ " " split ] map
|
||||
[ 1st "nameserver" = ] filter
|
||||
[ 2nd ] map ;
|
||||
|
||||
: resolv-conf-server ( -- ip ) resolv-conf-servers random ;
|
||||
|
|
@ -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,34 +6,6 @@ IN: dns.resolver
|
|||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
! Need to cache records even in the case of name error
|
||||
|
||||
: cache-message ( message -- message )
|
||||
dup dup rcode>> NAME-ERROR =
|
||||
[
|
||||
[ question-section>> 1st ]
|
||||
[ authority-section>> [ type>> SOA = ] filter random ttl>> ]
|
||||
bi
|
||||
cache-nx
|
||||
]
|
||||
[
|
||||
{
|
||||
[ answer-section>> cache-add-rrs ]
|
||||
[ authority-section>> cache-add-rrs ]
|
||||
[ additional-section>> cache-add-rrs ]
|
||||
}
|
||||
cleave
|
||||
]
|
||||
if ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
! Ask and cache the records
|
||||
|
||||
: ask* ( message -- message ) ask cache-message ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: canonical/cache ( name -- name )
|
||||
dup CNAME IN query boa cache-get dup vector? ! name result ?
|
||||
[ nip 1st rdata>> ]
|
||||
|
|
@ -44,25 +16,16 @@ IN: dns.resolver
|
|||
canonical/cache
|
||||
dup A IN query boa cache-get ! name result
|
||||
{
|
||||
{
|
||||
[ dup NX = ]
|
||||
[ 2drop f ]
|
||||
}
|
||||
{
|
||||
[ dup f = ]
|
||||
[ 2drop f ]
|
||||
}
|
||||
{
|
||||
[ t ]
|
||||
[ nip random rdata>> ]
|
||||
}
|
||||
{ [ dup NX = ] [ 2drop f ] }
|
||||
{ [ dup f = ] [ 2drop f ] }
|
||||
{ [ t ] [ nip random rdata>> ] }
|
||||
}
|
||||
cond ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: canonical/server ( name -- name )
|
||||
dup CNAME IN query boa <query-message> ask* answer-section>>
|
||||
dup CNAME IN query boa query->message ask cache-message answer-section>>
|
||||
[ type>> CNAME = ] filter dup empty? not
|
||||
[ nip 1st rdata>> ]
|
||||
[ drop ]
|
||||
|
|
@ -70,7 +33,7 @@ IN: dns.resolver
|
|||
|
||||
: name->ip/server ( name -- ip )
|
||||
canonical/server
|
||||
dup A IN query boa <query-message> ask* answer-section>>
|
||||
dup A IN query boa query->message ask cache-message answer-section>>
|
||||
[ type>> A = ] filter dup empty? not
|
||||
[ nip random rdata>> ]
|
||||
[ 2drop f ]
|
||||
|
|
@ -78,16 +41,6 @@ IN: dns.resolver
|
|||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: fully-qualified ( name -- name )
|
||||
{
|
||||
{ [ dup empty? ] [ "." append ] }
|
||||
{ [ dup peek CHAR: . = ] [ ] }
|
||||
{ [ t ] [ "." append ] }
|
||||
}
|
||||
cond ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: name->ip ( name -- ip )
|
||||
fully-qualified
|
||||
dup name->ip/cache dup
|
||||
|
|
|
|||
|
|
@ -0,0 +1,20 @@
|
|||
|
||||
USING: kernel sequences random accessors dns ;
|
||||
|
||||
IN: dns.stub
|
||||
|
||||
! Stub resolver
|
||||
!
|
||||
! Generally useful, but particularly when running a forwarding,
|
||||
! caching, nameserver on localhost with multiple Factor instances
|
||||
! querying it.
|
||||
|
||||
: name->ip ( name -- ip )
|
||||
A IN query boa
|
||||
query->message
|
||||
ask
|
||||
dup rcode>> NAME-ERROR =
|
||||
[ message-query name>> name-error ]
|
||||
[ answer-section>> [ type>> A = ] filter random rdata>> ]
|
||||
if ;
|
||||
|
||||
|
|
@ -62,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,10 +2,13 @@
|
|||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: arrays io io.styles kernel memoize namespaces peg
|
||||
sequences strings html.elements xml.entities xmode.code2html
|
||||
splitting io.streams.string html peg.parsers html.elements
|
||||
splitting io.streams.string peg.parsers
|
||||
sequences.deep unicode.categories ;
|
||||
IN: farkup
|
||||
|
||||
SYMBOL: relative-link-prefix
|
||||
SYMBOL: link-no-follow?
|
||||
|
||||
<PRIVATE
|
||||
|
||||
: delimiters ( -- string )
|
||||
|
|
@ -59,25 +62,30 @@ MEMO: eq ( -- parser )
|
|||
: render-code ( string mode -- string' )
|
||||
>r string-lines r>
|
||||
[
|
||||
[
|
||||
H{ { wrap-margin f } } [
|
||||
<pre>
|
||||
htmlize-lines
|
||||
] with-nesting
|
||||
] with-html-stream
|
||||
</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
|
||||
|
|
@ -102,7 +110,7 @@ MEMO: simple-link ( -- parser )
|
|||
"[[" token hide ,
|
||||
[ "|]" member? not ] satisfy repeat1 ,
|
||||
"]]" token hide ,
|
||||
] seq* [ first f make-link ] action ;
|
||||
] seq* [ first dup make-link ] action ;
|
||||
|
||||
MEMO: labelled-link ( -- parser )
|
||||
[
|
||||
|
|
@ -113,12 +121,14 @@ MEMO: labelled-link ( -- parser )
|
|||
"]]" token hide ,
|
||||
] seq* [ first2 make-link ] action ;
|
||||
|
||||
MEMO: link ( -- parser ) [ image-link , simple-link , labelled-link , ] choice* ;
|
||||
MEMO: link ( -- parser )
|
||||
[ image-link , simple-link , labelled-link , ] choice* ;
|
||||
|
||||
DEFER: line
|
||||
MEMO: list-item ( -- parser )
|
||||
[
|
||||
"-" token hide , line ,
|
||||
"-" token hide , ! text ,
|
||||
[ "\r\n" member? not ] satisfy repeat1 [ >string escape-string ] action ,
|
||||
] seq* [ "li" surround-with-foo ] action ;
|
||||
|
||||
MEMO: list ( -- parser )
|
||||
|
|
@ -149,6 +159,8 @@ MEMO: code ( -- parser )
|
|||
|
||||
MEMO: line ( -- parser )
|
||||
[
|
||||
nl table 2seq ,
|
||||
nl list 2seq ,
|
||||
text , strong , emphasis , link ,
|
||||
superscript , subscript , inline-code ,
|
||||
escaped-char , delimiter , eq ,
|
||||
|
|
|
|||
|
|
@ -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,7 +139,6 @@ SYMBOL: html
|
|||
dup "=" prepend swap
|
||||
[ write-attr ] curry attribute-effect html-word ;
|
||||
|
||||
[
|
||||
! Define some closed HTML tags
|
||||
[
|
||||
"h1" "h2" "h3" "h4" "h5" "h6" "h7" "h8" "h9"
|
||||
|
|
@ -163,4 +164,21 @@ SYMBOL: html
|
|||
"width" "selected" "onsubmit" "xmlns" "lang" "xml:lang"
|
||||
"media" "title" "multiple"
|
||||
] [ define-attribute-word ] each
|
||||
] with-compilation-unit
|
||||
|
||||
>>
|
||||
|
||||
: 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> ;
|
||||
|
|
@ -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
|
||||
, dup empty? [ drop ] [ handle-rest-param ] if
|
||||
|
||||
init-validation
|
||||
,
|
||||
request get
|
||||
<box> validation-message set
|
||||
[ request-params params set ]
|
||||
[
|
||||
method>> {
|
||||
[ request-params rest-param get assoc-union params set ]
|
||||
[ method>> ] bi
|
||||
{
|
||||
{ "GET" [ handle-get ] }
|
||||
{ "HEAD" [ handle-get ] }
|
||||
{ "POST" [ handle-post ] }
|
||||
} case
|
||||
] bi
|
||||
] [
|
||||
<404>
|
||||
] if
|
||||
] 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 ;
|
||||
|
|
|
|||
Some files were not shown because too many files have changed in this diff Show More
Loading…
Reference in New Issue