Merge branch 'master' of git://factorcode.org/git/factor
commit
ffb1d7e51a
|
@ -344,25 +344,37 @@ M: wrapper '
|
||||||
[ emit ] emit-object ;
|
[ emit ] emit-object ;
|
||||||
|
|
||||||
! Strings
|
! Strings
|
||||||
|
: native> ( object -- object )
|
||||||
|
big-endian get [ [ be> ] map ] [ [ le> ] map ] if ;
|
||||||
|
|
||||||
: emit-bytes ( seq -- )
|
: emit-bytes ( seq -- )
|
||||||
bootstrap-cell <groups>
|
bootstrap-cell <groups> native> emit-seq ;
|
||||||
big-endian get [ [ be> ] map ] [ [ le> ] map ] if
|
|
||||||
emit-seq ;
|
|
||||||
|
|
||||||
: pad-bytes ( seq -- newseq )
|
: pad-bytes ( seq -- newseq )
|
||||||
dup length bootstrap-cell align 0 pad-right ;
|
dup length bootstrap-cell align 0 pad-right ;
|
||||||
|
|
||||||
: check-string ( string -- )
|
: extended-part ( str -- str' )
|
||||||
[ 127 > ] contains?
|
dup [ 128 < ] all? [ drop f ] [
|
||||||
[ "Bootstrap cannot emit non-ASCII strings" throw ] when ;
|
[ -7 shift 1 bitxor ] { } map-as
|
||||||
|
big-endian get
|
||||||
|
[ [ 2 >be ] { } map-as ]
|
||||||
|
[ [ 2 >le ] { } map-as ] if
|
||||||
|
B{ } join
|
||||||
|
] if ;
|
||||||
|
|
||||||
|
: ascii-part ( str -- str' )
|
||||||
|
[
|
||||||
|
[ 128 mod ] [ 128 >= ] bi
|
||||||
|
[ 128 bitor ] when
|
||||||
|
] B{ } map-as ;
|
||||||
|
|
||||||
: emit-string ( string -- ptr )
|
: emit-string ( string -- ptr )
|
||||||
dup check-string
|
[ length ] [ extended-part ' ] [ ] tri
|
||||||
string type-number object tag-number [
|
string type-number object tag-number [
|
||||||
dup length emit-fixnum
|
[ emit-fixnum ]
|
||||||
f ' emit
|
[ emit ]
|
||||||
f ' emit
|
[ f ' emit ascii-part pad-bytes emit-bytes ]
|
||||||
pad-bytes emit-bytes
|
tri*
|
||||||
] emit-object ;
|
] emit-object ;
|
||||||
|
|
||||||
M: string '
|
M: string '
|
||||||
|
|
|
@ -2,19 +2,26 @@
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: sequences math kernel byte-arrays cairo.ffi cairo
|
USING: sequences math kernel byte-arrays cairo.ffi cairo
|
||||||
io.backend ui.gadgets accessors opengl.gl arrays fry
|
io.backend ui.gadgets accessors opengl.gl arrays fry
|
||||||
classes ui.render namespaces ;
|
classes ui.render namespaces destructors libc ;
|
||||||
|
|
||||||
IN: cairo.gadgets
|
IN: cairo.gadgets
|
||||||
|
|
||||||
|
<PRIVATE
|
||||||
: width>stride ( width -- stride ) 4 * ;
|
: width>stride ( width -- stride ) 4 * ;
|
||||||
|
|
||||||
|
: image-dims ( gadget -- width height stride )
|
||||||
|
dim>> first2 over width>stride ; inline
|
||||||
|
: image-buffer ( width height stride -- alien )
|
||||||
|
* nip malloc ; inline
|
||||||
|
PRIVATE>
|
||||||
|
|
||||||
GENERIC: render-cairo* ( gadget -- )
|
GENERIC: render-cairo* ( gadget -- )
|
||||||
|
|
||||||
: render-cairo ( gadget -- byte-array )
|
: render-cairo ( gadget -- alien )
|
||||||
dup dim>> first2 over width>stride
|
[
|
||||||
[ * nip <byte-array> dup CAIRO_FORMAT_ARGB32 ]
|
image-dims
|
||||||
[ cairo_image_surface_create_for_data ] 3bi
|
[ image-buffer dup CAIRO_FORMAT_ARGB32 ]
|
||||||
rot '[ _ render-cairo* ] with-cairo-from-surface ; inline
|
[ cairo_image_surface_create_for_data ] 3bi
|
||||||
|
] [ '[ _ render-cairo* ] with-cairo-from-surface ] bi ;
|
||||||
|
|
||||||
TUPLE: cairo-gadget < gadget ;
|
TUPLE: cairo-gadget < gadget ;
|
||||||
|
|
||||||
|
@ -23,11 +30,13 @@ TUPLE: cairo-gadget < gadget ;
|
||||||
swap >>dim ;
|
swap >>dim ;
|
||||||
|
|
||||||
M: cairo-gadget draw-gadget*
|
M: cairo-gadget draw-gadget*
|
||||||
[ dim>> ] [ render-cairo ] bi
|
[
|
||||||
origin get first2 glRasterPos2i
|
[ dim>> ] [ render-cairo &free ] bi
|
||||||
1.0 -1.0 glPixelZoom
|
origin get first2 glRasterPos2i
|
||||||
[ first2 GL_BGRA GL_UNSIGNED_BYTE ] dip
|
1.0 -1.0 glPixelZoom
|
||||||
glDrawPixels ;
|
[ first2 GL_BGRA GL_UNSIGNED_BYTE ] dip
|
||||||
|
glDrawPixels
|
||||||
|
] with-destructors ;
|
||||||
|
|
||||||
: copy-surface ( surface -- )
|
: copy-surface ( surface -- )
|
||||||
cr swap 0 0 cairo_set_source_surface
|
cr swap 0 0 cairo_set_source_surface
|
||||||
|
|
|
@ -53,7 +53,8 @@ ARTICLE: { "concurrency" "synchronous-sends" } "Synchronous sends"
|
||||||
{ $subsection reply-synchronous }
|
{ $subsection reply-synchronous }
|
||||||
"An example:"
|
"An example:"
|
||||||
{ $example
|
{ $example
|
||||||
"USING: concurrency.messaging kernel threads ;"
|
"USING: concurrency.messaging kernel prettyprint threads ;"
|
||||||
|
"IN: scratchpad"
|
||||||
": pong-server ( -- )"
|
": pong-server ( -- )"
|
||||||
" receive [ \"pong\" ] dip reply-synchronous ;"
|
" receive [ \"pong\" ] dip reply-synchronous ;"
|
||||||
"[ pong-server t ] \"pong-server\" spawn-server"
|
"[ pong-server t ] \"pong-server\" spawn-server"
|
||||||
|
|
|
@ -11,7 +11,7 @@ HELP: eval>string
|
||||||
{ $description "Evaluates the Factor code in " { $snippet "str" } " with " { $link output-stream } " rebound to a string output stream, then outputs the resulting string." } ;
|
{ $description "Evaluates the Factor code in " { $snippet "str" } " with " { $link output-stream } " rebound to a string output stream, then outputs the resulting string." } ;
|
||||||
|
|
||||||
ARTICLE: "eval" "Evaluating strings at runtime"
|
ARTICLE: "eval" "Evaluating strings at runtime"
|
||||||
"Evaluating strings at runtime:"
|
"The " { $vocab-link "eval" } " vocabulary implements support for evaluating strings at runtime."
|
||||||
{ $subsection eval }
|
{ $subsection eval }
|
||||||
{ $subsection eval>string } ;
|
{ $subsection eval>string } ;
|
||||||
|
|
||||||
|
|
|
@ -0,0 +1,4 @@
|
||||||
|
IN: eval.tests
|
||||||
|
USING: eval tools.test ;
|
||||||
|
|
||||||
|
[ "4\n" ] [ "USING: math prettyprint ; 2 2 + ." eval>string ] unit-test
|
|
@ -1,14 +1,24 @@
|
||||||
! Copyright (C) 2008 Slava Pestov.
|
! Copyright (C) 2008, 2009 Slava Pestov.
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: splitting parser compiler.units kernel namespaces
|
USING: splitting parser compiler.units kernel namespaces
|
||||||
debugger io.streams.string ;
|
debugger io.streams.string fry ;
|
||||||
IN: eval
|
IN: eval
|
||||||
|
|
||||||
|
: parse-string ( str -- )
|
||||||
|
[ string-lines parse-lines ] with-compilation-unit ;
|
||||||
|
|
||||||
|
: (eval) ( str -- )
|
||||||
|
parse-string call ;
|
||||||
|
|
||||||
: eval ( str -- )
|
: eval ( str -- )
|
||||||
[ string-lines parse-fresh ] with-compilation-unit call ;
|
[ (eval) ] with-file-vocabs ;
|
||||||
|
|
||||||
|
: (eval>string) ( str -- output )
|
||||||
|
[
|
||||||
|
"quiet" on
|
||||||
|
parser-notes off
|
||||||
|
'[ _ (eval) ] try
|
||||||
|
] with-string-writer ;
|
||||||
|
|
||||||
: eval>string ( str -- output )
|
: eval>string ( str -- output )
|
||||||
[
|
[ (eval>string) ] with-file-vocabs ;
|
||||||
parser-notes off
|
|
||||||
[ [ eval ] keep ] try drop
|
|
||||||
] with-string-writer ;
|
|
|
@ -14,8 +14,8 @@ HELP: parse-farkup ( string -- farkup )
|
||||||
{ $description "Parses Farkup and outputs a tree of " { $link "farkup-ast" } "." } ;
|
{ $description "Parses Farkup and outputs a tree of " { $link "farkup-ast" } "." } ;
|
||||||
|
|
||||||
HELP: (write-farkup)
|
HELP: (write-farkup)
|
||||||
{ $values { "farkup" "a Farkup syntax tree node" } }
|
{ $values { "farkup" "a Farkup syntax tree node" } { "xml" "an XML chunk" } }
|
||||||
{ $description "Writes a Farkup syntax tree as HTML on " { $link output-stream } "." } ;
|
{ $description "Converts a Farkup syntax tree node to XML." } ;
|
||||||
|
|
||||||
ARTICLE: "farkup-ast" "Farkup syntax tree nodes"
|
ARTICLE: "farkup-ast" "Farkup syntax tree nodes"
|
||||||
"The " { $link parse-farkup } " word outputs a tree of nodes corresponding to the Farkup syntax of the input string. This tree can be programatically traversed and mutated before being passed on to " { $link write-farkup } "."
|
"The " { $link parse-farkup } " word outputs a tree of nodes corresponding to the Farkup syntax of the input string. This tree can be programatically traversed and mutated before being passed on to " { $link write-farkup } "."
|
||||||
|
|
|
@ -92,22 +92,22 @@ link-no-follow? off
|
||||||
[ "<p>=</p><h2>foo</h2>" ] [ "===foo==" convert-farkup ] unit-test
|
[ "<p>=</p><h2>foo</h2>" ] [ "===foo==" convert-farkup ] unit-test
|
||||||
[ "<h1>foo</h1><p>=</p>" ] [ "=foo==" convert-farkup ] unit-test
|
[ "<h1>foo</h1><p>=</p>" ] [ "=foo==" convert-farkup ] unit-test
|
||||||
|
|
||||||
[ "<pre><span class='KEYWORD3'>int</span> <span class='FUNCTION'>main</span><span class='OPERATOR'>(</span><span class='OPERATOR'>)</span>\n</pre>" ]
|
[ "<pre><span class=\"KEYWORD3\">int</span> <span class=\"FUNCTION\">main</span><span class=\"OPERATOR\">(</span><span class=\"OPERATOR\">)</span></pre>" ]
|
||||||
[ "[c{int main()}]" convert-farkup ] unit-test
|
[ "[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\"/></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><img src=\"lol.jpg\" alt=\"teh lol\"/></p>" ] [ "[[image:lol.jpg|teh lol]]" convert-farkup ] unit-test
|
||||||
[ "<p><a href='http://lol.com'>http://lol.com</a></p>" ] [ "[[http://lol.com]]" convert-farkup ] unit-test
|
[ "<p><a href=\"http://lol.com\">http://lol.com</a></p>" ] [ "[[http://lol.com]]" convert-farkup ] unit-test
|
||||||
[ "<p><a href='http://lol.com'>haha</a></p>" ] [ "[[http://lol.com|haha]]" convert-farkup ] unit-test
|
[ "<p><a href=\"http://lol.com\">haha</a></p>" ] [ "[[http://lol.com|haha]]" convert-farkup ] unit-test
|
||||||
[ "<p><a href='Foo/Bar'>Bar</a></p>" ] [ "[[Foo/Bar]]" convert-farkup ] unit-test
|
[ "<p><a href=\"Foo/Bar\">Bar</a></p>" ] [ "[[Foo/Bar]]" convert-farkup ] unit-test
|
||||||
|
|
||||||
"/wiki/view/" relative-link-prefix [
|
"/wiki/view/" relative-link-prefix [
|
||||||
[ "<p><a href='/wiki/view/Foo/Bar'>Bar</a></p>" ] [ "[[Foo/Bar]]" convert-farkup ] unit-test
|
[ "<p><a href=\"/wiki/view/Foo/Bar\">Bar</a></p>" ] [ "[[Foo/Bar]]" convert-farkup ] unit-test
|
||||||
] with-variable
|
] with-variable
|
||||||
|
|
||||||
[ ] [ "[{}]" convert-farkup drop ] unit-test
|
[ ] [ "[{}]" convert-farkup drop ] unit-test
|
||||||
|
|
||||||
[ "<pre>hello\n</pre>" ] [ "[{hello}]" convert-farkup ] unit-test
|
[ "<pre>hello</pre>" ] [ "[{hello}]" convert-farkup ] 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>"
|
"<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>"
|
||||||
|
@ -118,15 +118,15 @@ link-no-follow? off
|
||||||
] [ "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
|
] [ "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>This wiki is written in <a href='Factor'>Factor</a> and is hosted on a <a href='http://linode.com'>http://linode.com</a> virtual server.</p>"
|
"<p>This wiki is written in <a href=\"Factor\">Factor</a> and is hosted on a <a href=\"http://linode.com\">http://linode.com</a> virtual server.</p>"
|
||||||
] [
|
] [
|
||||||
"This wiki is written in [[Factor]] and is hosted on a [[http://linode.com|http://linode.com]] virtual server."
|
"This wiki is written in [[Factor]] and is hosted on a [[http://linode.com|http://linode.com]] virtual server."
|
||||||
convert-farkup
|
convert-farkup
|
||||||
] unit-test
|
] unit-test
|
||||||
|
|
||||||
[ "<p><a href='a'>a</a> <a href='b'>c</a></p>" ] [ "[[a]] [[b|c]]" convert-farkup ] unit-test
|
[ "<p><a href=\"a\">a</a> <a href=\"b\">c</a></p>" ] [ "[[a]] [[b|c]]" convert-farkup ] unit-test
|
||||||
|
|
||||||
[ "<p><a href='C%2b%2b'>C++</a></p>" ] [ "[[C++]]" convert-farkup ] unit-test
|
[ "<p><a href=\"C%2b%2b\">C++</a></p>" ] [ "[[C++]]" convert-farkup ] unit-test
|
||||||
|
|
||||||
[ "<p><foo></p>" ] [ "<foo>" convert-farkup ] unit-test
|
[ "<p><foo></p>" ] [ "<foo>" convert-farkup ] unit-test
|
||||||
|
|
||||||
|
@ -138,10 +138,10 @@ link-no-follow? off
|
||||||
[ "<hr/>" ] [ "___" convert-farkup ] unit-test
|
[ "<hr/>" ] [ "___" convert-farkup ] unit-test
|
||||||
[ "<hr/>\n" ] [ "___\n" convert-farkup ] unit-test
|
[ "<hr/>\n" ] [ "___\n" convert-farkup ] unit-test
|
||||||
|
|
||||||
[ "<p>before:\n<pre><span class='OPERATOR'>{</span> <span class='DIGIT'>1</span> <span class='DIGIT'>2</span> <span class='DIGIT'>3</span> <span class='OPERATOR'>}</span> <span class='DIGIT'>1</span> tail\n</pre></p>" ]
|
[ "<p>before:\n<pre><span class=\"OPERATOR\">{</span> <span class=\"DIGIT\">1</span> <span class=\"DIGIT\">2</span> <span class=\"DIGIT\">3</span> <span class=\"OPERATOR\">}</span> <span class=\"DIGIT\">1</span> tail</pre></p>" ]
|
||||||
[ "before:\n[factor{{ 1 2 3 } 1 tail}]" convert-farkup ] unit-test
|
[ "before:\n[factor{{ 1 2 3 } 1 tail}]" convert-farkup ] unit-test
|
||||||
|
|
||||||
[ "<p><a href='Factor'>Factor</a>-rific!</p>" ]
|
[ "<p><a href=\"Factor\">Factor</a>-rific!</p>" ]
|
||||||
[ "[[Factor]]-rific!" convert-farkup ] unit-test
|
[ "[[Factor]]-rific!" convert-farkup ] unit-test
|
||||||
|
|
||||||
[ "<p>[ factor { 1 2 3 }]</p>" ]
|
[ "<p>[ factor { 1 2 3 }]</p>" ]
|
||||||
|
@ -163,7 +163,7 @@ link-no-follow? off
|
||||||
convert-farkup string>xml-chunk
|
convert-farkup string>xml-chunk
|
||||||
"a" deep-tag-named "href" swap at url-decode ;
|
"a" deep-tag-named "href" swap at url-decode ;
|
||||||
|
|
||||||
[ "Trader Joe's" ] [ "[[Trader Joe's]]" check-link-escaping ] unit-test
|
[ "Trader Joe\"s" ] [ "[[Trader Joe\"s]]" check-link-escaping ] unit-test
|
||||||
[ "<foo>" ] [ "[[<foo>]]" check-link-escaping ] unit-test
|
[ "<foo>" ] [ "[[<foo>]]" check-link-escaping ] unit-test
|
||||||
[ "&blah;" ] [ "[[&blah;]]" check-link-escaping ] unit-test
|
[ "&blah;" ] [ "[[&blah;]]" check-link-escaping ] unit-test
|
||||||
[ "C++" ] [ "[[C++]]" check-link-escaping ] unit-test
|
[ "C++" ] [ "[[C++]]" check-link-escaping ] unit-test
|
||||||
|
|
|
@ -2,8 +2,9 @@
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: accessors arrays combinators html.elements io
|
USING: accessors arrays combinators html.elements io
|
||||||
io.streams.string kernel math namespaces peg peg.ebnf
|
io.streams.string kernel math namespaces peg peg.ebnf
|
||||||
sequences sequences.deep strings xml.entities
|
sequences sequences.deep strings xml.entities xml.interpolate
|
||||||
vectors splitting xmode.code2html urls.encoding ;
|
vectors splitting xmode.code2html urls.encoding xml.data
|
||||||
|
xml.writer ;
|
||||||
IN: farkup
|
IN: farkup
|
||||||
|
|
||||||
SYMBOL: relative-link-prefix
|
SYMBOL: relative-link-prefix
|
||||||
|
@ -74,6 +75,7 @@ inline-code = "%" (!("%" | nl).)+ "%"
|
||||||
=> [[ second >string inline-code boa ]]
|
=> [[ second >string inline-code boa ]]
|
||||||
|
|
||||||
link-content = (!("|"|"]").)+
|
link-content = (!("|"|"]").)+
|
||||||
|
=> [[ >string ]]
|
||||||
|
|
||||||
image-link = "[[image:" link-content "|" link-content "]]"
|
image-link = "[[image:" link-content "|" link-content "]]"
|
||||||
=> [[ [ second >string ] [ fourth >string ] bi image boa ]]
|
=> [[ [ second >string ] [ fourth >string ] bi image boa ]]
|
||||||
|
@ -146,7 +148,7 @@ named-code
|
||||||
|
|
||||||
simple-code
|
simple-code
|
||||||
= "[{" (!("}]").)+ "}]"
|
= "[{" (!("}]").)+ "}]"
|
||||||
=> [[ second f swap code boa ]]
|
=> [[ second >string f swap code boa ]]
|
||||||
|
|
||||||
code = named-code | simple-code
|
code = named-code | simple-code
|
||||||
|
|
||||||
|
@ -163,66 +165,78 @@ stand-alone
|
||||||
{ [ dup [ 127 > ] contains? ] [ drop invalid-url ] }
|
{ [ dup [ 127 > ] contains? ] [ drop invalid-url ] }
|
||||||
{ [ dup first "/\\" member? ] [ drop invalid-url ] }
|
{ [ dup first "/\\" member? ] [ drop invalid-url ] }
|
||||||
{ [ CHAR: : over member? ] [ dup absolute-url? [ drop invalid-url ] unless ] }
|
{ [ CHAR: : over member? ] [ dup absolute-url? [ drop invalid-url ] unless ] }
|
||||||
[ relative-link-prefix get prepend ]
|
[ relative-link-prefix get prepend "" like ]
|
||||||
} cond ;
|
} cond url-encode ;
|
||||||
|
|
||||||
: escape-link ( href text -- href-esc text-esc )
|
: write-link ( href text -- xml )
|
||||||
[ check-url ] dip escape-string ;
|
[ check-url link-no-follow? get "true" and ] dip
|
||||||
|
[XML <a href=<-> nofollow=<->><-></a> XML] ;
|
||||||
|
|
||||||
: write-link ( href text -- )
|
: write-image-link ( href text -- xml )
|
||||||
escape-link
|
|
||||||
[ <a url-encode =href link-no-follow? get [ "true" =nofollow ] when a> ]
|
|
||||||
[ write </a> ]
|
|
||||||
bi* ;
|
|
||||||
|
|
||||||
: write-image-link ( href text -- )
|
|
||||||
disable-images? get [
|
disable-images? get [
|
||||||
2drop
|
2drop
|
||||||
<strong> "Images are not allowed" write </strong>
|
[XML <strong>Images are not allowed</strong> XML]
|
||||||
] [
|
] [
|
||||||
escape-link
|
[ check-url ] [ f like ] bi*
|
||||||
[ <img url-encode =src ] [ [ =alt ] unless-empty img/> ] bi*
|
[XML <img src=<-> alt=<->/> XML]
|
||||||
] if ;
|
] if ;
|
||||||
|
|
||||||
: render-code ( string mode -- string' )
|
: render-code ( string mode -- xml )
|
||||||
[ string-lines ] dip
|
[ string-lines ] dip htmlize-lines
|
||||||
[
|
[XML <pre><-></pre> XML] ;
|
||||||
<pre>
|
|
||||||
htmlize-lines
|
|
||||||
</pre>
|
|
||||||
] with-string-writer write ;
|
|
||||||
|
|
||||||
GENERIC: (write-farkup) ( farkup -- )
|
GENERIC: (write-farkup) ( farkup -- xml )
|
||||||
: <foo.> ( string -- ) <foo> write ;
|
|
||||||
: </foo.> ( string -- ) </foo> write ;
|
|
||||||
: in-tag. ( obj quot string -- ) [ <foo.> call ] keep </foo.> ; inline
|
|
||||||
M: heading1 (write-farkup) [ child>> (write-farkup) ] "h1" in-tag. ;
|
|
||||||
M: heading2 (write-farkup) [ child>> (write-farkup) ] "h2" in-tag. ;
|
|
||||||
M: heading3 (write-farkup) [ child>> (write-farkup) ] "h3" in-tag. ;
|
|
||||||
M: heading4 (write-farkup) [ child>> (write-farkup) ] "h4" in-tag. ;
|
|
||||||
M: strong (write-farkup) [ child>> (write-farkup) ] "strong" in-tag. ;
|
|
||||||
M: emphasis (write-farkup) [ child>> (write-farkup) ] "em" in-tag. ;
|
|
||||||
M: superscript (write-farkup) [ child>> (write-farkup) ] "sup" in-tag. ;
|
|
||||||
M: subscript (write-farkup) [ child>> (write-farkup) ] "sub" in-tag. ;
|
|
||||||
M: inline-code (write-farkup) [ child>> (write-farkup) ] "code" in-tag. ;
|
|
||||||
M: list-item (write-farkup) [ child>> (write-farkup) ] "li" in-tag. ;
|
|
||||||
M: unordered-list (write-farkup) [ child>> (write-farkup) ] "ul" in-tag. ;
|
|
||||||
M: ordered-list (write-farkup) [ child>> (write-farkup) ] "ol" in-tag. ;
|
|
||||||
M: paragraph (write-farkup) [ child>> (write-farkup) ] "p" in-tag. ;
|
|
||||||
M: link (write-farkup) [ href>> ] [ text>> ] bi write-link ;
|
|
||||||
M: image (write-farkup) [ href>> ] [ text>> ] bi write-image-link ;
|
|
||||||
M: code (write-farkup) [ string>> ] [ mode>> ] bi render-code ;
|
|
||||||
M: line (write-farkup) drop <hr/> ;
|
|
||||||
M: line-break (write-farkup) drop <br/> nl ;
|
|
||||||
M: table-row (write-farkup) ( obj -- )
|
|
||||||
child>> [ [ [ (write-farkup) ] "td" in-tag. ] each ] "tr" in-tag. ;
|
|
||||||
M: table (write-farkup) [ child>> (write-farkup) ] "table" in-tag. ;
|
|
||||||
M: string (write-farkup) escape-string write ;
|
|
||||||
M: vector (write-farkup) [ (write-farkup) ] each ;
|
|
||||||
M: f (write-farkup) drop ;
|
|
||||||
|
|
||||||
: write-farkup ( string -- )
|
: farkup-inside ( farkup name -- xml )
|
||||||
|
<simple-name> swap T{ attrs } swap
|
||||||
|
child>> (write-farkup) 1array <tag> ;
|
||||||
|
|
||||||
|
M: heading1 (write-farkup) "h1" farkup-inside ;
|
||||||
|
M: heading2 (write-farkup) "h2" farkup-inside ;
|
||||||
|
M: heading3 (write-farkup) "h3" farkup-inside ;
|
||||||
|
M: heading4 (write-farkup) "h4" farkup-inside ;
|
||||||
|
M: strong (write-farkup) "strong" farkup-inside ;
|
||||||
|
M: emphasis (write-farkup) "em" farkup-inside ;
|
||||||
|
M: superscript (write-farkup) "sup" farkup-inside ;
|
||||||
|
M: subscript (write-farkup) "sub" farkup-inside ;
|
||||||
|
M: inline-code (write-farkup) "code" farkup-inside ;
|
||||||
|
M: list-item (write-farkup) "li" farkup-inside ;
|
||||||
|
M: unordered-list (write-farkup) "ul" farkup-inside ;
|
||||||
|
M: ordered-list (write-farkup) "ol" farkup-inside ;
|
||||||
|
M: paragraph (write-farkup) "p" farkup-inside ;
|
||||||
|
M: table (write-farkup) "table" farkup-inside ;
|
||||||
|
|
||||||
|
M: link (write-farkup)
|
||||||
|
[ href>> ] [ text>> ] bi write-link ;
|
||||||
|
|
||||||
|
M: image (write-farkup)
|
||||||
|
[ href>> ] [ text>> ] bi write-image-link ;
|
||||||
|
|
||||||
|
M: code (write-farkup)
|
||||||
|
[ string>> ] [ mode>> ] bi render-code ;
|
||||||
|
|
||||||
|
M: line (write-farkup)
|
||||||
|
drop [XML <hr/> XML] ;
|
||||||
|
|
||||||
|
M: line-break (write-farkup)
|
||||||
|
drop [XML <br/> XML] ;
|
||||||
|
|
||||||
|
M: table-row (write-farkup)
|
||||||
|
child>>
|
||||||
|
[ (write-farkup) [XML <td><-></td> XML] ] map
|
||||||
|
[XML <tr><-></tr> XML] ;
|
||||||
|
|
||||||
|
M: string (write-farkup) ;
|
||||||
|
|
||||||
|
M: vector (write-farkup) [ (write-farkup) ] map ;
|
||||||
|
|
||||||
|
M: f (write-farkup) ;
|
||||||
|
|
||||||
|
: farkup>xml ( string -- xml )
|
||||||
parse-farkup (write-farkup) ;
|
parse-farkup (write-farkup) ;
|
||||||
|
|
||||||
|
: write-farkup ( string -- )
|
||||||
|
farkup>xml write-xml-chunk ;
|
||||||
|
|
||||||
: convert-farkup ( string -- string' )
|
: convert-farkup ( string -- string' )
|
||||||
parse-farkup [ (write-farkup) ] with-string-writer ;
|
[ write-farkup ] with-string-writer ;
|
||||||
|
|
|
@ -7,7 +7,7 @@ HELP: printf
|
||||||
{ $values { "format-string" string } }
|
{ $values { "format-string" string } }
|
||||||
{ $description
|
{ $description
|
||||||
"Writes the arguments (specified on the stack) formatted according to the format string.\n"
|
"Writes the arguments (specified on the stack) formatted according to the format string.\n"
|
||||||
"\n"
|
$nl
|
||||||
"Several format specifications exist for handling arguments of different types, and "
|
"Several format specifications exist for handling arguments of different types, and "
|
||||||
"specifying attributes for the result string, including such things as maximum width, "
|
"specifying attributes for the result string, including such things as maximum width, "
|
||||||
"padding, and decimals.\n"
|
"padding, and decimals.\n"
|
||||||
|
@ -24,10 +24,10 @@ HELP: printf
|
||||||
{ "%+Px" "Hexadecimal" "hex" }
|
{ "%+Px" "Hexadecimal" "hex" }
|
||||||
{ "%+PX" "Hexadecimal uppercase" "hex" }
|
{ "%+PX" "Hexadecimal uppercase" "hex" }
|
||||||
}
|
}
|
||||||
"\n"
|
$nl
|
||||||
"A plus sign ('+') is used to optionally specify that the number should be "
|
"A plus sign ('+') is used to optionally specify that the number should be "
|
||||||
"formatted with a '+' preceeding it if positive.\n"
|
"formatted with a '+' preceeding it if positive.\n"
|
||||||
"\n"
|
$nl
|
||||||
"Padding ('P') is used to optionally specify the minimum width of the result "
|
"Padding ('P') is used to optionally specify the minimum width of the result "
|
||||||
"string, the padding character, and the alignment. By default, the padding "
|
"string, the padding character, and the alignment. By default, the padding "
|
||||||
"character defaults to a space and the alignment defaults to right-aligned. "
|
"character defaults to a space and the alignment defaults to right-aligned. "
|
||||||
|
@ -38,7 +38,7 @@ HELP: printf
|
||||||
"\"%'#5f\" formats a float padding with '#' up to 3 characters wide."
|
"\"%'#5f\" formats a float padding with '#' up to 3 characters wide."
|
||||||
"\"%-10d\" formats an integer to 10 characters wide and left-aligns."
|
"\"%-10d\" formats an integer to 10 characters wide and left-aligns."
|
||||||
}
|
}
|
||||||
"\n"
|
$nl
|
||||||
"Digits ('D') is used to optionally specify the maximum digits in the result "
|
"Digits ('D') is used to optionally specify the maximum digits in the result "
|
||||||
"string. For example:\n"
|
"string. For example:\n"
|
||||||
{ $list
|
{ $list
|
||||||
|
@ -83,7 +83,7 @@ HELP: strftime
|
||||||
{ $values { "format-string" string } }
|
{ $values { "format-string" string } }
|
||||||
{ $description
|
{ $description
|
||||||
"Writes the timestamp (specified on the stack) formatted according to the format string.\n"
|
"Writes the timestamp (specified on the stack) formatted according to the format string.\n"
|
||||||
"\n"
|
$nl
|
||||||
"Different attributes of the timestamp can be retrieved using format specifications.\n"
|
"Different attributes of the timestamp can be retrieved using format specifications.\n"
|
||||||
{ $table
|
{ $table
|
||||||
{ "%a" "Abbreviated weekday name." }
|
{ "%a" "Abbreviated weekday name." }
|
||||||
|
@ -118,7 +118,7 @@ HELP: strftime
|
||||||
} ;
|
} ;
|
||||||
|
|
||||||
ARTICLE: "formatting" "Formatted printing"
|
ARTICLE: "formatting" "Formatted printing"
|
||||||
"The " { $vocab-link "formatting" } " vocabulary is used for formatted printing.\n"
|
"The " { $vocab-link "formatting" } " vocabulary is used for formatted printing."
|
||||||
{ $subsection printf }
|
{ $subsection printf }
|
||||||
{ $subsection sprintf }
|
{ $subsection sprintf }
|
||||||
{ $subsection strftime }
|
{ $subsection strftime }
|
||||||
|
|
|
@ -69,18 +69,18 @@ ARTICLE: "fry.philosophy" "Fried quotation philosophy"
|
||||||
"'[ [ _ key? ] all? ] filter"
|
"'[ [ _ key? ] all? ] filter"
|
||||||
"[ [ key? ] curry all? ] curry filter"
|
"[ [ key? ] curry all? ] curry filter"
|
||||||
}
|
}
|
||||||
"There is a mapping from fried quotations to lexical closures as defined in the " { $vocab-link "locals" } " vocabulary. Namely, a fried quotation is equivalent to a ``let'' form where each local binding is only used once, and bindings are used in the same order in which they are defined. The following two lines are equivalent:"
|
"There is a mapping from fried quotations to lexical closures as defined in the " { $vocab-link "locals" } " vocabulary. Namely, a fried quotation is equivalent to a “let” form where each local binding is only used once, and bindings are used in the same order in which they are defined. The following two lines are equivalent:"
|
||||||
{ $code
|
{ $code
|
||||||
"'[ 3 _ + 4 _ / ]"
|
"'[ 3 _ + 4 _ / ]"
|
||||||
"[let | a [ ] b [ ] | [ 3 a + 4 b / ] ]"
|
"[let | a [ ] b [ ] | [ 3 a + 4 b / ] ]"
|
||||||
} ;
|
} ;
|
||||||
|
|
||||||
ARTICLE: "fry" "Fried quotations"
|
ARTICLE: "fry" "Fried quotations"
|
||||||
"The " { $vocab-link "fry" } " vocabulary implements " { $emphasis "fried quotation" } ". Conceptually, fried quotations are quotations with ``holes'' (more formally, " { $emphasis "fry specifiers" } "), and the holes are filled in when the fried quotation is pushed on the stack."
|
"The " { $vocab-link "fry" } " vocabulary implements " { $emphasis "fried quotation" } ". Conceptually, fried quotations are quotations with “holes” (more formally, " { $emphasis "fry specifiers" } "), and the holes are filled in when the fried quotation is pushed on the stack."
|
||||||
$nl
|
$nl
|
||||||
"Fried quotations are started by a special parsing word:"
|
"Fried quotations are started by a special parsing word:"
|
||||||
{ $subsection POSTPONE: '[ }
|
{ $subsection POSTPONE: '[ }
|
||||||
"There are two types of fry specifiers; the first can hold a value, and the second ``splices'' a quotation, as if it were inserted without surrounding brackets:"
|
"There are two types of fry specifiers; the first can hold a value, and the second “splices” a quotation, as if it were inserted without surrounding brackets:"
|
||||||
{ $subsection _ }
|
{ $subsection _ }
|
||||||
{ $subsection @ }
|
{ $subsection @ }
|
||||||
"The holes are filled in with the top of stack going in the rightmost hole, the second item on the stack going in the second hole from the right, and so on."
|
"The holes are filled in with the top of stack going in the rightmost hole, the second item on the stack going in the second hole from the right, and so on."
|
||||||
|
|
|
@ -121,7 +121,7 @@ $nl
|
||||||
{ $subsection "furnace.auth.providers.db" } ;
|
{ $subsection "furnace.auth.providers.db" } ;
|
||||||
|
|
||||||
ARTICLE: "furnace.auth.features" "Optional authentication features"
|
ARTICLE: "furnace.auth.features" "Optional authentication features"
|
||||||
"Vocabularies having names prefixed by " { $code "furnace.auth.features" } " implement optional features which can be enabled by calling special words. These words define new actions on an authentication realm."
|
"Vocabularies having names prefixed by " { $code "furnace.auth.features" } " implement optional features which can be enabled by calling special words. These words define new actions on an authentication realm."
|
||||||
{ $subsection "furnace.auth.features.deactivate-user" }
|
{ $subsection "furnace.auth.features.deactivate-user" }
|
||||||
{ $subsection "furnace.auth.features.edit-profile" }
|
{ $subsection "furnace.auth.features.edit-profile" }
|
||||||
{ $subsection "furnace.auth.features.recover-password" }
|
{ $subsection "furnace.auth.features.recover-password" }
|
||||||
|
@ -148,7 +148,7 @@ ARTICLE: "furnace.auth.users" "User profiles"
|
||||||
"User profile variables have the same restrictions on their values as session variables; see " { $link "furnace.sessions.serialize" } " for a discussion." ;
|
"User profile variables have the same restrictions on their values as session variables; see " { $link "furnace.sessions.serialize" } " for a discussion." ;
|
||||||
|
|
||||||
ARTICLE: "furnace.auth.example" "Furnace authentication example"
|
ARTICLE: "furnace.auth.example" "Furnace authentication example"
|
||||||
"The " { $vocab-link "webapps.todo" } " vocabulary wraps all of its responders in a protected responder. The " { $slot "description" } " slot is set so that the login page contains the message ``You must log in to view your todo list'':"
|
"The " { $vocab-link "webapps.todo" } " vocabulary wraps all of its responders in a protected responder. The " { $slot "description" } " slot is set so that the login page contains the message “You must log in to view your todo list”:"
|
||||||
{ $code
|
{ $code
|
||||||
<" <protected>
|
<" <protected>
|
||||||
"view your todo list" >>description">
|
"view your todo list" >>description">
|
||||||
|
|
|
@ -27,7 +27,7 @@ SYMBOL: lost-password-from
|
||||||
over email>> 1array >>to
|
over email>> 1array >>to
|
||||||
[
|
[
|
||||||
"This e-mail was sent by the application server on " % current-host % "\n" %
|
"This e-mail was sent by the application server on " % current-host % "\n" %
|
||||||
"because somebody, maybe you, clicked on a ``recover password'' link in the\n" %
|
"because somebody, maybe you, clicked on a “recover password” link in the\n" %
|
||||||
"login form, and requested a new password for the user named ``" %
|
"login form, and requested a new password for the user named ``" %
|
||||||
over username>> % "''.\n" %
|
over username>> % "''.\n" %
|
||||||
"\n" %
|
"\n" %
|
||||||
|
|
|
@ -29,7 +29,7 @@ HELP: feed-entry-date
|
||||||
HELP: feed-entry-description
|
HELP: feed-entry-description
|
||||||
{ $values
|
{ $values
|
||||||
{ "object" object }
|
{ "object" object }
|
||||||
{ "description" null }
|
{ "description" string }
|
||||||
}
|
}
|
||||||
{ $contract "Outputs a feed entry description." } ;
|
{ $contract "Outputs a feed entry description." } ;
|
||||||
|
|
||||||
|
|
|
@ -1,4 +1,4 @@
|
||||||
! Copyright (C) 2006, 2008 Slava Pestov.
|
! Copyright (C) 2006, 2009 Slava Pestov.
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: fry accessors sequences parser kernel help help.markup
|
USING: fry accessors sequences parser kernel help help.markup
|
||||||
help.topics words strings classes tools.vocabs namespaces make
|
help.topics words strings classes tools.vocabs namespaces make
|
||||||
|
@ -6,21 +6,24 @@ io io.streams.string prettyprint definitions arrays vectors
|
||||||
combinators combinators.short-circuit splitting debugger
|
combinators combinators.short-circuit splitting debugger
|
||||||
hashtables sorting effects vocabs vocabs.loader assocs editors
|
hashtables sorting effects vocabs vocabs.loader assocs editors
|
||||||
continuations classes.predicate macros math sets eval
|
continuations classes.predicate macros math sets eval
|
||||||
vocabs.parser words.symbol values ;
|
vocabs.parser words.symbol values grouping unicode.categories
|
||||||
|
sequences.deep ;
|
||||||
IN: help.lint
|
IN: help.lint
|
||||||
|
|
||||||
: check-example ( element -- )
|
SYMBOL: vocabs-quot
|
||||||
rest [
|
|
||||||
but-last "\n" join 1vector
|
|
||||||
[
|
|
||||||
use [ clone ] change
|
|
||||||
[ eval>string ] with-datastack
|
|
||||||
] with-scope peek "\n" ?tail drop
|
|
||||||
] keep
|
|
||||||
peek assert= ;
|
|
||||||
|
|
||||||
: check-examples ( word element -- )
|
: check-example ( element -- )
|
||||||
nip \ $example swap elements [ check-example ] each ;
|
[
|
||||||
|
rest [
|
||||||
|
but-last "\n" join 1vector
|
||||||
|
[ (eval>string) ] with-datastack
|
||||||
|
peek "\n" ?tail drop
|
||||||
|
] keep
|
||||||
|
peek assert=
|
||||||
|
] vocabs-quot get call ;
|
||||||
|
|
||||||
|
: check-examples ( element -- )
|
||||||
|
\ $example swap elements [ check-example ] each ;
|
||||||
|
|
||||||
: extract-values ( element -- seq )
|
: extract-values ( element -- seq )
|
||||||
\ $values swap elements dup empty? [
|
\ $values swap elements dup empty? [
|
||||||
|
@ -64,8 +67,13 @@ IN: help.lint
|
||||||
]
|
]
|
||||||
} 2|| [ "$values don't match stack effect" throw ] unless ;
|
} 2|| [ "$values don't match stack effect" throw ] unless ;
|
||||||
|
|
||||||
: check-see-also ( word element -- )
|
: check-nulls ( element -- )
|
||||||
nip \ $see-also swap elements [
|
\ $values swap elements
|
||||||
|
null swap deep-member?
|
||||||
|
[ "$values should not contain null" throw ] when ;
|
||||||
|
|
||||||
|
: check-see-also ( element -- )
|
||||||
|
\ $see-also swap elements [
|
||||||
rest dup prune [ length ] bi@ assert=
|
rest dup prune [ length ] bi@ assert=
|
||||||
] each ;
|
] each ;
|
||||||
|
|
||||||
|
@ -79,43 +87,78 @@ IN: help.lint
|
||||||
] each ;
|
] each ;
|
||||||
|
|
||||||
: check-rendering ( element -- )
|
: check-rendering ( element -- )
|
||||||
[ print-topic ] with-string-writer drop ;
|
[ print-content ] with-string-writer drop ;
|
||||||
|
|
||||||
|
: check-strings ( str -- )
|
||||||
|
[
|
||||||
|
"\n\t" intersects?
|
||||||
|
[ "Paragraph text should not contain \\n or \\t" throw ] when
|
||||||
|
] [
|
||||||
|
" " swap subseq?
|
||||||
|
[ "Paragraph text should not contain double spaces" throw ] when
|
||||||
|
] bi ;
|
||||||
|
|
||||||
|
: check-whitespace ( str1 str2 -- )
|
||||||
|
[ " " tail? ] [ " " head? ] bi* or
|
||||||
|
[ "Missing whitespace between strings" throw ] unless ;
|
||||||
|
|
||||||
|
: check-bogus-nl ( element -- )
|
||||||
|
{ { $nl } { { $nl } } } [ head? ] with contains?
|
||||||
|
[ "Simple element should not begin with a paragraph break" throw ] when ;
|
||||||
|
|
||||||
|
: check-elements ( element -- )
|
||||||
|
{
|
||||||
|
[ check-bogus-nl ]
|
||||||
|
[ [ string? ] filter [ check-strings ] each ]
|
||||||
|
[ [ simple-element? ] filter [ check-elements ] each ]
|
||||||
|
[ 2 <clumps> [ [ string? ] all? ] filter [ first2 check-whitespace ] each ]
|
||||||
|
} cleave ;
|
||||||
|
|
||||||
|
: check-markup ( element -- )
|
||||||
|
{
|
||||||
|
[ check-elements ]
|
||||||
|
[ check-rendering ]
|
||||||
|
[ check-examples ]
|
||||||
|
[ check-modules ]
|
||||||
|
} cleave ;
|
||||||
|
|
||||||
: all-word-help ( words -- seq )
|
: all-word-help ( words -- seq )
|
||||||
[ word-help ] filter ;
|
[ word-help ] filter ;
|
||||||
|
|
||||||
TUPLE: help-error topic error ;
|
TUPLE: help-error error topic ;
|
||||||
|
|
||||||
C: <help-error> help-error
|
C: <help-error> help-error
|
||||||
|
|
||||||
M: help-error error.
|
M: help-error error.
|
||||||
"In " write dup topic>> pprint nl
|
[ "In " write topic>> pprint nl ]
|
||||||
error>> error. ;
|
[ error>> error. ]
|
||||||
|
bi ;
|
||||||
|
|
||||||
: check-something ( obj quot -- )
|
: check-something ( obj quot -- )
|
||||||
flush [ <help-error> , ] recover ; inline
|
flush '[ _ assert-depth ] swap '[ _ <help-error> , ] recover ; inline
|
||||||
|
|
||||||
: check-word ( word -- )
|
: check-word ( word -- )
|
||||||
|
[ with-file-vocabs ] vocabs-quot set
|
||||||
dup word-help [
|
dup word-help [
|
||||||
[
|
dup '[
|
||||||
dup word-help '[
|
_ dup word-help
|
||||||
_ _ {
|
[ check-values ]
|
||||||
[ check-examples ]
|
[ nip [ check-nulls ] [ check-see-also ] [ check-markup ] tri ] 2bi
|
||||||
[ check-values ]
|
|
||||||
[ check-see-also ]
|
|
||||||
[ [ check-rendering ] [ check-modules ] bi* ]
|
|
||||||
} 2cleave
|
|
||||||
] assert-depth
|
|
||||||
] check-something
|
] check-something
|
||||||
] [ drop ] if ;
|
] [ drop ] if ;
|
||||||
|
|
||||||
: check-words ( words -- ) [ check-word ] each ;
|
: check-words ( words -- ) [ check-word ] each ;
|
||||||
|
|
||||||
|
: check-article-title ( article -- )
|
||||||
|
article-title first LETTER?
|
||||||
|
[ "Article title must begin with a capital letter" throw ] unless ;
|
||||||
|
|
||||||
: check-article ( article -- )
|
: check-article ( article -- )
|
||||||
[
|
[ with-interactive-vocabs ] vocabs-quot set
|
||||||
dup article-content
|
dup '[
|
||||||
'[ _ check-rendering _ check-modules ]
|
_
|
||||||
assert-depth
|
[ check-article-title ]
|
||||||
|
[ article-content check-markup ] bi
|
||||||
] check-something ;
|
] check-something ;
|
||||||
|
|
||||||
: files>vocabs ( -- assoc )
|
: files>vocabs ( -- assoc )
|
||||||
|
@ -135,7 +178,7 @@ M: help-error error.
|
||||||
] keep ;
|
] keep ;
|
||||||
|
|
||||||
: check-about ( vocab -- )
|
: check-about ( vocab -- )
|
||||||
[ vocab-help [ article drop ] when* ] check-something ;
|
dup '[ _ vocab-help [ article drop ] when* ] check-something ;
|
||||||
|
|
||||||
: check-vocab ( vocab -- seq )
|
: check-vocab ( vocab -- seq )
|
||||||
"Checking " write dup write "..." print
|
"Checking " write dup write "..." print
|
||||||
|
|
|
@ -30,7 +30,7 @@ ARTICLE: "first-program-logic" "Writing some logic in your first program"
|
||||||
"! See http://factorcode.org/license.txt for BSD license."
|
"! See http://factorcode.org/license.txt for BSD license."
|
||||||
"IN: palindrome"
|
"IN: palindrome"
|
||||||
}
|
}
|
||||||
"We will now write our first word using " { $link POSTPONE: : } ". This word will test if a string is a palindrome; it will take a string as input, and give back a boolean as output. We will call this word " { $snippet "palindrome?" } ", following a naming convention that words returning booleans have names ending with " { $snippet "?" } "."
|
"We will now write our first word using " { $link POSTPONE: : } ". This word will test if a string is a palindrome; it will take a string as input, and give back a boolean as output. We will call this word " { $snippet "palindrome?" } ", following a naming convention that words returning booleans have names ending with " { $snippet "?" } "."
|
||||||
$nl
|
$nl
|
||||||
"Recall that a string is a palindrome if it is spelled the same forwards or backwards; that is, if the string is equal to its reverse. We can express this in Factor as follows:"
|
"Recall that a string is a palindrome if it is spelled the same forwards or backwards; that is, if the string is equal to its reverse. We can express this in Factor as follows:"
|
||||||
{ $code ": palindrome? ( string -- ? ) dup reverse = ;" }
|
{ $code ": palindrome? ( string -- ? ) dup reverse = ;" }
|
||||||
|
@ -94,7 +94,7 @@ $nl
|
||||||
"For example, we'd like it to identify the following as a palindrome:"
|
"For example, we'd like it to identify the following as a palindrome:"
|
||||||
{ $code "\"A man, a plan, a canal: Panama.\"" }
|
{ $code "\"A man, a plan, a canal: Panama.\"" }
|
||||||
"However, right now, the simplistic algorithm we use says this is not a palindrome:"
|
"However, right now, the simplistic algorithm we use says this is not a palindrome:"
|
||||||
{ $example "\"A man, a plan, a canal: Panama.\" palindrome?" "f" }
|
{ $unchecked-example "\"A man, a plan, a canal: Panama.\" palindrome?" "f" }
|
||||||
"We would like it to output " { $link t } " there. We can encode this requirement with a unit test that we add to " { $snippet "palindrome-tests.factor" } ":"
|
"We would like it to output " { $link t } " there. We can encode this requirement with a unit test that we add to " { $snippet "palindrome-tests.factor" } ":"
|
||||||
{ $code "[ t ] [ \"A man, a plan, a canal: Panama.\" palindrome? ] unit-test" }
|
{ $code "[ t ] [ \"A man, a plan, a canal: Panama.\" palindrome? ] unit-test" }
|
||||||
"If you now run unit tests, you will see a unit test failure:"
|
"If you now run unit tests, you will see a unit test failure:"
|
||||||
|
@ -106,12 +106,12 @@ $nl
|
||||||
"Start by pushing a character on the stack; notice that characters are really just integers:"
|
"Start by pushing a character on the stack; notice that characters are really just integers:"
|
||||||
{ $code "CHAR: a" }
|
{ $code "CHAR: a" }
|
||||||
"Now, use the " { $link Letter? } " word to test if it is an alphabetical character, upper or lower case:"
|
"Now, use the " { $link Letter? } " word to test if it is an alphabetical character, upper or lower case:"
|
||||||
{ $example "Letter? ." "t" }
|
{ $unchecked-example "Letter? ." "t" }
|
||||||
"This gives the expected result."
|
"This gives the expected result."
|
||||||
$nl
|
$nl
|
||||||
"Now try with a non-alphabetical character:"
|
"Now try with a non-alphabetical character:"
|
||||||
{ $code "CHAR: #" }
|
{ $code "CHAR: #" }
|
||||||
{ $example "Letter? ." "f" }
|
{ $unchecked-example "Letter? ." "f" }
|
||||||
"What we want to do is given a string, remove all characters which do not match the " { $link Letter? } " predicate. Let's push a string on the stack:"
|
"What we want to do is given a string, remove all characters which do not match the " { $link Letter? } " predicate. Let's push a string on the stack:"
|
||||||
{ $code "\"A man, a plan, a canal: Panama.\"" }
|
{ $code "\"A man, a plan, a canal: Panama.\"" }
|
||||||
"Now, place a quotation containing " { $link Letter? } " on the stack; quoting code places it on the stack instead of executing it immediately:"
|
"Now, place a quotation containing " { $link Letter? } " on the stack; quoting code places it on the stack instead of executing it immediately:"
|
||||||
|
|
|
@ -70,8 +70,8 @@ HELP: render
|
||||||
{ $description "Renders an HTML component to the " { $link output-stream } "." } ;
|
{ $description "Renders an HTML component to the " { $link output-stream } "." } ;
|
||||||
|
|
||||||
HELP: render*
|
HELP: render*
|
||||||
{ $values { "value" "a value" } { "name" "a value name" } { "renderer" "a component renderer" } }
|
{ $values { "value" "a value" } { "name" "a value name" } { "renderer" "a component renderer" } { "xml" "an XML chunk" } }
|
||||||
{ $contract "Renders an HTML component to the " { $link output-stream } "." } ;
|
{ $contract "Renders an HTML component, outputting an XHTML snippet." } ;
|
||||||
|
|
||||||
ARTICLE: "html.components" "HTML components"
|
ARTICLE: "html.components" "HTML components"
|
||||||
"The " { $vocab-link "html.components" } " vocabulary provides various HTML form components."
|
"The " { $vocab-link "html.components" } " vocabulary provides various HTML form components."
|
||||||
|
|
|
@ -31,7 +31,7 @@ TUPLE: color red green blue ;
|
||||||
] with-string-writer
|
] with-string-writer
|
||||||
] unit-test
|
] unit-test
|
||||||
|
|
||||||
[ "<input type='hidden' name='red' value='<jimmy>'/>" ] [
|
[ "<input value=\"<jimmy>\" name=\"red\" type=\"hidden\"/>" ] [
|
||||||
[
|
[
|
||||||
"red" hidden render
|
"red" hidden render
|
||||||
] with-string-writer
|
] with-string-writer
|
||||||
|
@ -39,13 +39,13 @@ TUPLE: color red green blue ;
|
||||||
|
|
||||||
[ ] [ "'jimmy'" "red" set-value ] unit-test
|
[ ] [ "'jimmy'" "red" set-value ] unit-test
|
||||||
|
|
||||||
[ "<input type='text' size='5' name='red' value=''jimmy''/>" ] [
|
[ "<input value=\"'jimmy'\" name=\"red\" size=\"5\" type=\"text\"/>" ] [
|
||||||
[
|
[
|
||||||
"red" <field> 5 >>size render
|
"red" <field> 5 >>size render
|
||||||
] with-string-writer
|
] with-string-writer
|
||||||
] unit-test
|
] unit-test
|
||||||
|
|
||||||
[ "<input type='password' size='5' name='red' value=''/>" ] [
|
[ "<input value=\"\" name=\"red\" size=\"5\" type=\"password\"/>" ] [
|
||||||
[
|
[
|
||||||
"red" <password> 5 >>size render
|
"red" <password> 5 >>size render
|
||||||
] with-string-writer
|
] with-string-writer
|
||||||
|
@ -105,7 +105,7 @@ TUPLE: color red green blue ;
|
||||||
|
|
||||||
[ ] [ t "delivery" set-value ] unit-test
|
[ ] [ t "delivery" set-value ] unit-test
|
||||||
|
|
||||||
[ "<input type='checkbox' name='delivery' checked='true'>Delivery</input>" ] [
|
[ "<input type=\"checkbox\" checked=\"true\" name=\"delivery\">Delivery</input>" ] [
|
||||||
[
|
[
|
||||||
"delivery"
|
"delivery"
|
||||||
<checkbox>
|
<checkbox>
|
||||||
|
@ -116,7 +116,7 @@ TUPLE: color red green blue ;
|
||||||
|
|
||||||
[ ] [ f "delivery" set-value ] unit-test
|
[ ] [ f "delivery" set-value ] unit-test
|
||||||
|
|
||||||
[ "<input type='checkbox' name='delivery'>Delivery</input>" ] [
|
[ "<input type=\"checkbox\" name=\"delivery\">Delivery</input>" ] [
|
||||||
[
|
[
|
||||||
"delivery"
|
"delivery"
|
||||||
<checkbox>
|
<checkbox>
|
||||||
|
@ -133,7 +133,7 @@ M: link-test link-href drop "http://www.apple.com/foo&bar" ;
|
||||||
|
|
||||||
[ ] [ link-test "link" set-value ] unit-test
|
[ ] [ link-test "link" set-value ] unit-test
|
||||||
|
|
||||||
[ "<a href='http://www.apple.com/foo&bar'><Link Title></a>" ] [
|
[ "<a href=\"http://www.apple.com/foo&bar\"><Link Title></a>" ] [
|
||||||
[ "link" link new render ] with-string-writer
|
[ "link" link new render ] with-string-writer
|
||||||
] unit-test
|
] unit-test
|
||||||
|
|
||||||
|
@ -149,7 +149,7 @@ M: link-test link-href drop "http://www.apple.com/foo&bar" ;
|
||||||
|
|
||||||
[ ] [ "java" "mode" 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" ] [
|
[ "<span class=\"KEYWORD3\">int</span> x <span class=\"OPERATOR\">=</span> <span class=\"DIGIT\">4</span>;" ] [
|
||||||
[ "code" <code> "mode" >>mode render ] with-string-writer
|
[ "code" <code> "mode" >>mode render ] with-string-writer
|
||||||
] unit-test
|
] unit-test
|
||||||
|
|
||||||
|
@ -163,6 +163,8 @@ M: link-test link-href drop "http://www.apple.com/foo&bar" ;
|
||||||
|
|
||||||
[ t ] [
|
[ t ] [
|
||||||
[ "object" inspector render ] with-string-writer
|
[ "object" inspector render ] with-string-writer
|
||||||
|
USING: splitting sequences ;
|
||||||
|
"\"" split "'" join ! replace " with ' for now
|
||||||
[ "object" value [ describe ] with-html-writer ] with-string-writer
|
[ "object" value [ describe ] with-html-writer ] with-string-writer
|
||||||
=
|
=
|
||||||
] unit-test
|
] unit-test
|
||||||
|
|
|
@ -4,12 +4,12 @@ USING: accessors kernel namespaces io math.parser assocs classes
|
||||||
classes.tuple words arrays sequences splitting mirrors
|
classes.tuple words arrays sequences splitting mirrors
|
||||||
hashtables combinators continuations math strings inspector
|
hashtables combinators continuations math strings inspector
|
||||||
fry locals calendar calendar.format xml.entities
|
fry locals calendar calendar.format xml.entities
|
||||||
validators urls present
|
validators urls present xml.writer xml.interpolate xml
|
||||||
xmode.code2html lcs.diff2html farkup
|
xmode.code2html lcs.diff2html farkup io.streams.string
|
||||||
html.elements html.streams html.forms ;
|
html.elements html.streams html.forms ;
|
||||||
IN: html.components
|
IN: html.components
|
||||||
|
|
||||||
GENERIC: render* ( value name renderer -- )
|
GENERIC: render* ( value name renderer -- xml )
|
||||||
|
|
||||||
: render ( name renderer -- )
|
: render ( name renderer -- )
|
||||||
prepare-value
|
prepare-value
|
||||||
|
@ -19,38 +19,36 @@ GENERIC: render* ( value name renderer -- )
|
||||||
[ f swap ]
|
[ f swap ]
|
||||||
if
|
if
|
||||||
] 2dip
|
] 2dip
|
||||||
render*
|
render* write-xml-chunk
|
||||||
[ render-error ] when* ;
|
[ render-error ] when* ;
|
||||||
|
|
||||||
<PRIVATE
|
<PRIVATE
|
||||||
|
|
||||||
: render-input ( value name type -- )
|
: render-input ( value name type -- xml )
|
||||||
<input =type =name present =value input/> ;
|
[XML <input value=<-> name=<-> type=<->/> XML] ;
|
||||||
|
|
||||||
PRIVATE>
|
PRIVATE>
|
||||||
|
|
||||||
SINGLETON: label
|
SINGLETON: label
|
||||||
|
|
||||||
M: label render* 2drop present escape-string write ;
|
M: label render*
|
||||||
|
2drop present ;
|
||||||
|
|
||||||
SINGLETON: hidden
|
SINGLETON: hidden
|
||||||
|
|
||||||
M: hidden render* drop "hidden" render-input ;
|
M: hidden render*
|
||||||
|
drop "hidden" render-input ;
|
||||||
|
|
||||||
: render-field ( value name size type -- )
|
: render-field ( value name size type -- xml )
|
||||||
<input
|
[XML <input value=<-> name=<-> size=<-> type=<->/> XML] ;
|
||||||
=type
|
|
||||||
[ present =size ] when*
|
|
||||||
=name
|
|
||||||
present =value
|
|
||||||
input/> ;
|
|
||||||
|
|
||||||
TUPLE: field size ;
|
TUPLE: field size ;
|
||||||
|
|
||||||
: <field> ( -- field )
|
: <field> ( -- field )
|
||||||
field new ;
|
field new ;
|
||||||
|
|
||||||
M: field render* size>> "text" render-field ;
|
M: field render*
|
||||||
|
size>> "text" render-field ;
|
||||||
|
|
||||||
TUPLE: password size ;
|
TUPLE: password size ;
|
||||||
|
|
||||||
|
@ -67,14 +65,12 @@ TUPLE: textarea rows cols ;
|
||||||
: <textarea> ( -- renderer )
|
: <textarea> ( -- renderer )
|
||||||
textarea new ;
|
textarea new ;
|
||||||
|
|
||||||
M: textarea render*
|
M: textarea render* ( value name area -- xml )
|
||||||
<textarea
|
rot [ [ rows>> ] [ cols>> ] bi ] dip
|
||||||
[ rows>> [ present =rows ] when* ]
|
[XML <textarea
|
||||||
[ cols>> [ present =cols ] when* ] bi
|
name=<->
|
||||||
=name
|
rows=<->
|
||||||
textarea>
|
cols=<->><-></textarea> XML] ;
|
||||||
present escape-string write
|
|
||||||
</textarea> ;
|
|
||||||
|
|
||||||
! Choice
|
! Choice
|
||||||
TUPLE: choice size multiple choices ;
|
TUPLE: choice size multiple choices ;
|
||||||
|
@ -82,24 +78,23 @@ TUPLE: choice size multiple choices ;
|
||||||
: <choice> ( -- choice )
|
: <choice> ( -- choice )
|
||||||
choice new ;
|
choice new ;
|
||||||
|
|
||||||
: render-option ( text selected? -- )
|
: render-option ( text selected? -- xml )
|
||||||
<option [ "selected" =selected ] when option>
|
"selected" and swap
|
||||||
present escape-string write
|
[XML <option selected=<->><-></option> XML] ;
|
||||||
</option> ;
|
|
||||||
|
|
||||||
: render-options ( options selected -- )
|
: render-options ( value choice -- xml )
|
||||||
'[ dup _ member? render-option ] each ;
|
[ choices>> value ] [ multiple>> ] bi
|
||||||
|
[ swap ] [ swap 1array ] if
|
||||||
|
'[ dup _ member? render-option ] map ;
|
||||||
|
|
||||||
M: choice render*
|
M:: choice render* ( value name choice -- xml )
|
||||||
<select
|
choice size>> :> size
|
||||||
swap =name
|
choice multiple>> "true" and :> multiple
|
||||||
dup size>> [ present =size ] when*
|
value choice render-options :> contents
|
||||||
dup multiple>> [ "true" =multiple ] when
|
[XML <select
|
||||||
select>
|
name=<-name->
|
||||||
[ choices>> value ] [ multiple>> ] bi
|
size=<-size->
|
||||||
[ swap ] [ swap 1array ] if
|
multiple=<-multiple->><-contents-></select> XML] ;
|
||||||
render-options
|
|
||||||
</select> ;
|
|
||||||
|
|
||||||
! Checkboxes
|
! Checkboxes
|
||||||
TUPLE: checkbox label ;
|
TUPLE: checkbox label ;
|
||||||
|
@ -108,13 +103,10 @@ TUPLE: checkbox label ;
|
||||||
checkbox new ;
|
checkbox new ;
|
||||||
|
|
||||||
M: checkbox render*
|
M: checkbox render*
|
||||||
<input
|
[ "true" and ] [ ] [ label>> ] tri*
|
||||||
"checkbox" =type
|
[XML <input
|
||||||
swap =name
|
type="checkbox"
|
||||||
swap [ "true" =checked ] when
|
checked=<-> name=<->><-></input> XML] ;
|
||||||
input>
|
|
||||||
label>> escape-string write
|
|
||||||
</input> ;
|
|
||||||
|
|
||||||
! Link components
|
! Link components
|
||||||
GENERIC: link-title ( obj -- string )
|
GENERIC: link-title ( obj -- string )
|
||||||
|
@ -129,10 +121,9 @@ M: url link-href ;
|
||||||
TUPLE: link target ;
|
TUPLE: link target ;
|
||||||
|
|
||||||
M: link render*
|
M: link render*
|
||||||
nip
|
nip swap
|
||||||
<a target>> [ =target ] when* dup link-href =href a>
|
[ target>> ] [ [ link-href ] [ link-title ] bi ] bi*
|
||||||
link-title present escape-string write
|
[XML <a target=<-> href=<->><-></a> XML] ;
|
||||||
</a> ;
|
|
||||||
|
|
||||||
! XMode code component
|
! XMode code component
|
||||||
TUPLE: code mode ;
|
TUPLE: code mode ;
|
||||||
|
@ -161,7 +152,7 @@ M: farkup render*
|
||||||
nip
|
nip
|
||||||
[ no-follow>> [ string>boolean link-no-follow? set ] when* ]
|
[ no-follow>> [ string>boolean link-no-follow? set ] when* ]
|
||||||
[ disable-images>> [ string>boolean disable-images? set ] when* ]
|
[ disable-images>> [ string>boolean disable-images? set ] when* ]
|
||||||
[ parsed>> string>boolean [ (write-farkup) ] [ write-farkup ] if ]
|
[ parsed>> string>boolean [ (write-farkup) ] [ farkup>xml ] if ]
|
||||||
tri
|
tri
|
||||||
] with-scope ;
|
] with-scope ;
|
||||||
|
|
||||||
|
@ -169,7 +160,8 @@ M: farkup render*
|
||||||
SINGLETON: inspector
|
SINGLETON: inspector
|
||||||
|
|
||||||
M: inspector render*
|
M: inspector render*
|
||||||
2drop [ describe ] with-html-writer ;
|
2drop [ [ describe ] with-html-writer ] with-string-writer
|
||||||
|
string>xml-chunk ;
|
||||||
|
|
||||||
! Diff component
|
! Diff component
|
||||||
SINGLETON: comparison
|
SINGLETON: comparison
|
||||||
|
@ -180,4 +172,4 @@ M: comparison render*
|
||||||
! HTML component
|
! HTML component
|
||||||
SINGLETON: html
|
SINGLETON: html
|
||||||
|
|
||||||
M: html render* 2drop write ;
|
M: html render* 2drop string>xml-chunk ;
|
||||||
|
|
|
@ -14,7 +14,7 @@ $nl
|
||||||
{ $code "<a =href a> \"Click me\" write </a>" }
|
{ $code "<a =href a> \"Click me\" write </a>" }
|
||||||
{ $code "<a \"http://\" prepend =href a> \"click\" write </a>" }
|
{ $code "<a \"http://\" prepend =href a> \"click\" write </a>" }
|
||||||
{ $code "<a [ \"http://\" % % ] \"\" make =href a> \"click\" write </a>" }
|
{ $code "<a [ \"http://\" % % ] \"\" make =href a> \"click\" write </a>" }
|
||||||
"Tags that have no ``closing'' equivalent have a trailing " { $snippet "tag/>" } " form:"
|
"Tags that have no “closing” equivalent have a trailing " { $snippet "tag/>" } " form:"
|
||||||
{ $code "<input \"text\" =type \"name\" =name 20 =size input/>" }
|
{ $code "<input \"text\" =type \"name\" =name 20 =size input/>" }
|
||||||
"For the full list of HTML tags and attributes, consult the word list for the " { $vocab-link "html.elements" } " vocabulary. In addition to HTML tag and attribute words, a few utilities are provided."
|
"For the full list of HTML tags and attributes, consult the word list for the " { $vocab-link "html.elements" } " vocabulary. In addition to HTML tag and attribute words, a few utilities are provided."
|
||||||
$nl
|
$nl
|
||||||
|
|
|
@ -159,7 +159,7 @@ TUPLE: person first-name last-name ;
|
||||||
"true" "b" set-value
|
"true" "b" set-value
|
||||||
] unit-test
|
] unit-test
|
||||||
|
|
||||||
[ "<input type='checkbox' name='a'>a</input><input type='checkbox' name='b' checked='true'>b</input>" ] [
|
[ "<input type=\"checkbox\" name=\"a\">a</input><input type=\"checkbox\" checked=\"true\" name=\"b\">b</input>" ] [
|
||||||
[
|
[
|
||||||
"test12" test-template call-template
|
"test12" test-template call-template
|
||||||
] run-template
|
] run-template
|
||||||
|
|
|
@ -30,7 +30,7 @@ $nl
|
||||||
{ $table
|
{ $table
|
||||||
{ { $slot "version" } { "The HTTP version. Default is " { $snippet "1.1" } " and should not be changed without good reason." } }
|
{ { $slot "version" } { "The HTTP version. Default is " { $snippet "1.1" } " and should not be changed without good reason." } }
|
||||||
{ { $slot "code" } { "HTTP status code, an " { $link integer } ". Examples are 200 for success, 404 for file not found, and so on." } }
|
{ { $slot "code" } { "HTTP status code, an " { $link integer } ". Examples are 200 for success, 404 for file not found, and so on." } }
|
||||||
{ { $slot "message" } { "HTTP status message, only displayed to the user. If the status code is 200, the status message might be ``Success'', for example." } }
|
{ { $slot "message" } { "HTTP status message, only displayed to the user. If the status code is 200, the status message might be “Success”, for example." } }
|
||||||
{ { $slot "header" } { "An assoc of HTTP header values. See " { $link "http.headers" } } }
|
{ { $slot "header" } { "An assoc of HTTP header values. See " { $link "http.headers" } } }
|
||||||
{ { $slot "cookies" } { "A sequence of HTTP cookies. See " { $link "http.cookies" } } }
|
{ { $slot "cookies" } { "A sequence of HTTP cookies. See " { $link "http.cookies" } } }
|
||||||
{ { $slot "content-type" } { "an HTTP content type" } }
|
{ { $slot "content-type" } { "an HTTP content type" } }
|
||||||
|
@ -49,7 +49,7 @@ $nl
|
||||||
{ $table
|
{ $table
|
||||||
{ { $slot "version" } { "The HTTP version. Default is " { $snippet "1.1" } " and should not be changed without good reason." } }
|
{ { $slot "version" } { "The HTTP version. Default is " { $snippet "1.1" } " and should not be changed without good reason." } }
|
||||||
{ { $slot "code" } { "HTTP status code, an " { $link integer } ". Examples are 200 for success, 404 for file not found, and so on." } }
|
{ { $slot "code" } { "HTTP status code, an " { $link integer } ". Examples are 200 for success, 404 for file not found, and so on." } }
|
||||||
{ { $slot "message" } { "HTTP status message, only displayed to the user. If the status code is 200, the status message might be ``Success'', for example." } }
|
{ { $slot "message" } { "HTTP status message, only displayed to the user. If the status code is 200, the status message might be “Success”, for example." } }
|
||||||
{ { $slot "body" } { "an HTTP response body" } }
|
{ { $slot "body" } { "an HTTP response body" } }
|
||||||
} } ;
|
} } ;
|
||||||
|
|
||||||
|
@ -110,7 +110,7 @@ $nl
|
||||||
HELP: set-header
|
HELP: set-header
|
||||||
{ $values { "request/response" "a " { $link request } " or a " { $link response } } { "value" object } { "key" string } }
|
{ $values { "request/response" "a " { $link request } " or a " { $link response } } { "value" object } { "key" string } }
|
||||||
{ $description "Stores a value into the HTTP header of a request or response. The value can be any object supported by " { $link present } "." }
|
{ $description "Stores a value into the HTTP header of a request or response. The value can be any object supported by " { $link present } "." }
|
||||||
{ $notes "This word always returns the same object that was input. This allows for a ``pipeline'' coding style, where several header parameters are set in a row." }
|
{ $notes "This word always returns the same object that was input. This allows for a “pipeline” coding style, where several header parameters are set in a row." }
|
||||||
{ $side-effects "request/response" } ;
|
{ $side-effects "request/response" } ;
|
||||||
|
|
||||||
ARTICLE: "http.cookies" "HTTP cookies"
|
ARTICLE: "http.cookies" "HTTP cookies"
|
||||||
|
|
|
@ -41,7 +41,7 @@ main-responder set-global">
|
||||||
}
|
}
|
||||||
"In the above example, visiting any URL other than " { $snippet "/new" } ", " { $snippet "/edit" } ", " { $snippet "/delete" } ", or " { $snippet "/" } " will result in a 404 error."
|
"In the above example, visiting any URL other than " { $snippet "/new" } ", " { $snippet "/edit" } ", " { $snippet "/delete" } ", or " { $snippet "/" } " will result in a 404 error."
|
||||||
{ $heading "Another pathname dispatcher" }
|
{ $heading "Another pathname dispatcher" }
|
||||||
"On the other hand, suppose we wanted to route all unrecognized paths to a ``view'' action:"
|
"On the other hand, suppose we wanted to route all unrecognized paths to a “view” action:"
|
||||||
{ $code
|
{ $code
|
||||||
<" <dispatcher>
|
<" <dispatcher>
|
||||||
<new-action> "new" add-responder
|
<new-action> "new" add-responder
|
||||||
|
|
|
@ -42,7 +42,7 @@ ERROR: no-boundary ;
|
||||||
";" split1 nip
|
";" split1 nip
|
||||||
"=" split1 nip [ no-boundary ] unless* ;
|
"=" split1 nip [ no-boundary ] unless* ;
|
||||||
|
|
||||||
: read-multipart-data ( request -- form-variables uploaded-files )
|
: read-multipart-data ( request -- mime-parts )
|
||||||
[ "content-type" header ]
|
[ "content-type" header ]
|
||||||
[ "content-length" header string>number ] bi
|
[ "content-length" header string>number ] bi
|
||||||
unlimit-input
|
unlimit-input
|
||||||
|
@ -55,7 +55,7 @@ ERROR: no-boundary ;
|
||||||
|
|
||||||
: parse-content ( request content-type -- post-data )
|
: parse-content ( request content-type -- post-data )
|
||||||
[ <post-data> swap ] keep {
|
[ <post-data> swap ] keep {
|
||||||
{ "multipart/form-data" [ read-multipart-data assoc-union >>params ] }
|
{ "multipart/form-data" [ read-multipart-data >>params ] }
|
||||||
{ "application/x-www-form-urlencoded" [ read-content query>assoc >>params ] }
|
{ "application/x-www-form-urlencoded" [ read-content query>assoc >>params ] }
|
||||||
[ drop read-content >>data ]
|
[ drop read-content >>data ]
|
||||||
} case ;
|
} case ;
|
||||||
|
|
|
@ -18,7 +18,8 @@ HELP: <interval-map>
|
||||||
{ $description "From a specification, produce an interval tree. The specification is an assoc where the keys are intervals, or pairs of numbers to represent intervals, or individual numbers to represent singleton intervals. The values are the values int he interval map. Construction time is O(n log n)." } ;
|
{ $description "From a specification, produce an interval tree. The specification is an assoc where the keys are intervals, or pairs of numbers to represent intervals, or individual numbers to represent singleton intervals. The values are the values int he interval map. Construction time is O(n log n)." } ;
|
||||||
|
|
||||||
ARTICLE: "interval-maps" "Interval maps"
|
ARTICLE: "interval-maps" "Interval maps"
|
||||||
"Interval maps are a mechanism, similar to assocs, where a set of closed intervals of keys are associated with values. As such, interval maps do not conform to the assoc protocol, because intervals of floats, for example, can be used, and it is impossible to get a list of keys in between."
|
"The " { $vocab-link "interval-maps" } " vocabulary implements a data structure, similar to assocs, where a set of closed intervals of keys are associated with values. As such, interval maps do not conform to the assoc protocol, because intervals of floats, for example, can be used, and it is impossible to get a list of keys in between."
|
||||||
|
$nl
|
||||||
"The following operations are used to query interval maps:"
|
"The following operations are used to query interval maps:"
|
||||||
{ $subsection interval-at* }
|
{ $subsection interval-at* }
|
||||||
{ $subsection interval-at }
|
{ $subsection interval-at }
|
||||||
|
|
|
@ -51,4 +51,4 @@ HOOK: add-completion io-backend ( port -- )
|
||||||
: default-security-attributes ( -- obj )
|
: default-security-attributes ( -- obj )
|
||||||
"SECURITY_ATTRIBUTES" <c-object>
|
"SECURITY_ATTRIBUTES" <c-object>
|
||||||
"SECURITY_ATTRIBUTES" heap-size
|
"SECURITY_ATTRIBUTES" heap-size
|
||||||
over set-SECURITY_ATTRIBUTES-nLength ;
|
over set-SECURITY_ATTRIBUTES-nLength ;
|
|
@ -5,13 +5,13 @@ IN: io.directories
|
||||||
HELP: cwd
|
HELP: cwd
|
||||||
{ $values { "path" "a pathname string" } }
|
{ $values { "path" "a pathname string" } }
|
||||||
{ $description "Outputs the current working directory of the Factor process." }
|
{ $description "Outputs the current working directory of the Factor process." }
|
||||||
{ $errors "Windows CE has no concept of ``current directory'', so this word throws an error there." }
|
{ $errors "Windows CE has no concept of “current directory”, so this word throws an error there." }
|
||||||
{ $notes "User code should use the value of the " { $link current-directory } " variable instead." } ;
|
{ $notes "User code should use the value of the " { $link current-directory } " variable instead." } ;
|
||||||
|
|
||||||
HELP: cd
|
HELP: cd
|
||||||
{ $values { "path" "a pathname string" } }
|
{ $values { "path" "a pathname string" } }
|
||||||
{ $description "Changes the current working directory of the Factor process." }
|
{ $description "Changes the current working directory of the Factor process." }
|
||||||
{ $errors "Windows CE has no concept of ``current directory'', so this word throws an error there." }
|
{ $errors "Windows CE has no concept of “current directory”, so this word throws an error there." }
|
||||||
{ $notes "User code should use " { $link with-directory } " or " { $link set-current-directory } " instead." } ;
|
{ $notes "User code should use " { $link with-directory } " or " { $link set-current-directory } " instead." } ;
|
||||||
|
|
||||||
{ cd cwd current-directory set-current-directory with-directory } related-words
|
{ cd cwd current-directory set-current-directory with-directory } related-words
|
||||||
|
@ -116,7 +116,7 @@ ARTICLE: "current-directory" "Current working directory"
|
||||||
"This variable can be changed with a pair of words:"
|
"This variable can be changed with a pair of words:"
|
||||||
{ $subsection set-current-directory }
|
{ $subsection set-current-directory }
|
||||||
{ $subsection with-directory }
|
{ $subsection with-directory }
|
||||||
"This variable is independent of the operating system notion of ``current working directory''. While all Factor I/O operations use the variable and not the operating system's value, care must be taken when making FFI calls which expect a pathname. The first option is to resolve relative paths:"
|
"This variable is independent of the operating system notion of “current working directory”. While all Factor I/O operations use the variable and not the operating system's value, care must be taken when making FFI calls which expect a pathname. The first option is to resolve relative paths:"
|
||||||
{ $subsection (normalize-path) }
|
{ $subsection (normalize-path) }
|
||||||
"The second is to change the working directory of the current process:"
|
"The second is to change the working directory of the current process:"
|
||||||
{ $subsection cd }
|
{ $subsection cd }
|
||||||
|
|
|
@ -4,8 +4,7 @@ IN: io.directories.search.tests
|
||||||
|
|
||||||
[ t ] [
|
[ t ] [
|
||||||
[
|
[
|
||||||
10 [ "io.paths.test" "gogogo" make-unique-file* ] replicate
|
10 [ "io.paths.test" "gogogo" make-unique-file ] replicate
|
||||||
current-directory get t [ ] find-all-files
|
current-temporary-directory get t [ ] find-all-files
|
||||||
] with-unique-directory
|
] with-unique-directory drop [ natural-sort ] bi@ =
|
||||||
[ natural-sort ] bi@ =
|
|
||||||
] unit-test
|
] unit-test
|
||||||
|
|
|
@ -4,7 +4,7 @@ USING: help.syntax help.markup io.encodings.8-bit.private
|
||||||
strings ;
|
strings ;
|
||||||
IN: io.encodings.8-bit
|
IN: io.encodings.8-bit
|
||||||
|
|
||||||
ARTICLE: "io.encodings.8-bit" "8-bit encodings"
|
ARTICLE: "io.encodings.8-bit" "Legacy 8-bit encodings"
|
||||||
"Many encodings are a simple mapping of bytes onto characters. The " { $vocab-link "io.encodings.8-bit" } " vocabulary implements these generically using existing resource files. These encodings should be used with extreme caution, as fully general Unicode encodings like UTF-8 are nearly always more appropriate. The following 8-bit encodings are already defined:"
|
"Many encodings are a simple mapping of bytes onto characters. The " { $vocab-link "io.encodings.8-bit" } " vocabulary implements these generically using existing resource files. These encodings should be used with extreme caution, as fully general Unicode encodings like UTF-8 are nearly always more appropriate. The following 8-bit encodings are already defined:"
|
||||||
{ $subsection latin1 }
|
{ $subsection latin1 }
|
||||||
{ $subsection latin2 }
|
{ $subsection latin2 }
|
||||||
|
|
|
@ -9,24 +9,30 @@ IN: io.files.links.unix.tests
|
||||||
|
|
||||||
[ t ] [
|
[ t ] [
|
||||||
[
|
[
|
||||||
5 "lol" make-test-links
|
current-temporary-directory get [
|
||||||
"lol1" follow-links
|
5 "lol" make-test-links
|
||||||
current-directory get "lol5" append-path =
|
"lol1" follow-links
|
||||||
] with-unique-directory
|
current-temporary-directory get "lol5" append-path =
|
||||||
|
] with-directory
|
||||||
|
] cleanup-unique-directory
|
||||||
] unit-test
|
] unit-test
|
||||||
|
|
||||||
[
|
[
|
||||||
[
|
[
|
||||||
100 "laf" make-test-links "laf1" follow-links
|
current-temporary-directory get [
|
||||||
|
100 "laf" make-test-links "laf1" follow-links
|
||||||
|
] with-directory
|
||||||
] with-unique-directory
|
] with-unique-directory
|
||||||
] [ too-many-symlinks? ] must-fail-with
|
] [ too-many-symlinks? ] must-fail-with
|
||||||
|
|
||||||
[ t ] [
|
[ t ] [
|
||||||
110 symlink-depth [
|
110 symlink-depth [
|
||||||
[
|
[
|
||||||
100 "laf" make-test-links
|
current-temporary-directory get [
|
||||||
"laf1" follow-links
|
100 "laf" make-test-links
|
||||||
current-directory get "laf100" append-path =
|
"laf1" follow-links
|
||||||
] with-unique-directory
|
current-temporary-directory get "laf100" append-path =
|
||||||
|
] with-directory
|
||||||
|
] cleanup-unique-directory
|
||||||
] with-variable
|
] with-variable
|
||||||
] unit-test
|
] unit-test
|
||||||
|
|
|
@ -1,8 +1,9 @@
|
||||||
USING: help.markup help.syntax io io.ports kernel math
|
USING: help.markup help.syntax io io.ports kernel math
|
||||||
io.pathnames io.directories math.parser io.files strings ;
|
io.pathnames io.directories math.parser io.files strings
|
||||||
|
quotations io.files.unique.private ;
|
||||||
IN: io.files.unique
|
IN: io.files.unique
|
||||||
|
|
||||||
HELP: temporary-path
|
HELP: default-temporary-directory
|
||||||
{ $values
|
{ $values
|
||||||
{ "path" "a pathname string" }
|
{ "path" "a pathname string" }
|
||||||
}
|
}
|
||||||
|
@ -25,42 +26,66 @@ HELP: unique-retries
|
||||||
HELP: make-unique-file ( prefix suffix -- path )
|
HELP: make-unique-file ( prefix suffix -- path )
|
||||||
{ $values { "prefix" "a string" } { "suffix" "a string" }
|
{ $values { "prefix" "a string" } { "suffix" "a string" }
|
||||||
{ "path" "a pathname string" } }
|
{ "path" "a pathname string" } }
|
||||||
{ $description "Creates a file that is guaranteed not to exist in a platform-specific temporary directory. The file name is composed of a prefix, a number of random digits and letters, and the suffix. Returns the full pathname." }
|
{ $description "Creates a file that is guaranteed not to exist in the directory stored in " { $link current-temporary-directory } ". The file name is composed of a prefix, a number of random digits and letters, and the suffix. Returns the full pathname." }
|
||||||
{ $errors "Throws an error if a new unique file cannot be created after a number of tries. The most likely error is incorrect directory permissions on the temporary directory." } ;
|
{ $errors "Throws an error if a new unique file cannot be created after a number of tries. The most likely error is incorrect directory permissions on the temporary directory." } ;
|
||||||
|
|
||||||
HELP: make-unique-file*
|
{ unique-file make-unique-file cleanup-unique-file } related-words
|
||||||
{ $values
|
|
||||||
{ "prefix" string } { "suffix" string }
|
|
||||||
{ "path" "a pathname string" }
|
|
||||||
}
|
|
||||||
{ $description "Creates a file that is guaranteed not to exist in the directory in the " { $link current-directory } " variable. The file name is composed of a prefix, a number of random digits and letters, and the suffix. Returns the full pathname." } ;
|
|
||||||
|
|
||||||
{ make-unique-file make-unique-file* with-unique-file } related-words
|
HELP: cleanup-unique-file ( prefix suffix quot: ( path -- ) -- )
|
||||||
|
|
||||||
HELP: with-unique-file ( prefix suffix quot: ( path -- ) -- )
|
|
||||||
{ $values { "prefix" "a string" } { "suffix" "a string" }
|
{ $values { "prefix" "a string" } { "suffix" "a string" }
|
||||||
{ "quot" "a quotation" } }
|
{ "quot" "a quotation" } }
|
||||||
{ $description "Creates a file with " { $link make-unique-file } " and calls the quotation with the path name on the stack." }
|
{ $description "Creates a file with " { $link make-unique-file } " and calls the quotation with the path name on the stack." }
|
||||||
{ $notes "The unique file will be deleted after calling this word." } ;
|
{ $notes "The unique file will be deleted after calling this word." } ;
|
||||||
|
|
||||||
HELP: make-unique-directory ( -- path )
|
HELP: unique-directory ( -- path )
|
||||||
{ $values { "path" "a pathname string" } }
|
{ $values { "path" "a pathname string" } }
|
||||||
{ $description "Creates a directory that is guaranteed not to exist in a platform-specific temporary directory and returns the full pathname." }
|
{ $description "Creates a directory in the value in " { $link current-temporary-directory } " that is guaranteed not to exist in and returns the full pathname." }
|
||||||
{ $errors "Throws an error if the directory cannot be created after a number of tries. The most likely error is incorrect directory permissions on the temporary directory." } ;
|
{ $errors "Throws an error if the directory cannot be created after a number of tries. The most likely error is incorrect directory permissions on the temporary directory." } ;
|
||||||
|
|
||||||
HELP: with-unique-directory ( quot -- )
|
HELP: cleanup-unique-directory ( quot -- )
|
||||||
{ $values { "quot" "a quotation" } }
|
{ $values { "quot" "a quotation" } }
|
||||||
{ $description "Creates a directory with " { $link make-unique-directory } " and calls the quotation with the pathname on the stack using the " { $link with-directory } " combinator. The quotation can access the " { $link current-directory } " symbol for the name of the temporary directory." }
|
{ $description "Creates a directory with " { $link unique-directory } " and calls the quotation with the pathname on the stack using the " { $link with-temporary-directory } " combinator. The quotation can access the " { $link current-temporary-directory } " symbol for the name of the temporary directory. Subsequent unique files will be created in this unique directory until the combinator returns." }
|
||||||
{ $notes "The directory will be deleted after calling this word, even if an error is thrown in the quotation." } ;
|
{ $notes "The directory will be deleted after calling this word, even if an error is thrown in the quotation. This combinator is like " { $link with-unique-directory } " but does not delete the directory." } ;
|
||||||
|
|
||||||
ARTICLE: "io.files.unique" "Temporary files"
|
HELP: with-unique-directory
|
||||||
"The " { $vocab-link "io.files.unique" } " vocabulary implements cross-platform temporary file creation in a high-level and secure way." $nl
|
{ $values
|
||||||
"Creating temporary files:"
|
{ "quot" quotation }
|
||||||
|
{ "path" "a pathname string" }
|
||||||
|
}
|
||||||
|
{ $description "Creates a directory with " { $link unique-directory } " and calls the quotation with the pathname on the stack using the " { $link with-temporary-directory } " combinator. The quotation can access the " { $link current-temporary-directory } " symbol for the name of the temporary directory. Subsequent unique files will be created in this unique directory until the combinator returns." } ;
|
||||||
|
|
||||||
|
HELP: current-temporary-directory
|
||||||
|
{ $values
|
||||||
|
{ "value" "a path" }
|
||||||
|
}
|
||||||
|
{ $description "The temporary directory used for creating unique files and directories." } ;
|
||||||
|
|
||||||
|
HELP: unique-file
|
||||||
|
{ $values
|
||||||
|
{ "path" "a pathname string" }
|
||||||
|
{ "path'" "a pathname string" }
|
||||||
|
}
|
||||||
|
{ $description "Creates a temporary file in the directory stored in " { $link current-temporary-directory } " and outputs the path name." } ;
|
||||||
|
|
||||||
|
HELP: with-temporary-directory
|
||||||
|
{ $values
|
||||||
|
{ "path" "a pathname string" } { "quot" quotation }
|
||||||
|
}
|
||||||
|
{ $description "Sets " { $link current-temporary-directory } " to " { $snippet "path" } " and calls the quotation, restoring the previous temporary path after execution completes." } ;
|
||||||
|
|
||||||
|
ARTICLE: "io.files.unique" "Unique files"
|
||||||
|
"The " { $vocab-link "io.files.unique" } " vocabulary implements cross-platform unique file creation in temporary directories in a high-level and secure way." $nl
|
||||||
|
"Changing the temporary path:"
|
||||||
|
{ $subsection current-temporary-directory }
|
||||||
|
"Creating unique files:"
|
||||||
|
{ $subsection unique-file }
|
||||||
|
{ $subsection cleanup-unique-file }
|
||||||
{ $subsection make-unique-file }
|
{ $subsection make-unique-file }
|
||||||
{ $subsection make-unique-file* }
|
"Creating unique directories:"
|
||||||
{ $subsection with-unique-file }
|
{ $subsection unique-directory }
|
||||||
"Creating temporary directories:"
|
{ $subsection with-unique-directory }
|
||||||
{ $subsection make-unique-directory }
|
{ $subsection cleanup-unique-directory }
|
||||||
{ $subsection with-unique-directory } ;
|
"Default temporary directory:"
|
||||||
|
{ $subsection default-temporary-directory } ;
|
||||||
|
|
||||||
ABOUT: "io.files.unique"
|
ABOUT: "io.files.unique"
|
||||||
|
|
|
@ -1,21 +1,41 @@
|
||||||
USING: io.encodings.ascii sequences strings io io.files accessors
|
USING: io.encodings.ascii sequences strings io io.files accessors
|
||||||
tools.test kernel io.files.unique namespaces continuations
|
tools.test kernel io.files.unique namespaces continuations
|
||||||
io.files.info io.pathnames ;
|
io.files.info io.pathnames io.directories ;
|
||||||
IN: io.files.unique.tests
|
IN: io.files.unique.tests
|
||||||
|
|
||||||
[ 123 ] [
|
[ 123 ] [
|
||||||
"core" ".test" [
|
"core" ".test" [
|
||||||
[ [ 123 CHAR: a <repetition> ] dip ascii set-file-contents ]
|
[ [ 123 CHAR: a <repetition> ] dip ascii set-file-contents ]
|
||||||
[ file-info size>> ] bi
|
[ file-info size>> ] bi
|
||||||
] with-unique-file
|
] cleanup-unique-file
|
||||||
] unit-test
|
] unit-test
|
||||||
|
|
||||||
[ t ] [
|
[ t ] [
|
||||||
[ current-directory get file-info directory? ] with-unique-directory
|
[ current-directory get file-info directory? ] cleanup-unique-directory
|
||||||
] unit-test
|
] unit-test
|
||||||
|
|
||||||
[ t ] [
|
[ t ] [
|
||||||
current-directory get
|
current-directory get
|
||||||
[ [ "FAILDOG" throw ] with-unique-directory ] [ drop ] recover
|
[ [ "FAILDOG" throw ] cleanup-unique-directory ] [ drop ] recover
|
||||||
current-directory get =
|
current-directory get =
|
||||||
] unit-test
|
] unit-test
|
||||||
|
|
||||||
|
[ t ] [
|
||||||
|
[
|
||||||
|
"asdf" unique-file drop
|
||||||
|
"asdf2" unique-file drop
|
||||||
|
current-temporary-directory get directory-files length 2 =
|
||||||
|
] cleanup-unique-directory
|
||||||
|
] unit-test
|
||||||
|
|
||||||
|
[ t ] [
|
||||||
|
[ ] with-unique-directory >boolean
|
||||||
|
] unit-test
|
||||||
|
|
||||||
|
[ t ] [
|
||||||
|
[
|
||||||
|
"asdf" unique-file drop
|
||||||
|
"asdf" unique-file drop
|
||||||
|
current-temporary-directory get directory-files length 2 =
|
||||||
|
] with-unique-directory drop
|
||||||
|
] unit-test
|
||||||
|
|
|
@ -6,8 +6,13 @@ kernel math math.bitwise math.parser namespaces random
|
||||||
sequences system vocabs.loader ;
|
sequences system vocabs.loader ;
|
||||||
IN: io.files.unique
|
IN: io.files.unique
|
||||||
|
|
||||||
HOOK: touch-unique-file io-backend ( path -- )
|
HOOK: (touch-unique-file) io-backend ( path -- )
|
||||||
HOOK: temporary-path io-backend ( -- path )
|
: touch-unique-file ( path -- )
|
||||||
|
normalize-path (touch-unique-file) ;
|
||||||
|
|
||||||
|
HOOK: default-temporary-directory io-backend ( -- path )
|
||||||
|
|
||||||
|
SYMBOL: current-temporary-directory
|
||||||
|
|
||||||
SYMBOL: unique-length
|
SYMBOL: unique-length
|
||||||
SYMBOL: unique-retries
|
SYMBOL: unique-retries
|
||||||
|
@ -15,6 +20,9 @@ SYMBOL: unique-retries
|
||||||
10 unique-length set-global
|
10 unique-length set-global
|
||||||
10 unique-retries set-global
|
10 unique-retries set-global
|
||||||
|
|
||||||
|
: with-temporary-directory ( path quot -- )
|
||||||
|
[ current-temporary-directory ] dip with-variable ; inline
|
||||||
|
|
||||||
<PRIVATE
|
<PRIVATE
|
||||||
|
|
||||||
: random-letter ( -- ch )
|
: random-letter ( -- ch )
|
||||||
|
@ -24,37 +32,44 @@ SYMBOL: unique-retries
|
||||||
{ t f } random
|
{ t f } random
|
||||||
[ 10 random CHAR: 0 + ] [ random-letter ] if ;
|
[ 10 random CHAR: 0 + ] [ random-letter ] if ;
|
||||||
|
|
||||||
: random-name ( n -- string )
|
: random-name ( -- string )
|
||||||
[ random-ch ] "" replicate-as ;
|
unique-length get [ random-ch ] "" replicate-as ;
|
||||||
|
|
||||||
PRIVATE>
|
|
||||||
|
|
||||||
: (make-unique-file) ( path prefix suffix -- path )
|
: (make-unique-file) ( path prefix suffix -- path )
|
||||||
'[
|
'[
|
||||||
_ _ _ unique-length get random-name glue append-path
|
_ _ _ random-name glue append-path
|
||||||
dup touch-unique-file
|
dup touch-unique-file
|
||||||
] unique-retries get retry ;
|
] unique-retries get retry ;
|
||||||
|
|
||||||
|
PRIVATE>
|
||||||
|
|
||||||
: make-unique-file ( prefix suffix -- path )
|
: make-unique-file ( prefix suffix -- path )
|
||||||
[ temporary-path ] 2dip (make-unique-file) ;
|
[ current-temporary-directory get ] 2dip (make-unique-file) ;
|
||||||
|
|
||||||
: make-unique-file* ( prefix suffix -- path )
|
: cleanup-unique-file ( prefix suffix quot: ( path -- ) -- )
|
||||||
[ current-directory get ] 2dip (make-unique-file) ;
|
|
||||||
|
|
||||||
: with-unique-file ( prefix suffix quot: ( path -- ) -- )
|
|
||||||
[ make-unique-file ] dip [ delete-file ] bi ; inline
|
[ make-unique-file ] dip [ delete-file ] bi ; inline
|
||||||
|
|
||||||
: make-unique-directory ( -- path )
|
: unique-directory ( -- path )
|
||||||
[
|
[
|
||||||
temporary-path unique-length get random-name append-path
|
current-temporary-directory get
|
||||||
|
random-name append-path
|
||||||
dup make-directory
|
dup make-directory
|
||||||
] unique-retries get retry ;
|
] unique-retries get retry ;
|
||||||
|
|
||||||
: with-unique-directory ( quot: ( -- ) -- )
|
: with-unique-directory ( quot -- path )
|
||||||
[ make-unique-directory ] dip
|
[ unique-directory ] dip
|
||||||
'[ _ with-directory ] [ delete-tree ] bi ; inline
|
[ with-temporary-directory ] [ drop ] 2bi ; inline
|
||||||
|
|
||||||
|
: cleanup-unique-directory ( quot: ( -- ) -- )
|
||||||
|
[ unique-directory ] dip
|
||||||
|
'[ _ with-temporary-directory ] [ delete-tree ] bi ; inline
|
||||||
|
|
||||||
|
: unique-file ( path -- path' )
|
||||||
|
"" make-unique-file ;
|
||||||
|
|
||||||
{
|
{
|
||||||
{ [ os unix? ] [ "io.files.unique.unix" ] }
|
{ [ os unix? ] [ "io.files.unique.unix" ] }
|
||||||
{ [ os windows? ] [ "io.files.unique.windows" ] }
|
{ [ os windows? ] [ "io.files.unique.windows" ] }
|
||||||
} cond require
|
} cond require
|
||||||
|
|
||||||
|
default-temporary-directory current-temporary-directory set-global
|
||||||
|
|
|
@ -7,7 +7,7 @@ IN: io.files.unique.unix
|
||||||
: open-unique-flags ( -- flags )
|
: open-unique-flags ( -- flags )
|
||||||
{ O_RDWR O_CREAT O_EXCL } flags ;
|
{ O_RDWR O_CREAT O_EXCL } flags ;
|
||||||
|
|
||||||
M: unix touch-unique-file ( path -- )
|
M: unix (touch-unique-file) ( path -- )
|
||||||
open-unique-flags file-mode open-file close-file ;
|
open-unique-flags file-mode open-file close-file ;
|
||||||
|
|
||||||
M: unix temporary-path ( -- path ) "/tmp" ;
|
M: unix default-temporary-directory ( -- path ) "/tmp" ;
|
||||||
|
|
|
@ -3,8 +3,8 @@ io.files.windows io.ports windows destructors environment
|
||||||
io.files.unique ;
|
io.files.unique ;
|
||||||
IN: io.files.unique.windows
|
IN: io.files.unique.windows
|
||||||
|
|
||||||
M: windows touch-unique-file ( path -- )
|
M: windows (touch-unique-file) ( path -- )
|
||||||
GENERIC_WRITE CREATE_NEW 0 open-file dispose ;
|
GENERIC_WRITE CREATE_NEW 0 open-file dispose ;
|
||||||
|
|
||||||
M: windows temporary-path ( -- path )
|
M: windows default-temporary-directory ( -- path )
|
||||||
"TEMP" os-env ;
|
"TEMP" os-env ;
|
||||||
|
|
|
@ -16,7 +16,7 @@ destructors io.timeouts ;
|
||||||
[ ] [ "monitor-test-self" temp-file touch-file ] unit-test
|
[ ] [ "monitor-test-self" temp-file touch-file ] unit-test
|
||||||
|
|
||||||
[ t ] [
|
[ t ] [
|
||||||
"m" get next-change drop
|
"m" get next-change path>>
|
||||||
[ "" = ] [ "monitor-test-self" temp-file = ] bi or
|
[ "" = ] [ "monitor-test-self" temp-file = ] bi or
|
||||||
] unit-test
|
] unit-test
|
||||||
|
|
||||||
|
@ -29,7 +29,7 @@ destructors io.timeouts ;
|
||||||
[ ] [ "monitor-test-self" temp-file touch-file ] unit-test
|
[ ] [ "monitor-test-self" temp-file touch-file ] unit-test
|
||||||
|
|
||||||
[ t ] [
|
[ t ] [
|
||||||
"m" get next-change drop
|
"m" get next-change path>>
|
||||||
[ "" = ] [ "monitor-test-self" temp-file = ] bi or
|
[ "" = ] [ "monitor-test-self" temp-file = ] bi or
|
||||||
] unit-test
|
] unit-test
|
||||||
|
|
||||||
|
|
|
@ -17,9 +17,12 @@ HELP: (monitor)
|
||||||
{ $contract "Opens a file system change monitor which listens for changes on " { $snippet "path" } " and posts notifications to " { $snippet "mailbox" } " as triples with shape " { $snippet "{ path changed monitor } " } ". The boolean indicates whether changes in subdirectories should be reported." }
|
{ $contract "Opens a file system change monitor which listens for changes on " { $snippet "path" } " and posts notifications to " { $snippet "mailbox" } " as triples with shape " { $snippet "{ path changed monitor } " } ". The boolean indicates whether changes in subdirectories should be reported." }
|
||||||
{ $errors "Throws an error if the pathname does not exist, if a monitor could not be created or if the platform does not support monitors." } ;
|
{ $errors "Throws an error if the pathname does not exist, if a monitor could not be created or if the platform does not support monitors." } ;
|
||||||
|
|
||||||
|
HELP: file-change
|
||||||
|
{ $class-description "A change notification output by " { $link next-change } ". The " { $snippet "path" } " slot holds a pathname string. The " { $snippet "changed" } " slots holds a sequence of symbols documented in " { $link "io.monitors.descriptors" } "." } ;
|
||||||
|
|
||||||
HELP: next-change
|
HELP: next-change
|
||||||
{ $values { "monitor" "a monitor" } { "path" "a pathname string" } { "changed" "a change descriptor" } }
|
{ $values { "monitor" "a monitor" } { "change" file-change } }
|
||||||
{ $contract "Waits for file system changes and outputs the pathname of the first changed file. The change descriptor is a sequence of symbols documented in " { $link "io.monitors.descriptors" } "." }
|
{ $contract "Waits for file system changes and outputs a change descriptor for the first changed file." }
|
||||||
{ $errors "Throws an error if the monitor is closed from another thread." } ;
|
{ $errors "Throws an error if the monitor is closed from another thread." } ;
|
||||||
|
|
||||||
HELP: with-monitor
|
HELP: with-monitor
|
||||||
|
@ -46,7 +49,9 @@ HELP: +rename-file+
|
||||||
{ $description "Indicates that a file has been renamed." } ;
|
{ $description "Indicates that a file has been renamed." } ;
|
||||||
|
|
||||||
ARTICLE: "io.monitors.descriptors" "File system change descriptors"
|
ARTICLE: "io.monitors.descriptors" "File system change descriptors"
|
||||||
"Change descriptors output by " { $link next-change } ":"
|
"The " { $link next-change } " word outputs instances of a class:"
|
||||||
|
{ $subsection file-change }
|
||||||
|
"The " { $slot "changed" } " slot holds a sequence which may contain any of the following symbols:"
|
||||||
{ $subsection +add-file+ }
|
{ $subsection +add-file+ }
|
||||||
{ $subsection +remove-file+ }
|
{ $subsection +remove-file+ }
|
||||||
{ $subsection +modify-file+ }
|
{ $subsection +modify-file+ }
|
||||||
|
@ -55,7 +60,7 @@ ARTICLE: "io.monitors.descriptors" "File system change descriptors"
|
||||||
{ $subsection +rename-file+ } ;
|
{ $subsection +rename-file+ } ;
|
||||||
|
|
||||||
ARTICLE: "io.monitors.platforms" "Monitors on different platforms"
|
ARTICLE: "io.monitors.platforms" "Monitors on different platforms"
|
||||||
"Whether the " { $snippet "path" } " output value of " { $link next-change } " contains an absolute path or a path relative to the path given to " { $link <monitor> } " is unspecified, and may even vary on the same platform. User code should not assume either case."
|
"Whether the " { $slot "path" } " slot of a " { $link file-change } " contains an absolute path or a path relative to the path given to " { $link <monitor> } " is unspecified, and may even vary on the same platform. User code should not assume either case."
|
||||||
$nl
|
$nl
|
||||||
"If the immediate path being monitored was changed, then " { $snippet "path" } " will equal " { $snippet "\"\"" } "; however this condition is not reported on all platforms. See below."
|
"If the immediate path being monitored was changed, then " { $snippet "path" } " will equal " { $snippet "\"\"" } "; however this condition is not reported on all platforms. See below."
|
||||||
{ $heading "Mac OS X" }
|
{ $heading "Mac OS X" }
|
||||||
|
@ -63,7 +68,7 @@ $nl
|
||||||
$nl
|
$nl
|
||||||
{ $snippet "FSEventStream" } "s always monitor directory hierarchies recursively, and the " { $snippet "recursive?" } " parameter to " { $link <monitor> } " has no effect."
|
{ $snippet "FSEventStream" } "s always monitor directory hierarchies recursively, and the " { $snippet "recursive?" } " parameter to " { $link <monitor> } " has no effect."
|
||||||
$nl
|
$nl
|
||||||
"The " { $snippet "changed" } " output value of the " { $link next-change } " word always outputs " { $link +modify-file+ } " and the " { $snippet "path" } " output value is always the directory containing the file that changed. Unlike other platforms, fine-grained information is not available."
|
"The " { $snippet "changed" } " slot of the " { $link file-change } " word tuple always contains " { $link +modify-file+ } " and the " { $snippet "path" } " slot is always the directory containing the file that changed. Unlike other platforms, fine-grained information is not available."
|
||||||
$nl
|
$nl
|
||||||
"Only directories may be monitored, not individual files. Changes to the directory itself (permissions, modification time, and so on) are not reported; only changes to children are reported."
|
"Only directories may be monitored, not individual files. Changes to the directory itself (permissions, modification time, and so on) are not reported; only changes to children are reported."
|
||||||
{ $heading "Windows" }
|
{ $heading "Windows" }
|
||||||
|
@ -107,7 +112,7 @@ $nl
|
||||||
{ $code
|
{ $code
|
||||||
"USE: io.monitors"
|
"USE: io.monitors"
|
||||||
": watch-loop ( monitor -- )"
|
": watch-loop ( monitor -- )"
|
||||||
" dup next-change . . nl nl flush watch-loop ;"
|
" dup next-change . nl nl flush watch-loop ;"
|
||||||
""
|
""
|
||||||
": watch-directory ( path -- )"
|
": watch-directory ( path -- )"
|
||||||
" [ t [ watch-loop ] with-monitor ] with-monitors"
|
" [ t [ watch-loop ] with-monitor ] with-monitors"
|
||||||
|
|
|
@ -3,7 +3,7 @@ USING: io.monitors tools.test io.files system sequences
|
||||||
continuations namespaces concurrency.count-downs kernel io
|
continuations namespaces concurrency.count-downs kernel io
|
||||||
threads calendar prettyprint destructors io.timeouts
|
threads calendar prettyprint destructors io.timeouts
|
||||||
io.files.temp io.directories io.directories.hierarchy
|
io.files.temp io.directories io.directories.hierarchy
|
||||||
io.pathnames ;
|
io.pathnames accessors ;
|
||||||
|
|
||||||
os { winnt linux macosx } member? [
|
os { winnt linux macosx } member? [
|
||||||
[
|
[
|
||||||
|
@ -53,7 +53,7 @@ os { winnt linux macosx } member? [
|
||||||
"b" get count-down
|
"b" get count-down
|
||||||
|
|
||||||
[
|
[
|
||||||
"m" get next-change drop
|
"m" get next-change path>>
|
||||||
dup print flush
|
dup print flush
|
||||||
dup parent-directory
|
dup parent-directory
|
||||||
[ trim-right-separators "xyz" tail? ] either? not
|
[ trim-right-separators "xyz" tail? ] either? not
|
||||||
|
@ -62,7 +62,7 @@ os { winnt linux macosx } member? [
|
||||||
"c1" get count-down
|
"c1" get count-down
|
||||||
|
|
||||||
[
|
[
|
||||||
"m" get next-change drop
|
"m" get next-change path>>
|
||||||
dup print flush
|
dup print flush
|
||||||
dup parent-directory
|
dup parent-directory
|
||||||
[ trim-right-separators "yxy" tail? ] either? not
|
[ trim-right-separators "yxy" tail? ] either? not
|
||||||
|
@ -101,13 +101,13 @@ os { winnt linux macosx } member? [
|
||||||
! Non-recursive
|
! Non-recursive
|
||||||
[ ] [ "monitor-timeout-test" temp-file f <monitor> "m" set ] unit-test
|
[ ] [ "monitor-timeout-test" temp-file f <monitor> "m" set ] unit-test
|
||||||
[ ] [ 3 seconds "m" get set-timeout ] unit-test
|
[ ] [ 3 seconds "m" get set-timeout ] unit-test
|
||||||
[ [ t ] [ "m" get next-change 2drop ] [ ] while ] must-fail
|
[ [ t ] [ "m" get next-change drop ] [ ] while ] must-fail
|
||||||
[ ] [ "m" get dispose ] unit-test
|
[ ] [ "m" get dispose ] unit-test
|
||||||
|
|
||||||
! Recursive
|
! Recursive
|
||||||
[ ] [ "monitor-timeout-test" temp-file t <monitor> "m" set ] unit-test
|
[ ] [ "monitor-timeout-test" temp-file t <monitor> "m" set ] unit-test
|
||||||
[ ] [ 3 seconds "m" get set-timeout ] unit-test
|
[ ] [ 3 seconds "m" get set-timeout ] unit-test
|
||||||
[ [ t ] [ "m" get next-change 2drop ] [ ] while ] must-fail
|
[ [ t ] [ "m" get next-change drop ] [ ] while ] must-fail
|
||||||
[ ] [ "m" get dispose ] unit-test
|
[ ] [ "m" get dispose ] unit-test
|
||||||
] with-monitors
|
] with-monitors
|
||||||
] when
|
] when
|
||||||
|
|
|
@ -1,8 +1,8 @@
|
||||||
! Copyright (C) 2008 Slava Pestov.
|
! Copyright (C) 2008, 2009 Slava Pestov.
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: io.backend kernel continuations destructors namespaces
|
USING: io.backend kernel continuations destructors namespaces
|
||||||
sequences assocs hashtables sorting arrays threads boxes
|
sequences assocs hashtables sorting arrays threads boxes
|
||||||
io.timeouts accessors concurrency.mailboxes
|
io.timeouts accessors concurrency.mailboxes fry
|
||||||
system vocabs.loader combinators ;
|
system vocabs.loader combinators ;
|
||||||
IN: io.monitors
|
IN: io.monitors
|
||||||
|
|
||||||
|
@ -33,17 +33,19 @@ M: monitor set-timeout (>>timeout) ;
|
||||||
swap >>queue
|
swap >>queue
|
||||||
swap >>path ; inline
|
swap >>path ; inline
|
||||||
|
|
||||||
|
TUPLE: file-change path changed monitor ;
|
||||||
|
|
||||||
: queue-change ( path changes monitor -- )
|
: queue-change ( path changes monitor -- )
|
||||||
3dup and and
|
3dup and and
|
||||||
[ [ 3array ] keep queue>> mailbox-put ] [ 3drop ] if ;
|
[ [ file-change boa ] keep queue>> mailbox-put ] [ 3drop ] if ;
|
||||||
|
|
||||||
HOOK: (monitor) io-backend ( path recursive? mailbox -- monitor )
|
HOOK: (monitor) io-backend ( path recursive? mailbox -- monitor )
|
||||||
|
|
||||||
: <monitor> ( path recursive? -- monitor )
|
: <monitor> ( path recursive? -- monitor )
|
||||||
<mailbox> (monitor) ;
|
<mailbox> (monitor) ;
|
||||||
|
|
||||||
: next-change ( monitor -- path changed )
|
: next-change ( monitor -- change )
|
||||||
[ queue>> ] [ timeout ] bi mailbox-get-timeout first2 ;
|
[ queue>> ] [ timeout ] bi mailbox-get-timeout ;
|
||||||
|
|
||||||
SYMBOL: +add-file+
|
SYMBOL: +add-file+
|
||||||
SYMBOL: +remove-file+
|
SYMBOL: +remove-file+
|
||||||
|
@ -55,9 +57,15 @@ SYMBOL: +rename-file+
|
||||||
: with-monitor ( path recursive? quot -- )
|
: with-monitor ( path recursive? quot -- )
|
||||||
[ <monitor> ] dip with-disposal ; inline
|
[ <monitor> ] dip with-disposal ; inline
|
||||||
|
|
||||||
|
: run-monitor ( path recursive? quot -- )
|
||||||
|
'[ [ @ t ] loop ] with-monitor ; inline
|
||||||
|
|
||||||
|
: spawn-monitor ( path recursive? quot -- )
|
||||||
|
[ '[ _ _ _ run-monitor ] ] [ 2drop "Monitoring " prepend ] 3bi
|
||||||
|
spawn drop ;
|
||||||
{
|
{
|
||||||
{ [ os macosx? ] [ "io.monitors.macosx" require ] }
|
{ [ os macosx? ] [ "io.monitors.macosx" require ] }
|
||||||
{ [ os linux? ] [ "io.monitors.linux" require ] }
|
{ [ os linux? ] [ "io.monitors.linux" require ] }
|
||||||
{ [ os winnt? ] [ "io.monitors.windows.nt" require ] }
|
{ [ os winnt? ] [ "io.monitors.windows.nt" require ] }
|
||||||
[ ]
|
{ [ os bsd? ] [ ] }
|
||||||
} cond
|
} cond
|
||||||
|
|
|
@ -1,4 +1,4 @@
|
||||||
! Copyright (C) 2008 Slava Pestov.
|
! Copyright (C) 2008, 2009 Slava Pestov.
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: accessors sequences assocs arrays continuations
|
USING: accessors sequences assocs arrays continuations
|
||||||
destructors combinators kernel threads concurrency.messaging
|
destructors combinators kernel threads concurrency.messaging
|
||||||
|
@ -45,12 +45,11 @@ M: recursive-monitor dispose*
|
||||||
bi ;
|
bi ;
|
||||||
|
|
||||||
: stop-pump ( -- )
|
: stop-pump ( -- )
|
||||||
monitor tget children>> [ nip dispose ] assoc-each ;
|
monitor tget children>> values dispose-each ;
|
||||||
|
|
||||||
: pump-step ( msg -- )
|
: pump-step ( msg -- )
|
||||||
first3 path>> swap [ prepend-path ] dip monitor tget 3array
|
[ [ monitor>> path>> ] [ path>> ] bi append-path ] [ changed>> ] bi
|
||||||
monitor tget queue>>
|
monitor tget queue-change ;
|
||||||
mailbox-put ;
|
|
||||||
|
|
||||||
: child-added ( path monitor -- )
|
: child-added ( path monitor -- )
|
||||||
path>> prepend-path add-child-monitor ;
|
path>> prepend-path add-child-monitor ;
|
||||||
|
@ -59,7 +58,7 @@ M: recursive-monitor dispose*
|
||||||
path>> prepend-path remove-child-monitor ;
|
path>> prepend-path remove-child-monitor ;
|
||||||
|
|
||||||
: update-hierarchy ( msg -- )
|
: update-hierarchy ( msg -- )
|
||||||
first3 swap [
|
[ path>> ] [ monitor>> ] [ changed>> ] tri [
|
||||||
{
|
{
|
||||||
{ +add-file+ [ child-added ] }
|
{ +add-file+ [ child-added ] }
|
||||||
{ +remove-file+ [ child-removed ] }
|
{ +remove-file+ [ child-removed ] }
|
||||||
|
|
|
@ -29,7 +29,7 @@ HELP: run-pipeline
|
||||||
}
|
}
|
||||||
}
|
}
|
||||||
{ $examples
|
{ $examples
|
||||||
"Print the lines of a log file which contain the string ``error'', sort them and filter out duplicates, using Unix shell commands only:"
|
"Print the lines of a log file which contain the string “error”, sort them and filter out duplicates, using Unix shell commands only:"
|
||||||
{ $code "{ \"cat log.txt\" \"grep error\" \"sort\" \"uniq\" } run-pipeline" }
|
{ $code "{ \"cat log.txt\" \"grep error\" \"sort\" \"uniq\" } run-pipeline" }
|
||||||
} ;
|
} ;
|
||||||
|
|
||||||
|
|
|
@ -81,7 +81,7 @@ ARTICLE: "io.streams.limited" "Limited input streams"
|
||||||
"Unlimits a limited stream:"
|
"Unlimits a limited stream:"
|
||||||
{ $subsection unlimit }
|
{ $subsection unlimit }
|
||||||
"Unlimits the current " { $link input-stream } ":"
|
"Unlimits the current " { $link input-stream } ":"
|
||||||
{ $subsection limit-input }
|
{ $subsection unlimit-input }
|
||||||
"Make a limited stream throw an exception on exhaustion:"
|
"Make a limited stream throw an exception on exhaustion:"
|
||||||
{ $subsection stream-throws }
|
{ $subsection stream-throws }
|
||||||
"Make a limited stream return " { $link f } " on exhaustion:"
|
"Make a limited stream return " { $link f } " on exhaustion:"
|
||||||
|
|
|
@ -1,6 +1,7 @@
|
||||||
USING: io io.streams.limited io.encodings io.encodings.string
|
USING: io io.streams.limited io.encodings io.encodings.string
|
||||||
io.encodings.ascii io.encodings.binary io.streams.byte-array
|
io.encodings.ascii io.encodings.binary io.streams.byte-array
|
||||||
namespaces tools.test strings kernel io.streams.string accessors ;
|
namespaces tools.test strings kernel io.streams.string accessors
|
||||||
|
io.encodings.utf8 io.files destructors ;
|
||||||
IN: io.streams.limited.tests
|
IN: io.streams.limited.tests
|
||||||
|
|
||||||
[ ] [
|
[ ] [
|
||||||
|
@ -59,3 +60,19 @@ IN: io.streams.limited.tests
|
||||||
"abc" <string-reader> 3 stream-eofs limit unlimit
|
"abc" <string-reader> 3 stream-eofs limit unlimit
|
||||||
"abc" <string-reader> =
|
"abc" <string-reader> =
|
||||||
] unit-test
|
] unit-test
|
||||||
|
|
||||||
|
[ t ]
|
||||||
|
[
|
||||||
|
"abc" <string-reader> 3 stream-eofs limit unlimit
|
||||||
|
"abc" <string-reader> =
|
||||||
|
] unit-test
|
||||||
|
|
||||||
|
[ t ]
|
||||||
|
[
|
||||||
|
[
|
||||||
|
"resource:license.txt" utf8 <file-reader> &dispose
|
||||||
|
3 stream-eofs limit unlimit
|
||||||
|
"resource:license.txt" utf8 <file-reader> &dispose
|
||||||
|
[ decoder? ] both?
|
||||||
|
] with-destructors
|
||||||
|
] unit-test
|
||||||
|
|
|
@ -5,7 +5,7 @@ USING: kernel math io io.encodings destructors accessors
|
||||||
sequences namespaces byte-vectors fry combinators ;
|
sequences namespaces byte-vectors fry combinators ;
|
||||||
IN: io.streams.limited
|
IN: io.streams.limited
|
||||||
|
|
||||||
TUPLE: limited-stream stream count limit mode ;
|
TUPLE: limited-stream stream count limit mode stack ;
|
||||||
|
|
||||||
SINGLETONS: stream-throws stream-eofs ;
|
SINGLETONS: stream-throws stream-eofs ;
|
||||||
|
|
||||||
|
@ -24,13 +24,24 @@ M: decoder limit ( stream limit mode -- stream' )
|
||||||
M: object limit ( stream limit mode -- stream' )
|
M: object limit ( stream limit mode -- stream' )
|
||||||
<limited-stream> ;
|
<limited-stream> ;
|
||||||
|
|
||||||
: unlimit ( stream -- stream' )
|
GENERIC: unlimit ( stream -- stream' )
|
||||||
|
|
||||||
|
M: decoder unlimit ( stream -- stream' )
|
||||||
[ stream>> ] change-stream ;
|
[ stream>> ] change-stream ;
|
||||||
|
|
||||||
|
M: object unlimit ( stream -- stream' )
|
||||||
|
stream>> stream>> ;
|
||||||
|
|
||||||
: limit-input ( limit mode -- ) input-stream [ -rot limit ] change ;
|
: limit-input ( limit mode -- ) input-stream [ -rot limit ] change ;
|
||||||
|
|
||||||
: unlimit-input ( -- ) input-stream [ unlimit ] change ;
|
: unlimit-input ( -- ) input-stream [ unlimit ] change ;
|
||||||
|
|
||||||
|
: with-unlimited-stream ( stream quot -- )
|
||||||
|
[ clone unlimit ] dip call ; inline
|
||||||
|
|
||||||
|
: with-limited-stream ( stream limit mode quot -- )
|
||||||
|
[ limit ] dip call ; inline
|
||||||
|
|
||||||
ERROR: limit-exceeded ;
|
ERROR: limit-exceeded ;
|
||||||
|
|
||||||
ERROR: bad-stream-mode mode ;
|
ERROR: bad-stream-mode mode ;
|
||||||
|
|
|
@ -0,0 +1,6 @@
|
||||||
|
! Copyright (C) 2009 Daniel Ehrenberg
|
||||||
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
|
USING: lcs.diff2html lcs kernel tools.test strings sequences xml.writer ;
|
||||||
|
IN: lcs.diff2html.tests
|
||||||
|
|
||||||
|
[ ] [ "hello" "heyo" [ 1string ] { } map-as diff htmlize-diff xml-chunk>string drop ] unit-test
|
|
@ -1,44 +1,42 @@
|
||||||
! Copyright (C) 2008 Slava Pestov
|
! Copyright (C) 2008 Slava Pestov
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: lcs html.elements kernel ;
|
USING: lcs xml.interpolate xml.writer kernel strings ;
|
||||||
FROM: accessors => item>> ;
|
FROM: accessors => item>> ;
|
||||||
FROM: io => write ;
|
FROM: io => write ;
|
||||||
FROM: sequences => each if-empty ;
|
FROM: sequences => each if-empty when-empty map ;
|
||||||
FROM: xml.entities => escape-string ;
|
|
||||||
IN: lcs.diff2html
|
IN: lcs.diff2html
|
||||||
|
|
||||||
GENERIC: diff-line ( obj -- )
|
GENERIC: diff-line ( obj -- xml )
|
||||||
|
|
||||||
: write-item ( item -- )
|
: item-string ( item -- string )
|
||||||
item>> [ " " ] [ escape-string ] if-empty write ;
|
item>> [ CHAR: no-break-space 1string ] when-empty ;
|
||||||
|
|
||||||
M: retain diff-line
|
M: retain diff-line
|
||||||
<tr>
|
item-string
|
||||||
dup [
|
[XML <td class="retain"><-></td> XML]
|
||||||
<td "retain" =class td>
|
dup [XML <tr><-><-></tr> XML] ;
|
||||||
write-item
|
|
||||||
</td>
|
|
||||||
] bi@
|
|
||||||
</tr> ;
|
|
||||||
|
|
||||||
M: insert diff-line
|
M: insert diff-line
|
||||||
<tr>
|
item-string [XML
|
||||||
<td> </td>
|
<tr>
|
||||||
<td "insert" =class td>
|
<td> </td>
|
||||||
write-item
|
<td class="insert"><-></td>
|
||||||
</td>
|
</tr>
|
||||||
</tr> ;
|
XML] ;
|
||||||
|
|
||||||
M: delete diff-line
|
M: delete diff-line
|
||||||
<tr>
|
item-string [XML
|
||||||
<td "delete" =class td>
|
<tr>
|
||||||
write-item
|
<td class="delete"><-></td>
|
||||||
</td>
|
<td> </td>
|
||||||
<td> </td>
|
</tr>
|
||||||
</tr> ;
|
XML] ;
|
||||||
|
|
||||||
: htmlize-diff ( diff -- )
|
: htmlize-diff ( diff -- xml )
|
||||||
<table "100%" =width "comparison" =class table>
|
[ diff-line ] map
|
||||||
<tr> <th> "Old" write </th> <th> "New" write </th> </tr>
|
[XML
|
||||||
[ diff-line ] each
|
<table width="100%" class="comparison">
|
||||||
</table> ;
|
<tr><th>Old</th><th>New</th></tr>
|
||||||
|
<->
|
||||||
|
</table>
|
||||||
|
XML] ;
|
||||||
|
|
|
@ -134,6 +134,7 @@ $nl
|
||||||
}
|
}
|
||||||
"In a word with locals, literals expand into code which constructs the literal, and so every invocation pushes a new object:"
|
"In a word with locals, literals expand into code which constructs the literal, and so every invocation pushes a new object:"
|
||||||
{ $example
|
{ $example
|
||||||
|
"USE: locals"
|
||||||
"IN: scratchpad"
|
"IN: scratchpad"
|
||||||
"TUPLE: person first-name last-name ;"
|
"TUPLE: person first-name last-name ;"
|
||||||
":: ordinary-word-test ( -- tuple )"
|
":: ordinary-word-test ( -- tuple )"
|
||||||
|
@ -166,7 +167,7 @@ $nl
|
||||||
"Recall that the following two code snippets are equivalent:"
|
"Recall that the following two code snippets are equivalent:"
|
||||||
{ $code "'[ sq _ + ]" }
|
{ $code "'[ sq _ + ]" }
|
||||||
{ $code "[ [ sq ] dip + ] curry" }
|
{ $code "[ [ sq ] dip + ] curry" }
|
||||||
"The semantics of " { $link dip } " and " { $link curry } " are such that the first example behaves as if the top of the stack as ``inserted'' in the ``hole'' in the quotation's second element."
|
"The semantics of " { $link dip } " and " { $link curry } " are such that the first example behaves as if the top of the stack as “inserted” in the “hole” in the quotation's second element."
|
||||||
$nl
|
$nl
|
||||||
"Conceptually, " { $link curry } " is defined so that the following two code snippets are equivalent:"
|
"Conceptually, " { $link curry } " is defined so that the following two code snippets are equivalent:"
|
||||||
{ $code "3 [ - ] curry" }
|
{ $code "3 [ - ] curry" }
|
||||||
|
@ -179,7 +180,7 @@ $nl
|
||||||
{ $code "'[ [| a | a - ] curry ] call" }
|
{ $code "'[ [| a | a - ] curry ] call" }
|
||||||
"Instead, the first line above expands into something like the following:"
|
"Instead, the first line above expands into something like the following:"
|
||||||
{ $code "[ [ swap [| a | a - ] ] curry call ]" }
|
{ $code "[ [ swap [| a | a - ] ] curry call ]" }
|
||||||
"This ensures that the fried value appears ``underneath'' the local variable " { $snippet "a" } " when the quotation calls."
|
"This ensures that the fried value appears “underneath” the local variable " { $snippet "a" } " when the quotation calls."
|
||||||
$nl
|
$nl
|
||||||
"The precise behavior is the following. When frying a lambda, a stack shuffle (" { $link mnswap } ") is prepended to the lambda so that the " { $snippet "m" } " curried values, which start off at the top of the stack, are transposed with the " { $snippet "n" } " inputs to the lambda." ;
|
"The precise behavior is the following. When frying a lambda, a stack shuffle (" { $link mnswap } ") is prepended to the lambda so that the " { $snippet "m" } " curried values, which start off at the top of the stack, are transposed with the " { $snippet "n" } " inputs to the lambda." ;
|
||||||
|
|
||||||
|
|
|
@ -6,7 +6,7 @@ ARTICLE: "complex-numbers-zero" "Embedding of real numbers in complex numbers"
|
||||||
"Constructing a complex number with an imaginary component equal to an integer zero simply returns the real number corresponding to the real component:"
|
"Constructing a complex number with an imaginary component equal to an integer zero simply returns the real number corresponding to the real component:"
|
||||||
{ $example "USING: math prettyprint ;" "C{ 1 2 } C{ 3 -2 } + ." "4" }
|
{ $example "USING: math prettyprint ;" "C{ 1 2 } C{ 3 -2 } + ." "4" }
|
||||||
"Constructing a complex number with an imaginary component equal to floating point zero will still output a new complex number, however:"
|
"Constructing a complex number with an imaginary component equal to floating point zero will still output a new complex number, however:"
|
||||||
{ $example "USING: math prettyprint ;" "C{ 0.0 2.0 } C{ 0.0 1.0 } * ." "C{ 2.0 0.0 }" }
|
{ $example "USING: math prettyprint ;" "C{ 0.0 2.0 } C{ 0.0 1.0 } * ." "C{ -2.0 0.0 }" }
|
||||||
"Unlike math, where all real numbers are also complex numbers, Factor only considers a number to be a complex number if its imaginary part is non-zero. However, complex number operations are fully supported for real numbers; they are treated as having an imaginary part of zero." ;
|
"Unlike math, where all real numbers are also complex numbers, Factor only considers a number to be a complex number if its imaginary part is non-zero. However, complex number operations are fully supported for real numbers; they are treated as having an imaginary part of zero." ;
|
||||||
|
|
||||||
ARTICLE: "complex-numbers" "Complex numbers"
|
ARTICLE: "complex-numbers" "Complex numbers"
|
||||||
|
|
|
@ -5,8 +5,8 @@ ARTICLE: "math.libm" "C standard library math functions"
|
||||||
"The words in the " { $vocab-link "math.libm" } " vocabulary call C standard library math functions. They are used to implement words in the " { $vocab-link "math.functions" } " vocabulary."
|
"The words in the " { $vocab-link "math.libm" } " vocabulary call C standard library math functions. They are used to implement words in the " { $vocab-link "math.functions" } " vocabulary."
|
||||||
$nl
|
$nl
|
||||||
"They can be called directly, however there is little reason to do so, since they only implement real-valued functions, and in some cases place restrictions on the domain:"
|
"They can be called directly, however there is little reason to do so, since they only implement real-valued functions, and in some cases place restrictions on the domain:"
|
||||||
{ $example "2 acos ." "C{ 0.0 1.316957896924817 }" }
|
{ $example "USE: math.functions" "2 acos ." "C{ 0.0 1.316957896924817 }" }
|
||||||
{ $example "2 facos ." "0.0/0.0" }
|
{ $example "USE: math.libm" "2 facos ." "0.0/0.0" }
|
||||||
"Trigonometric functions:"
|
"Trigonometric functions:"
|
||||||
{ $subsection fcos }
|
{ $subsection fcos }
|
||||||
{ $subsection fsin }
|
{ $subsection fsin }
|
||||||
|
|
|
@ -2,7 +2,7 @@
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: io.encodings.ascii io.files io.files.unique kernel
|
USING: io.encodings.ascii io.files io.files.unique kernel
|
||||||
mime.multipart tools.test io.streams.duplex io multiline
|
mime.multipart tools.test io.streams.duplex io multiline
|
||||||
assocs ;
|
assocs accessors ;
|
||||||
IN: mime.multipart.tests
|
IN: mime.multipart.tests
|
||||||
|
|
||||||
: upload-separator ( -- seq )
|
: upload-separator ( -- seq )
|
||||||
|
@ -20,11 +20,16 @@ IN: mime.multipart.tests
|
||||||
|
|
||||||
[ t ] [
|
[ t ] [
|
||||||
mime-test-stream [ upload-separator parse-multipart ] with-input-stream
|
mime-test-stream [ upload-separator parse-multipart ] with-input-stream
|
||||||
nip "\"up.txt\"" swap key?
|
"file1" swap key?
|
||||||
] unit-test
|
] unit-test
|
||||||
|
|
||||||
[ t ] [
|
[ t ] [
|
||||||
mime-test-stream [ upload-separator parse-multipart ] with-input-stream
|
mime-test-stream [ upload-separator parse-multipart ] with-input-stream
|
||||||
drop "\"text1\"" swap key?
|
"file1" swap key?
|
||||||
|
] unit-test
|
||||||
|
|
||||||
|
[ t ] [
|
||||||
|
mime-test-stream [ upload-separator parse-multipart ] with-input-stream
|
||||||
|
"file1" swap at filename>> "up.txt" =
|
||||||
] unit-test
|
] unit-test
|
||||||
|
|
||||||
|
|
|
@ -3,7 +3,7 @@
|
||||||
USING: multiline kernel sequences io splitting fry namespaces
|
USING: multiline kernel sequences io splitting fry namespaces
|
||||||
http.parsers hashtables assocs combinators ascii io.files.unique
|
http.parsers hashtables assocs combinators ascii io.files.unique
|
||||||
accessors io.encodings.binary io.files byte-arrays math
|
accessors io.encodings.binary io.files byte-arrays math
|
||||||
io.streams.string combinators.short-circuit strings ;
|
io.streams.string combinators.short-circuit strings math.order ;
|
||||||
IN: mime.multipart
|
IN: mime.multipart
|
||||||
|
|
||||||
CONSTANT: buffer-size 65536
|
CONSTANT: buffer-size 65536
|
||||||
|
@ -16,8 +16,7 @@ header
|
||||||
content-disposition bytes
|
content-disposition bytes
|
||||||
filename temp-file
|
filename temp-file
|
||||||
name name-content
|
name name-content
|
||||||
uploaded-files
|
mime-parts ;
|
||||||
form-variables ;
|
|
||||||
|
|
||||||
TUPLE: mime-file headers filename temporary-path ;
|
TUPLE: mime-file headers filename temporary-path ;
|
||||||
TUPLE: mime-variable headers key value ;
|
TUPLE: mime-variable headers key value ;
|
||||||
|
@ -25,8 +24,7 @@ TUPLE: mime-variable headers key value ;
|
||||||
: <multipart> ( mime-separator -- multipart )
|
: <multipart> ( mime-separator -- multipart )
|
||||||
multipart new
|
multipart new
|
||||||
swap >>mime-separator
|
swap >>mime-separator
|
||||||
H{ } clone >>uploaded-files
|
H{ } clone >>mime-parts ;
|
||||||
H{ } clone >>form-variables ;
|
|
||||||
|
|
||||||
ERROR: bad-header bytes ;
|
ERROR: bad-header bytes ;
|
||||||
|
|
||||||
|
@ -47,11 +45,7 @@ ERROR: end-of-stream multipart ;
|
||||||
dup bytes>> [ fill-bytes ] unless ;
|
dup bytes>> [ fill-bytes ] unless ;
|
||||||
|
|
||||||
: split-bytes ( bytes separator -- leftover-bytes safe-to-dump )
|
: split-bytes ( bytes separator -- leftover-bytes safe-to-dump )
|
||||||
2dup [ length ] [ length 1- ] bi* < [
|
dupd [ length ] bi@ 1- - short cut-slice swap ;
|
||||||
drop f
|
|
||||||
] [
|
|
||||||
length 1- cut-slice swap
|
|
||||||
] if ;
|
|
||||||
|
|
||||||
: dump-until-separator ( multipart -- multipart )
|
: dump-until-separator ( multipart -- multipart )
|
||||||
dup
|
dup
|
||||||
|
@ -59,11 +53,10 @@ ERROR: end-of-stream multipart ;
|
||||||
[ nip ] [ start ] 2bi [
|
[ nip ] [ start ] 2bi [
|
||||||
cut-slice
|
cut-slice
|
||||||
[ mime-write ]
|
[ mime-write ]
|
||||||
[ over current-separator>> length tail-slice >>bytes ] bi*
|
[ over current-separator>> length short tail-slice >>bytes ] bi*
|
||||||
] [
|
] [
|
||||||
drop
|
drop
|
||||||
dup [ bytes>> ] [ current-separator>> ] bi split-bytes
|
dup [ bytes>> ] [ current-separator>> ] bi split-bytes mime-write
|
||||||
[ mime-write ] when*
|
|
||||||
>>bytes fill-bytes dup end-of-stream?>> [ dump-until-separator ] unless
|
>>bytes fill-bytes dup end-of-stream?>> [ dump-until-separator ] unless
|
||||||
] if* ;
|
] if* ;
|
||||||
|
|
||||||
|
@ -72,31 +65,43 @@ ERROR: end-of-stream multipart ;
|
||||||
[ dump-until-separator ] with-string-writer ;
|
[ dump-until-separator ] with-string-writer ;
|
||||||
|
|
||||||
: read-header ( multipart -- multipart )
|
: read-header ( multipart -- multipart )
|
||||||
"\r\n\r\n" dump-string dup "--\r" = [
|
dup bytes>> "--\r\n" sequence= [
|
||||||
drop
|
t >>end-of-stream?
|
||||||
] [
|
] [
|
||||||
parse-headers >>header
|
"\r\n\r\n" dump-string parse-headers >>header
|
||||||
] if ;
|
] if ;
|
||||||
|
|
||||||
: empty-name? ( string -- ? )
|
: empty-name? ( string -- ? )
|
||||||
{ "''" "\"\"" "" f } member? ;
|
{ "''" "\"\"" "" f } member? ;
|
||||||
|
|
||||||
|
: quote? ( ch -- ? ) "'\"" member? ;
|
||||||
|
|
||||||
|
: quoted? ( str -- ? )
|
||||||
|
{
|
||||||
|
[ length 1 > ]
|
||||||
|
[ first quote? ]
|
||||||
|
[ [ first ] [ peek ] bi = ]
|
||||||
|
} 1&& ;
|
||||||
|
|
||||||
|
: unquote ( str -- newstr )
|
||||||
|
dup quoted? [ but-last-slice rest-slice >string ] when ;
|
||||||
|
|
||||||
: save-uploaded-file ( multipart -- )
|
: save-uploaded-file ( multipart -- )
|
||||||
dup filename>> empty-name? [
|
dup filename>> empty-name? [
|
||||||
drop
|
drop
|
||||||
] [
|
] [
|
||||||
[ [ header>> ] [ filename>> ] [ temp-file>> ] tri mime-file boa ]
|
[ [ header>> ] [ filename>> ] [ temp-file>> ] tri mime-file boa ]
|
||||||
[ filename>> ]
|
[ content-disposition>> "name" swap at unquote ]
|
||||||
[ uploaded-files>> set-at ] tri
|
[ mime-parts>> set-at ] tri
|
||||||
] if ;
|
] if ;
|
||||||
|
|
||||||
: save-form-variable ( multipart -- )
|
: save-mime-part ( multipart -- )
|
||||||
dup name>> empty-name? [
|
dup name>> empty-name? [
|
||||||
drop
|
drop
|
||||||
] [
|
] [
|
||||||
[ [ header>> ] [ name>> ] [ name-content>> ] tri mime-variable boa ]
|
[ [ header>> ] [ name>> unquote ] [ name-content>> ] tri mime-variable boa ]
|
||||||
[ name>> ]
|
[ name>> unquote ]
|
||||||
[ form-variables>> set-at ] tri
|
[ mime-parts>> set-at ] tri
|
||||||
] if ;
|
] if ;
|
||||||
|
|
||||||
: dump-mime-file ( multipart filename -- multipart )
|
: dump-mime-file ( multipart filename -- multipart )
|
||||||
|
@ -119,12 +124,13 @@ ERROR: unknown-content-disposition multipart ;
|
||||||
|
|
||||||
: parse-form-data ( multipart -- multipart )
|
: parse-form-data ( multipart -- multipart )
|
||||||
"filename" lookup-disposition [
|
"filename" lookup-disposition [
|
||||||
|
unquote
|
||||||
>>filename
|
>>filename
|
||||||
[ dump-file ] [ save-uploaded-file ] bi
|
[ dump-file ] [ save-uploaded-file ] bi
|
||||||
] [
|
] [
|
||||||
"name" lookup-disposition [
|
"name" lookup-disposition [
|
||||||
[ dup mime-separator>> dump-string >>name-content ] dip
|
[ dup mime-separator>> dump-string >>name-content ] dip
|
||||||
>>name dup save-form-variable
|
>>name dup save-mime-part
|
||||||
] [
|
] [
|
||||||
unknown-content-disposition
|
unknown-content-disposition
|
||||||
] if*
|
] if*
|
||||||
|
@ -157,6 +163,6 @@ ERROR: no-content-disposition multipart ;
|
||||||
read-header
|
read-header
|
||||||
dup end-of-stream?>> [ process-header parse-multipart-loop ] unless ;
|
dup end-of-stream?>> [ process-header parse-multipart-loop ] unless ;
|
||||||
|
|
||||||
: parse-multipart ( separator -- form-variables uploaded-files )
|
: parse-multipart ( separator -- mime-parts )
|
||||||
<multipart> parse-beginning parse-multipart-loop
|
<multipart> parse-beginning fill-bytes parse-multipart-loop
|
||||||
[ form-variables>> ] [ uploaded-files>> ] bi ;
|
mime-parts>> ;
|
||||||
|
|
|
@ -14,7 +14,7 @@ HELP: ppop
|
||||||
{ $contract "Persistent analogue of " { $link pop* } ". Outputs a new sequence with all elements of " { $snippet "seq" } " except for the final element." } ;
|
{ $contract "Persistent analogue of " { $link pop* } ". Outputs a new sequence with all elements of " { $snippet "seq" } " except for the final element." } ;
|
||||||
|
|
||||||
ARTICLE: "persistent.sequences" "Persistent sequence protocol"
|
ARTICLE: "persistent.sequences" "Persistent sequence protocol"
|
||||||
"The persistent sequence protocol consists of the non-mutating sequence protocol words, such as " { $link length } " and " { $link nth } ", together with the following operations:"
|
"The persistent sequence protocol consists of the non-mutating sequence protocol words, such as " { $link length } " and " { $link nth } ", together with the following operations:"
|
||||||
{ $subsection new-nth }
|
{ $subsection new-nth }
|
||||||
{ $subsection ppush }
|
{ $subsection ppush }
|
||||||
{ $subsection ppop }
|
{ $subsection ppop }
|
||||||
|
|
|
@ -193,11 +193,11 @@ HELP: unparse
|
||||||
|
|
||||||
HELP: pprint-short
|
HELP: pprint-short
|
||||||
{ $values { "obj" object } }
|
{ $values { "obj" object } }
|
||||||
{ $description "Prettyprints an object to " { $link output-stream } ". This word rebinds printer control variables to enforce ``shorter'' output. See " { $link "prettyprint-variables" } "." } ;
|
{ $description "Prettyprints an object to " { $link output-stream } ". This word rebinds printer control variables to enforce “shorter” output. See " { $link "prettyprint-variables" } "." } ;
|
||||||
|
|
||||||
HELP: short.
|
HELP: short.
|
||||||
{ $values { "obj" object } }
|
{ $values { "obj" object } }
|
||||||
{ $description "Prettyprints an object to " { $link output-stream } " with a trailing line break. This word rebinds printer control variables to enforce ``shorter'' output." } ;
|
{ $description "Prettyprints an object to " { $link output-stream } " with a trailing line break. This word rebinds printer control variables to enforce “shorter” output." } ;
|
||||||
|
|
||||||
HELP: .b
|
HELP: .b
|
||||||
{ $values { "n" "an integer" } }
|
{ $values { "n" "an integer" } }
|
||||||
|
|
|
@ -73,7 +73,7 @@ ARTICLE: "random-protocol" "Random protocol"
|
||||||
ARTICLE: "random" "Generating random integers"
|
ARTICLE: "random" "Generating random integers"
|
||||||
"The " { $vocab-link "random" } " vocabulary contains a protocol for generating random or pseudorandom numbers."
|
"The " { $vocab-link "random" } " vocabulary contains a protocol for generating random or pseudorandom numbers."
|
||||||
$nl
|
$nl
|
||||||
"The ``Mersenne Twister'' pseudorandom number generator algorithm is the default generator stored in " { $link random-generator } "."
|
"The “Mersenne Twister” pseudorandom number generator algorithm is the default generator stored in " { $link random-generator } "."
|
||||||
$nl
|
$nl
|
||||||
"Generate a random object:"
|
"Generate a random object:"
|
||||||
{ $subsection random }
|
{ $subsection random }
|
||||||
|
|
|
@ -11,19 +11,19 @@ HELP: find-numbers
|
||||||
}
|
}
|
||||||
{ $description "Splits a string on numbers and returns a sequence of sequences and integers." } ;
|
{ $description "Splits a string on numbers and returns a sequence of sequences and integers." } ;
|
||||||
|
|
||||||
HELP: human-<=>
|
HELP: human<=>
|
||||||
{ $values
|
{ $values
|
||||||
{ "obj1" object } { "obj2" object }
|
{ "obj1" object } { "obj2" object }
|
||||||
{ "<=>" "an ordering specifier" }
|
{ "<=>" "an ordering specifier" }
|
||||||
}
|
}
|
||||||
{ $description "Compares two objects after converting numbers in the string into integers." } ;
|
{ $description "Compares two objects after converting numbers in the string into integers." } ;
|
||||||
|
|
||||||
HELP: human->=<
|
HELP: human>=<
|
||||||
{ $values
|
{ $values
|
||||||
{ "obj1" object } { "obj2" object }
|
{ "obj1" object } { "obj2" object }
|
||||||
{ ">=<" "an ordering specifier" }
|
{ ">=<" "an ordering specifier" }
|
||||||
}
|
}
|
||||||
{ $description "Compares two objects using the " { $link human-<=> } " word and inverts the result." } ;
|
{ $description "Compares two objects using the " { $link human<=> } " word and inverts the result." } ;
|
||||||
|
|
||||||
HELP: human-compare
|
HELP: human-compare
|
||||||
{ $values
|
{ $values
|
||||||
|
@ -44,22 +44,22 @@ HELP: human-sort-keys
|
||||||
{ "seq" "an alist" }
|
{ "seq" "an alist" }
|
||||||
{ "sortedseq" "a new sorted sequence" }
|
{ "sortedseq" "a new sorted sequence" }
|
||||||
}
|
}
|
||||||
{ $description "Sorts the elements comparing first elements of pairs using the " { $link human-<=> } " word." } ;
|
{ $description "Sorts the elements comparing first elements of pairs using the " { $link human<=> } " word." } ;
|
||||||
|
|
||||||
HELP: human-sort-values
|
HELP: human-sort-values
|
||||||
{ $values
|
{ $values
|
||||||
{ "seq" "an alist" }
|
{ "seq" "an alist" }
|
||||||
{ "sortedseq" "a new sorted sequence" }
|
{ "sortedseq" "a new sorted sequence" }
|
||||||
}
|
}
|
||||||
{ $description "Sorts the elements comparing second elements of pairs using the " { $link human-<=> } " word." } ;
|
{ $description "Sorts the elements comparing second elements of pairs using the " { $link human<=> } " word." } ;
|
||||||
|
|
||||||
{ <=> >=< human-compare human-sort human-sort-keys human-sort-values } related-words
|
{ <=> >=< human-compare human-sort human-sort-keys human-sort-values } related-words
|
||||||
|
|
||||||
ARTICLE: "sorting.human" "sorting.human"
|
ARTICLE: "sorting.human" "Human-friendly sorting"
|
||||||
"The " { $vocab-link "sorting.human" } " vocabulary sorts by numbers as a human would -- by comparing their magnitudes -- rather than in a lexicographic way. For example, sorting a1, a10, a03, a2 with human sort returns a1, a2, a03, a10, while sorting with natural sort returns a03, a1, a10, a2." $nl
|
"The " { $vocab-link "sorting.human" } " vocabulary sorts by numbers as a human would -- by comparing their magnitudes -- rather than in a lexicographic way. For example, sorting a1, a10, a03, a2 with human sort returns a1, a2, a03, a10, while sorting with natural sort returns a03, a1, a10, a2." $nl
|
||||||
"Comparing two objects:"
|
"Comparing two objects:"
|
||||||
{ $subsection human-<=> }
|
{ $subsection human<=> }
|
||||||
{ $subsection human->=< }
|
{ $subsection human>=< }
|
||||||
{ $subsection human-compare }
|
{ $subsection human-compare }
|
||||||
"Sort a sequence:"
|
"Sort a sequence:"
|
||||||
{ $subsection human-sort }
|
{ $subsection human-sort }
|
||||||
|
|
|
@ -7,13 +7,13 @@ IN: sorting.human
|
||||||
: find-numbers ( string -- seq )
|
: find-numbers ( string -- seq )
|
||||||
[EBNF Result = ([0-9]+ => [[ string>number ]] | (!([0-9]) .)+)* EBNF] ;
|
[EBNF Result = ([0-9]+ => [[ string>number ]] | (!([0-9]) .)+)* EBNF] ;
|
||||||
|
|
||||||
: human-<=> ( obj1 obj2 -- <=> ) [ find-numbers ] bi@ <=> ;
|
: human<=> ( obj1 obj2 -- <=> ) [ find-numbers ] bi@ <=> ;
|
||||||
|
|
||||||
: human->=< ( obj1 obj2 -- >=< ) human-<=> invert-comparison ; inline
|
: human>=< ( obj1 obj2 -- >=< ) human<=> invert-comparison ; inline
|
||||||
|
|
||||||
: human-compare ( obj1 obj2 quot -- <=> ) bi@ human-<=> ;
|
: human-compare ( obj1 obj2 quot -- <=> ) bi@ human<=> ;
|
||||||
|
|
||||||
: human-sort ( seq -- seq' ) [ human-<=> ] sort ;
|
: human-sort ( seq -- seq' ) [ human<=> ] sort ;
|
||||||
|
|
||||||
: human-sort-keys ( seq -- sortedseq )
|
: human-sort-keys ( seq -- sortedseq )
|
||||||
[ [ first ] human-compare ] sort ;
|
[ [ first ] human-compare ] sort ;
|
||||||
|
|
|
@ -41,7 +41,7 @@ TUPLE: tuple2 d ;
|
||||||
T{ sort-test f 1 1 11 }
|
T{ sort-test f 1 1 11 }
|
||||||
T{ sort-test f 2 5 3 }
|
T{ sort-test f 2 5 3 }
|
||||||
T{ sort-test f 2 5 2 }
|
T{ sort-test f 2 5 2 }
|
||||||
} { { a>> human-<=> } { b>> human->=< } { c>> <=> } } sort-by-slots
|
} { { a>> human<=> } { b>> human>=< } { c>> <=> } } sort-by-slots
|
||||||
] unit-test
|
] unit-test
|
||||||
|
|
||||||
[
|
[
|
||||||
|
@ -64,7 +64,7 @@ TUPLE: tuple2 d ;
|
||||||
T{ sort-test f 2 5 3 }
|
T{ sort-test f 2 5 3 }
|
||||||
T{ sort-test f 2 5 2 }
|
T{ sort-test f 2 5 2 }
|
||||||
}
|
}
|
||||||
{ { a>> human-<=> } { b>> <=> } } [ sort-by-slots ] keep
|
{ { a>> human<=> } { b>> <=> } } [ sort-by-slots ] keep
|
||||||
[ but-last-slice ] map split-by-slots [ >array ] map
|
[ but-last-slice ] map split-by-slots [ >array ] map
|
||||||
] unit-test
|
] unit-test
|
||||||
|
|
||||||
|
|
|
@ -21,7 +21,7 @@ $nl
|
||||||
|
|
||||||
ARTICLE: "inference-combinators" "Combinator stack effects"
|
ARTICLE: "inference-combinators" "Combinator stack effects"
|
||||||
"Without further information, one cannot say what the stack effect of " { $link call } " is; it depends on the given quotation. If the inferencer encounters a " { $link call } " without further information, a " { $link literal-expected } " error is raised."
|
"Without further information, one cannot say what the stack effect of " { $link call } " is; it depends on the given quotation. If the inferencer encounters a " { $link call } " without further information, a " { $link literal-expected } " error is raised."
|
||||||
{ $example "[ dup call ] infer." "... an error ..." }
|
{ $example "[ dup call ] infer." "Literal value expected\n\nType :help for debugging help." }
|
||||||
"On the other hand, the stack effect of applying " { $link call } " to a literal quotation or a " { $link curry } " of a literal quotation is easy to compute; it behaves as if the quotation was substituted at that point:"
|
"On the other hand, the stack effect of applying " { $link call } " to a literal quotation or a " { $link curry } " of a literal quotation is easy to compute; it behaves as if the quotation was substituted at that point:"
|
||||||
{ $example "[ [ 2 + ] call ] infer." "( object -- object )" }
|
{ $example "[ [ 2 + ] call ] infer." "( object -- object )" }
|
||||||
"Consider a combinator such as " { $link keep } ". The combinator itself does not have a stack effect, because it applies " { $link call } " to a potentially arbitrary quotation. However, since the combinator is declared " { $link POSTPONE: inline } ", a given usage of it can have a stack effect:"
|
"Consider a combinator such as " { $link keep } ". The combinator itself does not have a stack effect, because it applies " { $link call } " to a potentially arbitrary quotation. However, since the combinator is declared " { $link POSTPONE: inline } ", a given usage of it can have a stack effect:"
|
||||||
|
@ -35,7 +35,15 @@ $nl
|
||||||
"Here is an example where the stack effect cannot be inferred:"
|
"Here is an example where the stack effect cannot be inferred:"
|
||||||
{ $code ": foo 0 [ + ] ;" "[ foo reduce ] infer." }
|
{ $code ": foo 0 [ + ] ;" "[ foo reduce ] infer." }
|
||||||
"However if " { $snippet "foo" } " was declared " { $link POSTPONE: inline } ", everything would work, since the " { $link reduce } " combinator is also " { $link POSTPONE: inline } ", and the inferencer can see the literal quotation value at the point it is passed to " { $link call } ":"
|
"However if " { $snippet "foo" } " was declared " { $link POSTPONE: inline } ", everything would work, since the " { $link reduce } " combinator is also " { $link POSTPONE: inline } ", and the inferencer can see the literal quotation value at the point it is passed to " { $link call } ":"
|
||||||
{ $example ": foo 0 [ + ] ; inline" "[ foo reduce ] infer." "( object -- object )" } ;
|
{ $example ": foo 0 [ + ] ; inline" "[ foo reduce ] infer." "( object -- object )" }
|
||||||
|
"Passing a literal quotation on the data stack through an inlined recursive combinator nullifies its literal status. For example, the following will not infer:"
|
||||||
|
{ $example
|
||||||
|
"[ [ reverse ] swap [ reverse ] map swap call ] infer." "Literal value expected\n\nType :help for debugging help."
|
||||||
|
}
|
||||||
|
"To make this work, pass the quotation on the retain stack instead:"
|
||||||
|
{ $example
|
||||||
|
"[ [ reverse ] [ [ reverse ] map ] dip call ] infer." "( object -- object )"
|
||||||
|
} ;
|
||||||
|
|
||||||
ARTICLE: "inference-branches" "Branch stack effects"
|
ARTICLE: "inference-branches" "Branch stack effects"
|
||||||
"Conditionals such as " { $link if } " and combinators built on " { $link if } " present a problem, in that if the two branches leave the stack at a different height, it is not clear what the stack effect should be. In this case, inference throws a " { $link unbalanced-branches-error } "."
|
"Conditionals such as " { $link if } " and combinators built on " { $link if } " present a problem, in that if the two branches leave the stack at a different height, it is not clear what the stack effect should be. In this case, inference throws a " { $link unbalanced-branches-error } "."
|
||||||
|
@ -58,12 +66,14 @@ $nl
|
||||||
$nl
|
$nl
|
||||||
"If a recursive word takes quotation parameters from the stack and calls them, it must be declared " { $link POSTPONE: inline } " (as documented in " { $link "inference-combinators" } ") as well as " { $link POSTPONE: recursive } "."
|
"If a recursive word takes quotation parameters from the stack and calls them, it must be declared " { $link POSTPONE: inline } " (as documented in " { $link "inference-combinators" } ") as well as " { $link POSTPONE: recursive } "."
|
||||||
$nl
|
$nl
|
||||||
"Furthermore, the input parameters which are quotations must be annotated in the stack effect. For example,"
|
"Furthermore, the input parameters which are quotations must be annotated in the stack effect. For example, the following will not infer:"
|
||||||
{ $see loop }
|
{ $example ": bad ( quot -- ) [ call ] keep foo ; inline recursive" "[ [ ] bad ] infer." "Literal value expected\n\nType :help for debugging help." }
|
||||||
"An inline recursive word cannot pass a quotation through the recursive call. For example, the following will not infer:"
|
"The following is correct:"
|
||||||
{ $code ": foo ( a b c -- d e f ) [ f foo drop ] when 2dup call ; inline" "[ 1 [ 1+ ] foo ] infer." }
|
{ $example ": good ( quot: ( -- ) -- ) [ call ] keep good ; inline recursive" "[ [ ] good ] infer." "( -- )" }
|
||||||
|
"An inline recursive word cannot pass a quotation on the data stack through the recursive call. For example, the following will not infer:"
|
||||||
|
{ $example ": bad ( ? quot: ( ? -- ) -- ) 2dup [ not ] dip bad call ; inline recursive" "[ [ drop ] bad ] infer." "Literal value expected\n\nType :help for debugging help." }
|
||||||
"However a small change can be made:"
|
"However a small change can be made:"
|
||||||
{ $example ": foo ( a b c -- d ) [ 2dup f foo drop ] when call ; inline" "[ 1 [ 1+ ] t foo ] infer." "( -- object )" }
|
{ $example ": good ( ? quot: ( ? -- ) -- ) [ good ] 2keep [ not ] dip call ; inline recursive" "[ [ drop ] good ] infer." "( object -- )" }
|
||||||
"An inline recursive word must have a fixed stack effect in its base case. The following will not infer:"
|
"An inline recursive word must have a fixed stack effect in its base case. The following will not infer:"
|
||||||
{ $code
|
{ $code
|
||||||
": foo ( quot ? -- ) [ f foo ] [ call ] if ; inline"
|
": foo ( quot ? -- ) [ f foo ] [ call ] if ; inline"
|
||||||
|
|
|
@ -2,10 +2,10 @@ IN: tools.threads
|
||||||
USING: help.markup help.syntax threads ;
|
USING: help.markup help.syntax threads ;
|
||||||
|
|
||||||
HELP: threads.
|
HELP: threads.
|
||||||
{ $description "Prints a list of running threads and their state. The ``Waiting on'' column displays one of the following:"
|
{ $description "Prints a list of running threads and their state. The “Waiting on” column displays one of the following:"
|
||||||
{ $list
|
{ $list
|
||||||
"``running'' if the thread is the current thread"
|
"“running” if the thread is the current thread"
|
||||||
"``yield'' if the thread is waiting to run"
|
"“yield” if the thread is waiting to run"
|
||||||
{ "the string given to " { $link suspend } " if the thread is suspended" }
|
{ "the string given to " { $link suspend } " if the thread is suspended" }
|
||||||
}
|
}
|
||||||
} ;
|
} ;
|
||||||
|
|
|
@ -1,9 +1,9 @@
|
||||||
! Copyright (C) 2008 Slava Pestov.
|
! Copyright (C) 2008, 2009 Slava Pestov.
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: threads io.files io.pathnames io.monitors init kernel
|
USING: threads io.files io.pathnames io.monitors init kernel
|
||||||
vocabs vocabs.loader tools.vocabs namespaces continuations
|
vocabs vocabs.loader tools.vocabs namespaces continuations
|
||||||
sequences splitting assocs command-line concurrency.messaging
|
sequences splitting assocs command-line concurrency.messaging
|
||||||
io.backend sets tr ;
|
io.backend sets tr accessors ;
|
||||||
IN: tools.vocabs.monitor
|
IN: tools.vocabs.monitor
|
||||||
|
|
||||||
TR: convert-separators "/\\" ".." ;
|
TR: convert-separators "/\\" ".." ;
|
||||||
|
@ -29,7 +29,7 @@ TR: convert-separators "/\\" ".." ;
|
||||||
: monitor-loop ( -- )
|
: monitor-loop ( -- )
|
||||||
#! On OS X, monitors give us the full path, so we chop it
|
#! On OS X, monitors give us the full path, so we chop it
|
||||||
#! off if its there.
|
#! off if its there.
|
||||||
receive first path>vocab changed-vocab
|
receive path>> path>vocab changed-vocab
|
||||||
reset-cache
|
reset-cache
|
||||||
monitor-loop ;
|
monitor-loop ;
|
||||||
|
|
||||||
|
|
|
@ -85,7 +85,7 @@ ARTICLE: "ui-completion-vocabs" "Vocabulary completion popup"
|
||||||
{ $operations "kernel" vocab } ;
|
{ $operations "kernel" vocab } ;
|
||||||
|
|
||||||
ARTICLE: "ui-completion-sources" "Source file completion popup"
|
ARTICLE: "ui-completion-sources" "Source file completion popup"
|
||||||
"The source file completion popup lists all source files which have been previously loaded by " { $link run-file } ". Clicking a source file or pressing " { $snippet "RET" } " opens the source file in your editor with " { $link edit } "."
|
"The source file completion popup lists all source files which have been previously loaded by " { $link run-file } ". Clicking a source file or pressing " { $snippet "RET" } " opens the source file in your editor with " { $link edit } "."
|
||||||
{ $operations P" " } ;
|
{ $operations P" " } ;
|
||||||
|
|
||||||
ARTICLE: "ui-completion" "UI completion popups"
|
ARTICLE: "ui-completion" "UI completion popups"
|
||||||
|
|
|
@ -185,7 +185,9 @@ $nl
|
||||||
{ $subsection add-gadgets }
|
{ $subsection add-gadgets }
|
||||||
{ $subsection clear-gadget }
|
{ $subsection clear-gadget }
|
||||||
"The children of a gadget are available via the "
|
"The children of a gadget are available via the "
|
||||||
{ $snippet "children" } " slot. " "Working with gadget children:"
|
{ $snippet "children" } " slot. "
|
||||||
|
$nl
|
||||||
|
"Working with gadget children:"
|
||||||
{ $subsection gadget-child }
|
{ $subsection gadget-child }
|
||||||
{ $subsection nth-gadget }
|
{ $subsection nth-gadget }
|
||||||
{ $subsection each-child }
|
{ $subsection each-child }
|
||||||
|
@ -199,7 +201,7 @@ $nl
|
||||||
{ $subsection relayout-1 }
|
{ $subsection relayout-1 }
|
||||||
"Gadgets implement a generic word to inform their parents of their preferred size:"
|
"Gadgets implement a generic word to inform their parents of their preferred size:"
|
||||||
{ $subsection pref-dim* }
|
{ $subsection pref-dim* }
|
||||||
"To get a gadget's preferred size, do not call the above word, instead use " { $link pref-dim } ", which caches the result." ;
|
"To get a gadget's preferred size, do not call the above word, instead use " { $link pref-dim } ", which caches the result." ;
|
||||||
|
|
||||||
ARTICLE: "ui-null-layout" "Manual layouts"
|
ARTICLE: "ui-null-layout" "Manual layouts"
|
||||||
"When automatic layout is not appropriate, gadgets can be added to a parent with no layout policy, and then positioned and sized manually by setting the " { $snippet "loc" } " field." ;
|
"When automatic layout is not appropriate, gadgets can be added to a parent with no layout policy, and then positioned and sized manually by setting the " { $snippet "loc" } " field." ;
|
||||||
|
|
|
@ -9,7 +9,7 @@ M: unix-error error.
|
||||||
dup message>> write " (" write errno>> pprint ")" print ;
|
dup message>> write " (" write errno>> pprint ")" print ;
|
||||||
|
|
||||||
M: unix-system-call-error error.
|
M: unix-system-call-error error.
|
||||||
"Unix system call ``" write dup word>> pprint "'' failed:" print
|
"Unix system call “" write dup word>> pprint "” failed:" print
|
||||||
nl
|
nl
|
||||||
dup message>> write " (" write dup errno>> pprint ")" print
|
dup message>> write " (" write dup errno>> pprint ")" print
|
||||||
nl
|
nl
|
||||||
|
|
|
@ -83,7 +83,6 @@ ARTICLE: "unix.groups" "Unix groups"
|
||||||
$nl
|
$nl
|
||||||
"Listing all groups:"
|
"Listing all groups:"
|
||||||
{ $subsection all-groups }
|
{ $subsection all-groups }
|
||||||
"Returning a passwd tuple:"
|
|
||||||
"Real groups:"
|
"Real groups:"
|
||||||
{ $subsection real-group-name }
|
{ $subsection real-group-name }
|
||||||
{ $subsection real-group-id }
|
{ $subsection real-group-id }
|
||||||
|
|
|
@ -91,7 +91,6 @@ ARTICLE: "unix.users" "Unix users"
|
||||||
$nl
|
$nl
|
||||||
"Listing all users:"
|
"Listing all users:"
|
||||||
{ $subsection all-users }
|
{ $subsection all-users }
|
||||||
"Returning a passwd tuple:"
|
|
||||||
"Real user:"
|
"Real user:"
|
||||||
{ $subsection real-user-name }
|
{ $subsection real-user-name }
|
||||||
{ $subsection real-user-id }
|
{ $subsection real-user-id }
|
||||||
|
|
|
@ -3,7 +3,7 @@
|
||||||
USING: accessors kernel xml arrays math generic http.client
|
USING: accessors kernel xml arrays math generic http.client
|
||||||
combinators hashtables namespaces io base64 sequences strings
|
combinators hashtables namespaces io base64 sequences strings
|
||||||
calendar xml.data xml.writer xml.utilities assocs math.parser
|
calendar xml.data xml.writer xml.utilities assocs math.parser
|
||||||
debugger calendar.format math.order ;
|
debugger calendar.format math.order xml.interpolate xml.dispatch ;
|
||||||
IN: xml-rpc
|
IN: xml-rpc
|
||||||
|
|
||||||
! * Sending RPC requests
|
! * Sending RPC requests
|
||||||
|
@ -15,56 +15,70 @@ GENERIC: item>xml ( object -- xml )
|
||||||
M: integer item>xml
|
M: integer item>xml
|
||||||
dup 31 2^ neg 31 2^ 1 - between?
|
dup 31 2^ neg 31 2^ 1 - between?
|
||||||
[ "Integers must fit in 32 bits" throw ] unless
|
[ "Integers must fit in 32 bits" throw ] unless
|
||||||
number>string "i4" build-tag ;
|
[XML <i4><-></i4> XML] ;
|
||||||
|
|
||||||
UNION: boolean t POSTPONE: f ;
|
UNION: boolean t POSTPONE: f ;
|
||||||
|
|
||||||
M: boolean item>xml
|
M: boolean item>xml
|
||||||
"1" "0" ? "boolean" build-tag ;
|
"1" "0" ? [XML <boolean><-></boolean> XML] ;
|
||||||
|
|
||||||
M: float item>xml
|
M: float item>xml
|
||||||
number>string "double" build-tag ;
|
number>string [XML <double><-></double> XML] ;
|
||||||
|
|
||||||
M: string item>xml ! This should change < and &
|
M: string item>xml
|
||||||
"string" build-tag ;
|
[XML <string><-></string> XML] ;
|
||||||
|
|
||||||
: struct-member ( name value -- tag )
|
: struct-member ( name value -- tag )
|
||||||
swap dup string?
|
over string? [ "Struct member name must be string" throw ] unless
|
||||||
[ "Struct member name must be string" throw ] unless
|
item>xml
|
||||||
"name" build-tag swap
|
[XML
|
||||||
item>xml "value" build-tag
|
<member>
|
||||||
2array "member" build-tag* ;
|
<name><-></name>
|
||||||
|
<value><-></value>
|
||||||
|
</member>
|
||||||
|
XML] ;
|
||||||
|
|
||||||
M: hashtable item>xml
|
M: hashtable item>xml
|
||||||
[ struct-member ] { } assoc>map
|
[ struct-member ] { } assoc>map
|
||||||
"struct" build-tag* ;
|
[XML <struct><-></struct> XML] ;
|
||||||
|
|
||||||
M: array item>xml
|
M: array item>xml
|
||||||
[ item>xml "value" build-tag ] map
|
[ item>xml [XML <value><-></value> XML] ] map
|
||||||
"data" build-tag* "array" build-tag ;
|
[XML <array><data><-></data></array> XML] ;
|
||||||
|
|
||||||
TUPLE: base64 string ;
|
TUPLE: base64 string ;
|
||||||
|
|
||||||
C: <base64> base64
|
C: <base64> base64
|
||||||
|
|
||||||
M: base64 item>xml
|
M: base64 item>xml
|
||||||
string>> >base64 "base64" build-tag ;
|
string>> >base64
|
||||||
|
[XML <base64><-></base64> XML] ;
|
||||||
|
|
||||||
: params ( seq -- xml )
|
: params ( seq -- xml )
|
||||||
[ item>xml "value" build-tag "param" build-tag ] map
|
[ item>xml [XML <param><value><-></value></param> XML] ] map
|
||||||
"params" build-tag* ;
|
[XML <params><-></params> XML] ;
|
||||||
|
|
||||||
: method-call ( name seq -- xml )
|
: method-call ( name seq -- xml )
|
||||||
params [ "methodName" build-tag ] dip
|
params
|
||||||
2array "methodCall" build-tag* build-xml ;
|
<XML
|
||||||
|
<methodCall>
|
||||||
|
<methodName><-></methodName>
|
||||||
|
<->
|
||||||
|
</methodCall>
|
||||||
|
XML> ;
|
||||||
|
|
||||||
: return-params ( seq -- xml )
|
: return-params ( seq -- xml )
|
||||||
params "methodResponse" build-tag build-xml ;
|
params <XML <methodResponse><-></methodResponse> XML> ;
|
||||||
|
|
||||||
: return-fault ( fault-code fault-string -- xml )
|
: return-fault ( fault-code fault-string -- xml )
|
||||||
[ "faultString" set "faultCode" set ] H{ } make-assoc item>xml
|
[ "faultString" set "faultCode" set ] H{ } make-assoc item>xml
|
||||||
"value" build-tag "fault" build-tag "methodResponse" build-tag
|
<XML
|
||||||
build-xml ;
|
<methodResponse>
|
||||||
|
<fault>
|
||||||
|
<value><-></value>
|
||||||
|
</fault>
|
||||||
|
</methodResponse>
|
||||||
|
XML> ;
|
||||||
|
|
||||||
TUPLE: rpc-method name params ;
|
TUPLE: rpc-method name params ;
|
||||||
|
|
||||||
|
@ -162,10 +176,3 @@ TAG: array xml>item
|
||||||
|
|
||||||
: invoke-method ( params method url -- )
|
: invoke-method ( params method url -- )
|
||||||
[ swap <rpc-method> ] dip post-rpc ;
|
[ swap <rpc-method> ] dip post-rpc ;
|
||||||
|
|
||||||
: put-http-response ( string -- )
|
|
||||||
"HTTP/1.1 200 OK\nConnection: close\nContent-Length: " write
|
|
||||||
dup length number>string write
|
|
||||||
"\nContent-Type: text/xml\nDate: " write
|
|
||||||
now timestamp>http-string write "\n\n" write
|
|
||||||
write ;
|
|
||||||
|
|
|
@ -4,7 +4,7 @@ IN: xml.data
|
||||||
ABOUT: "xml.data"
|
ABOUT: "xml.data"
|
||||||
|
|
||||||
ARTICLE: "xml.data" "XML data types"
|
ARTICLE: "xml.data" "XML data types"
|
||||||
{ $vocab-link "xml.data" } " defines a simple document object model for XML. Everything is simply a tuple and can be manipulated as such."
|
"The " { $vocab-link "xml.data" } " vocabulary defines a simple document object model for XML. Everything is simply a tuple and can be manipulated as such."
|
||||||
{ $subsection { "xml.data" "classes" } }
|
{ $subsection { "xml.data" "classes" } }
|
||||||
{ $subsection { "xml.data" "constructors" } }
|
{ $subsection { "xml.data" "constructors" } }
|
||||||
"Simple words for manipulating names:"
|
"Simple words for manipulating names:"
|
||||||
|
@ -49,7 +49,7 @@ ARTICLE: { "xml.data" "constructors" } "XML data constructors"
|
||||||
{ $subsection <notation-decl> } ;
|
{ $subsection <notation-decl> } ;
|
||||||
|
|
||||||
HELP: tag
|
HELP: tag
|
||||||
{ $class-description "tuple representing an XML tag, delegating to a " { $link
|
{ $class-description "Tuple representing an XML tag, delegating to a " { $link
|
||||||
name } ", containing the slots attrs (an alist of names to strings) and children (a sequence). Tags implement the sequence protocol by acting like a sequence of its chidren, and the assoc protocol by acting like its attributes." }
|
name } ", containing the slots attrs (an alist of names to strings) and children (a sequence). Tags implement the sequence protocol by acting like a sequence of its chidren, and the assoc protocol by acting like its attributes." }
|
||||||
{ $see-also <tag> name contained-tag xml } ;
|
{ $see-also <tag> name contained-tag xml } ;
|
||||||
|
|
||||||
|
@ -58,32 +58,32 @@ HELP: <tag>
|
||||||
{ "attrs" "an alist of names to strings" }
|
{ "attrs" "an alist of names to strings" }
|
||||||
{ "children" sequence }
|
{ "children" sequence }
|
||||||
{ "tag" tag } }
|
{ "tag" tag } }
|
||||||
{ $description "constructs an XML " { $link tag } " with the name (not a string) and tag attributes specified in attrs and children specified" }
|
{ $description "Constructs an XML " { $link tag } " with the name (not a string) and tag attributes specified in attrs and children specified." }
|
||||||
{ $see-also tag <contained-tag> } ;
|
{ $see-also tag <contained-tag> } ;
|
||||||
|
|
||||||
HELP: name
|
HELP: name
|
||||||
{ $class-description "represents an XML name, with the fields space (a string representing the namespace, as written in the document, tag (a string of the actual name of the tag) and url (a string of the URL that the namespace points to)" }
|
{ $class-description "Represents an XML name, with the fields space (a string representing the namespace, as written in the document, tag (a string of the actual name of the tag) and url (a string of the URL that the namespace points to)." }
|
||||||
{ $see-also <name> tag } ;
|
{ $see-also <name> tag } ;
|
||||||
|
|
||||||
HELP: <name>
|
HELP: <name>
|
||||||
{ $values { "space" "a string" } { "main" "a string" } { "url" "a string" }
|
{ $values { "space" "a string" } { "main" "a string" } { "url" "a string" }
|
||||||
{ "name" "an XML tag name" } }
|
{ "name" "an XML tag name" } }
|
||||||
{ $description "creates a name tuple with the name-space space and the tag-name tag and the tag-url url." }
|
{ $description "Creates a name tuple with the namespace prefix space, the the given main part of the name, and the namespace URL given by url." }
|
||||||
{ $see-also name <tag> } ;
|
{ $see-also name <tag> } ;
|
||||||
|
|
||||||
HELP: contained-tag
|
HELP: contained-tag
|
||||||
{ $class-description "delegates to tag representing a tag like <a/> with no contents. The tag attributes are accessed with tag-attrs" }
|
{ $class-description "This is a subclass of " { $link tag } " consisting of tags with no body, like " { $snippet "<a/>" } "." }
|
||||||
{ $see-also tag <contained-tag> } ;
|
{ $see-also tag <contained-tag> } ;
|
||||||
|
|
||||||
HELP: <contained-tag>
|
HELP: <contained-tag>
|
||||||
{ $values { "name" "an XML tag name" }
|
{ $values { "name" "an XML tag name" }
|
||||||
{ "attrs" "an alist from names to strings" }
|
{ "attrs" "an alist from names to strings" }
|
||||||
{ "tag" tag } }
|
{ "tag" tag } }
|
||||||
{ $description "creates an empty tag (like <a/>) with the specified name and tag attributes. This delegates to tag" }
|
{ $description "Creates an empty tag (like " { $snippet "<a/>" } ") with the specified name and tag attributes." }
|
||||||
{ $see-also contained-tag <tag> } ;
|
{ $see-also contained-tag <tag> } ;
|
||||||
|
|
||||||
HELP: xml
|
HELP: xml
|
||||||
{ $class-description "tuple representing an XML document, delegating to the main tag, containing the fields prolog (the header <?xml...?>), before (whatever comes between the prolog and the main tag) and after (whatever comes after the main tag)" }
|
{ $class-description "Tuple representing an XML document, delegating to the main tag, containing the fields prolog (the header " { $snippet "<?xml...?>" } "), before (whatever comes between the prolog and the main tag) and after (whatever comes after the main tag)." }
|
||||||
{ $see-also <xml> tag prolog } ;
|
{ $see-also <xml> tag prolog } ;
|
||||||
|
|
||||||
HELP: <xml>
|
HELP: <xml>
|
||||||
|
@ -159,35 +159,35 @@ HELP: <element-decl>
|
||||||
{ $description "Creates an element declaration object, of the class " { $link element-decl } } ;
|
{ $description "Creates an element declaration object, of the class " { $link element-decl } } ;
|
||||||
|
|
||||||
HELP: attlist-decl
|
HELP: attlist-decl
|
||||||
{ $class-description "Describes the class of element declarations, like <!ATTLIST pre xml:space (preserve) #FIXED 'preserve'>." } ;
|
{ $class-description "Describes the class of element declarations, like " { $snippet "<!ATTLIST pre xml:space (preserve) #FIXED 'preserve'>" } "." } ;
|
||||||
|
|
||||||
HELP: <attlist-decl>
|
HELP: <attlist-decl>
|
||||||
{ $values { "name" name } { "att-defs" string } { "attlist-decl" attlist-decl } }
|
{ $values { "name" name } { "att-defs" string } { "attlist-decl" attlist-decl } }
|
||||||
{ $description "Creates an element declaration object, of the class " { $link attlist-decl } } ;
|
{ $description "Creates an element declaration object, of the class " { $link attlist-decl } } ;
|
||||||
|
|
||||||
HELP: entity-decl
|
HELP: entity-decl
|
||||||
{ $class-description "Describes the class of element declarations, like <!ENTITY foo 'bar'>." } ;
|
{ $class-description "Describes the class of element declarations, like " { $snippet "<!ENTITY foo 'bar'>" } "." } ;
|
||||||
|
|
||||||
HELP: <entity-decl>
|
HELP: <entity-decl>
|
||||||
{ $values { "name" name } { "def" string } { "pe?" "t or f" } { "entity-decl" entity-decl } }
|
{ $values { "name" name } { "def" string } { "pe?" "t or f" } { "entity-decl" entity-decl } }
|
||||||
{ $description "Creates an entity declaration object, of the class " { $link entity-decl } ". The pe? slot should be t if the object is a DTD-internal entity, like <!ENTITY % foo 'bar'> and f if the object is like <!ENTITY foo 'bar'>, that is, it can be used outside of the DTD." } ;
|
{ $description "Creates an entity declaration object, of the class " { $link entity-decl } ". The pe? slot should be t if the object is a DTD-internal entity, like " { $snippet "<!ENTITY % foo 'bar'>" } " and f if the object is like " { $snippet "<!ENTITY foo 'bar'>" } ", that is, it can be used outside of the DTD." } ;
|
||||||
|
|
||||||
HELP: system-id
|
HELP: system-id
|
||||||
{ $class-description "Describes the class of system identifiers within an XML DTD directive, such as <!DOCTYPE greeting " { $emphasis "SYSTEM 'hello.dtd'" } ">" } ;
|
{ $class-description "Describes the class of system identifiers within an XML DTD directive, such as " { $snippet "<!DOCTYPE greeting " { $emphasis "SYSTEM 'hello.dtd'" } ">" } } ;
|
||||||
|
|
||||||
HELP: <system-id>
|
HELP: <system-id>
|
||||||
{ $values { "system-literal" string } { "system-id" system-id } }
|
{ $values { "system-literal" string } { "system-id" system-id } }
|
||||||
{ $description "Constructs a " { $link system-id } " tuple." } ;
|
{ $description "Constructs a " { $link system-id } " tuple." } ;
|
||||||
|
|
||||||
HELP: public-id
|
HELP: public-id
|
||||||
{ $class-description "Describes the class of public identifiers within an XML DTD directive, such as <!DOCTYPE open-hatch " { $emphasis "PUBLIC '-//Textuality//TEXT Standard open-hatch boilerplate//EN' 'http://www.textuality.com/boilerplate/OpenHatch.xml'" } ">" } ;
|
{ $class-description "Describes the class of public identifiers within an XML DTD directive, such as " { $snippet "<!DOCTYPE open-hatch " { $emphasis "PUBLIC '-//Textuality//TEXT Standard open-hatch boilerplate//EN' 'http://www.textuality.com/boilerplate/OpenHatch.xml'" } ">" } } ;
|
||||||
|
|
||||||
HELP: <public-id>
|
HELP: <public-id>
|
||||||
{ $values { "pubid-literal" string } { "system-literal" string } { "public-id" public-id } }
|
{ $values { "pubid-literal" string } { "system-literal" string } { "public-id" public-id } }
|
||||||
{ $description "Constructs a " { $link system-id } " tuple." } ;
|
{ $description "Constructs a " { $link system-id } " tuple." } ;
|
||||||
|
|
||||||
HELP: notation-decl
|
HELP: notation-decl
|
||||||
{ $class-description "Describes the class of element declarations, like <!NOTATION jpg SYSTEM './jpgviewer'>." } ;
|
{ $class-description "Describes the class of element declarations, like " { $snippet "<!NOTATION jpg SYSTEM './jpgviewer'>" } "." } ;
|
||||||
|
|
||||||
HELP: <notation-decl>
|
HELP: <notation-decl>
|
||||||
{ $values { "name" string } { "id" id } { "notation-decl" notation-decl } }
|
{ $values { "name" string } { "id" id } { "notation-decl" notation-decl } }
|
||||||
|
|
|
@ -216,3 +216,6 @@ M: xml like
|
||||||
|
|
||||||
PREDICATE: contained-tag < tag children>> not ;
|
PREDICATE: contained-tag < tag children>> not ;
|
||||||
PREDICATE: open-tag < tag children>> ;
|
PREDICATE: open-tag < tag children>> ;
|
||||||
|
|
||||||
|
UNION: xml-data
|
||||||
|
tag comment string directive instruction ;
|
||||||
|
|
|
@ -0,0 +1,2 @@
|
||||||
|
collections
|
||||||
|
assocs
|
|
@ -0,0 +1,25 @@
|
||||||
|
! Copyright (C) 2005, 2009 Daniel Ehrenberg
|
||||||
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
|
USING: help.markup help.syntax ;
|
||||||
|
IN: xml.dispatch
|
||||||
|
|
||||||
|
ABOUT: "xml.dispatch"
|
||||||
|
|
||||||
|
ARTICLE: "xml.dispatch" "Dispatch on XML tag names"
|
||||||
|
"Two parsing words define a system, analogous to generic words, for processing XML. A word can dispatch off the name of the tag that is passed to it. To define such a word, use"
|
||||||
|
{ $subsection POSTPONE: PROCESS: }
|
||||||
|
"and to define a new 'method' for this word, use"
|
||||||
|
{ $subsection POSTPONE: TAG: } ;
|
||||||
|
|
||||||
|
HELP: PROCESS:
|
||||||
|
{ $syntax "PROCESS: word" }
|
||||||
|
{ $values { "word" "a new word to define" } }
|
||||||
|
{ $description "creates a new word to process XML tags" }
|
||||||
|
{ $see-also POSTPONE: TAG: } ;
|
||||||
|
|
||||||
|
HELP: TAG:
|
||||||
|
{ $syntax "TAG: tag word definition... ;" }
|
||||||
|
{ $values { "tag" "an xml tag name" } { "word" "an XML process" } }
|
||||||
|
{ $description "defines what a process should do when it encounters a specific tag" }
|
||||||
|
{ $examples { $code "PROCESS: x ( tag -- )\nTAG: a x drop \"hi\" write ;" } }
|
||||||
|
{ $see-also POSTPONE: PROCESS: } ;
|
|
@ -1,7 +1,8 @@
|
||||||
! Copyright (C) 2005, 2006 Daniel Ehrenberg
|
! Copyright (C) 2005, 2009 Daniel Ehrenberg
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
IN: xml.tests
|
USING: xml io kernel math sequences strings xml.utilities
|
||||||
USING: xml io kernel math sequences strings xml.utilities tools.test math.parser ;
|
tools.test math.parser xml.dispatch ;
|
||||||
|
IN: xml.dispatch.tests
|
||||||
|
|
||||||
PROCESS: calculate ( tag -- n )
|
PROCESS: calculate ( tag -- n )
|
||||||
|
|
|
@ -0,0 +1,27 @@
|
||||||
|
! Copyright (C) 2005, 2009 Daniel Ehrenberg
|
||||||
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
|
USING: words assocs kernel accessors parser sequences summary
|
||||||
|
lexer splitting fry ;
|
||||||
|
IN: xml.dispatch
|
||||||
|
|
||||||
|
TUPLE: process-missing process tag ;
|
||||||
|
M: process-missing summary
|
||||||
|
drop "Tag not implemented on process" ;
|
||||||
|
|
||||||
|
: run-process ( tag word -- )
|
||||||
|
2dup "xtable" word-prop
|
||||||
|
[ dup main>> ] dip at* [ 2nip call ] [
|
||||||
|
drop \ process-missing boa throw
|
||||||
|
] if ;
|
||||||
|
|
||||||
|
: PROCESS:
|
||||||
|
CREATE
|
||||||
|
dup H{ } clone "xtable" set-word-prop
|
||||||
|
dup '[ _ run-process ] define ; parsing
|
||||||
|
|
||||||
|
: TAG:
|
||||||
|
scan scan-word
|
||||||
|
parse-definition
|
||||||
|
swap "xtable" word-prop
|
||||||
|
rot "/" split [ [ 2dup ] dip swap set-at ] each 2drop ;
|
||||||
|
parsing
|
|
@ -0,0 +1 @@
|
||||||
|
'Generic words' that dispatch on XML tag names
|
|
@ -0,0 +1 @@
|
||||||
|
syntax
|
|
@ -3,16 +3,15 @@
|
||||||
USING: kernel namespaces xml.tokenize xml.state xml.name
|
USING: kernel namespaces xml.tokenize xml.state xml.name
|
||||||
xml.data accessors arrays make xml.char-classes fry assocs sequences
|
xml.data accessors arrays make xml.char-classes fry assocs sequences
|
||||||
math xml.errors sets combinators io.encodings io.encodings.iana
|
math xml.errors sets combinators io.encodings io.encodings.iana
|
||||||
unicode.case xml.dtd strings xml.entities ;
|
unicode.case xml.dtd strings xml.entities unicode.categories ;
|
||||||
IN: xml.elements
|
IN: xml.elements
|
||||||
|
|
||||||
: take-interpolated ( quot -- interpolated )
|
: take-interpolated ( quot -- interpolated )
|
||||||
interpolating? get [
|
interpolating? get [
|
||||||
drop get-char CHAR: > =
|
drop get-char CHAR: > =
|
||||||
[ next f ] [
|
[ next f ]
|
||||||
pass-blank " \t\r\n-" take-to
|
[ "->" take-string [ blank? ] trim ]
|
||||||
pass-blank "->" expect
|
if <interpolated>
|
||||||
] if <interpolated>
|
|
||||||
] [ call ] if ; inline
|
] [ call ] if ; inline
|
||||||
|
|
||||||
: interpolate-quote ( -- interpolated )
|
: interpolate-quote ( -- interpolated )
|
||||||
|
|
|
@ -16,6 +16,7 @@ IN: xml.entities
|
||||||
{ CHAR: & "&" }
|
{ CHAR: & "&" }
|
||||||
{ CHAR: ' "'" }
|
{ CHAR: ' "'" }
|
||||||
{ CHAR: " """ }
|
{ CHAR: " """ }
|
||||||
|
{ CHAR: < "<" }
|
||||||
} ;
|
} ;
|
||||||
|
|
||||||
: escape-string-by ( str table -- escaped )
|
: escape-string-by ( str table -- escaped )
|
||||||
|
|
|
@ -10,44 +10,68 @@ HELP: notags
|
||||||
{ $class-description "XML parsing error describing the case where an XML document contains no main tag, or any tags at all" } ;
|
{ $class-description "XML parsing error describing the case where an XML document contains no main tag, or any tags at all" } ;
|
||||||
|
|
||||||
HELP: extra-attrs
|
HELP: extra-attrs
|
||||||
{ $class-description "XML parsing error describing the case where the XML prolog (<?xml ...?>) contains attributes other than the three allowed ones, standalone, version and encoding. Contains one slot, attrs, which is a hashtable of all the extra attributes' names. Delegates to " { $link parsing-error } "." } ;
|
{ $class-description "XML parsing error describing the case where the XML prolog (" { $snippet "<?xml ...?>" } ") contains attributes other than the three allowed ones, standalone, version and encoding. Contains one slot, attrs, which is a hashtable of all the extra attributes' names. Delegates to " { $link xml-error-at } "." } ;
|
||||||
|
|
||||||
HELP: nonexist-ns
|
HELP: nonexist-ns
|
||||||
{ $class-description "XML parsing error describing the case where a namespace doesn't exist but it is used in a tag. Contains one slot, name, which contains the name of the undeclared namespace, and delegates to " { $link parsing-error } "." } ;
|
{ $class-description "XML parsing error describing the case where a namespace doesn't exist but it is used in a tag. Contains one slot, name, which contains the name of the undeclared namespace, and delegates to " { $link xml-error-at } "." } ;
|
||||||
|
|
||||||
HELP: not-yes/no
|
HELP: not-yes/no
|
||||||
{ $class-description "XML parsing error used to describe the case where standalone is set in the XML prolog to something other than 'yes' or 'no'. Delegates to " { $link parsing-error } " and contains one slot, text, which contains offending value." } ;
|
{ $class-description "XML parsing error used to describe the case where standalone is set in the XML prolog to something other than 'yes' or 'no'. Delegates to " { $link xml-error-at } " and contains one slot, text, which contains offending value." } ;
|
||||||
|
|
||||||
HELP: unclosed
|
HELP: unclosed
|
||||||
{ $class-description "XML parsing error used to describe the case where the XML document contains classes which are not closed by the end of the document. Contains one slot, tags, a sequence of names." } ;
|
{ $class-description "XML parsing error used to describe the case where the XML document contains classes which are not closed by the end of the document. Contains one slot, tags, a sequence of names." } ;
|
||||||
|
|
||||||
HELP: mismatched
|
HELP: mismatched
|
||||||
{ $class-description "XML parsing error describing mismatched tags, eg <a></c>. Contains two slots: open is the name of the opening tag and close is the name of the closing tag. Delegates to " { $link parsing-error } " showing the location of the closing tag" } ;
|
{ $class-description "XML parsing error describing mismatched tags, eg " { $snippet "<a></c>" } ". Contains two slots: open is the name of the opening tag and close is the name of the closing tag. Delegates to " { $link xml-error-at } " showing the location of the closing tag" } ;
|
||||||
|
|
||||||
HELP: expected
|
HELP: expected
|
||||||
{ $class-description "XML parsing error describing when an expected token was not present. Delegates to " { $link parsing-error } ". Contains two slots, should-be, which has the expected string, and was, which has the actual string." } ;
|
{ $class-description "XML parsing error describing when an expected token was not present. Delegates to " { $link xml-error-at } ". Contains two slots, should-be, which has the expected string, and was, which has the actual string." } ;
|
||||||
|
|
||||||
HELP: no-entity
|
HELP: no-entity
|
||||||
{ $class-description "XML parsing error describing the use of an undefined entity in a case where standalone is marked yes. Delegates to " { $link parsing-error } ". Contains one slot, thing, containing a string representing the entity." } ;
|
{ $class-description "XML parsing error describing the use of an undefined entity in a case where standalone is marked yes. Delegates to " { $link xml-error-at } ". Contains one slot, thing, containing a string representing the entity." } ;
|
||||||
|
|
||||||
|
|
||||||
HELP: pre/post-content
|
HELP: pre/post-content
|
||||||
{ $class-description "describes the error where a non-whitespace string is used before or after the main tag in an XML document. Contains two slots: string contains the offending string, and pre? is t if it occured before the main tag and f if it occured after" } ;
|
{ $class-description "Describes the error where a non-whitespace string is used before or after the main tag in an XML document. Contains two slots: string contains the offending string, and pre? is t if it occured before the main tag and f if it occured after" } ;
|
||||||
|
|
||||||
HELP: unclosed-quote
|
HELP: unclosed-quote
|
||||||
{ $class-description "describes the error where a quotation for an attribute value is opened but not closed before the end of the document." } ;
|
{ $class-description "Describes the error where a quotation for an attribute value is opened but not closed before the end of the document." } ;
|
||||||
|
|
||||||
HELP: bad-name
|
HELP: bad-name
|
||||||
{ $class-description "describes the error where a name is used, for example in an XML tag or attribute key, which is invalid." } ;
|
{ $class-description "Describes the error where a name is used, for example in an XML tag or attribute key, which is invalid." } ;
|
||||||
|
|
||||||
HELP: quoteless-attr
|
HELP: quoteless-attr
|
||||||
{ $class-description "describes the error where an attribute of an XML tag is missing quotes around a value." } ;
|
{ $class-description "Describes the error where an attribute of an XML tag is missing quotes around a value." } ;
|
||||||
|
|
||||||
HELP: xml-parse-error
|
HELP: disallowed-char
|
||||||
{ $class-description "the exception class that all parsing errors in XML documents are in." } ;
|
{ $class-description "Describes the error where a disallowed character occurs in an XML document." } ;
|
||||||
|
|
||||||
|
HELP: missing-close
|
||||||
|
{ $class-description "Describes the error where a particular closing token is missing." } ;
|
||||||
|
|
||||||
|
HELP: unexpected-end
|
||||||
|
{ $class-description "Describes the error where a document unexpectedly ends, and the XML parser expected it to continue." } ;
|
||||||
|
|
||||||
|
HELP: duplicate-attr
|
||||||
|
{ $class-description "Describes the error where there is more than one attribute of the same key." } ;
|
||||||
|
|
||||||
|
HELP: bad-cdata
|
||||||
|
{ $class-description "Describes the error where CDATA is used outside of the main tag of an XML document." } ;
|
||||||
|
|
||||||
|
HELP: text-w/]]>
|
||||||
|
{ $class-description "Describes the error where a text node contains the literal string " { $snippet "]]>" } " which is disallowed." } ;
|
||||||
|
|
||||||
|
HELP: attr-w/<
|
||||||
|
{ $class-description "Describes the error where an attribute value contains the literal character " { $snippet "<" } " which is disallowed." } ;
|
||||||
|
|
||||||
|
HELP: misplaced-directive
|
||||||
|
{ $class-description "Describes the error where an internal DTD directive is used outside of a DOCTYPE or DTD file, or where a DOCTYPE occurs somewhere other than before the main tag of an XML document." } ;
|
||||||
|
|
||||||
|
HELP: xml-error
|
||||||
|
{ $class-description "The exception class that all parsing errors in XML documents are in." } ;
|
||||||
|
|
||||||
ARTICLE: "xml.errors" "XML parsing errors"
|
ARTICLE: "xml.errors" "XML parsing errors"
|
||||||
{ $vocab-link "xml.errors" } " provides a rich and highly inspectable set of parsing errors. All XML errors are described by the union class " { $link xml-parse-error } " but there are many classes contained in that:"
|
"The " { $vocab-link "xml.errors" } " vocabulary provides a rich and highly inspectable set of parsing errors. All XML errors are described by the union class " { $link xml-error } " but there are many classes contained in that:"
|
||||||
{ $subsection multitags }
|
{ $subsection multitags }
|
||||||
{ $subsection notags }
|
{ $subsection notags }
|
||||||
{ $subsection extra-attrs }
|
{ $subsection extra-attrs }
|
||||||
|
@ -61,7 +85,15 @@ ARTICLE: "xml.errors" "XML parsing errors"
|
||||||
{ $subsection unclosed-quote }
|
{ $subsection unclosed-quote }
|
||||||
{ $subsection bad-name }
|
{ $subsection bad-name }
|
||||||
{ $subsection quoteless-attr }
|
{ $subsection quoteless-attr }
|
||||||
"Additionally, most of these errors are a kind of " { $link parsing-error } " which provides more information"
|
{ $subsection disallowed-char }
|
||||||
|
{ $subsection missing-close }
|
||||||
|
{ $subsection unexpected-end }
|
||||||
|
{ $subsection duplicate-attr }
|
||||||
|
{ $subsection bad-cdata }
|
||||||
|
{ $subsection text-w/]]> }
|
||||||
|
{ $subsection attr-w/< }
|
||||||
|
{ $subsection misplaced-directive }
|
||||||
|
"Additionally, most of these errors are a kind of " { $link xml-error-at } " which provides more information"
|
||||||
$nl
|
$nl
|
||||||
"Note that, in parsing an XML document, only the first error is reported." ;
|
"Note that, in parsing an XML document, only the first error is reported." ;
|
||||||
|
|
||||||
|
|
|
@ -27,12 +27,16 @@ T{ pre/post-content f "x" t } "x<y/>" xml-error-test
|
||||||
T{ versionless-prolog f 1 8 } "<?xml?><x/>" xml-error-test
|
T{ versionless-prolog f 1 8 } "<?xml?><x/>" xml-error-test
|
||||||
T{ unclosed-quote f 1 13 } "<x value='/>" xml-error-test
|
T{ unclosed-quote f 1 13 } "<x value='/>" xml-error-test
|
||||||
T{ bad-name f 1 3 "-" } "<-/>" xml-error-test
|
T{ bad-name f 1 3 "-" } "<-/>" xml-error-test
|
||||||
|
T{ quoteless-attr f 1 12 } "<x value=<->/>" xml-error-test
|
||||||
T{ quoteless-attr f 1 10 } "<x value=3/>" xml-error-test
|
T{ quoteless-attr f 1 10 } "<x value=3/>" xml-error-test
|
||||||
T{ attr-w/< f 1 11 } "<x value='<'/>" xml-error-test
|
T{ attr-w/< f 1 11 } "<x value='<'/>" xml-error-test
|
||||||
T{ text-w/]]> f 1 6 } "<x>]]></x>" xml-error-test
|
T{ text-w/]]> f 1 6 } "<x>]]></x>" xml-error-test
|
||||||
T{ duplicate-attr f 1 21 T{ name { space "" } { main "this" } } V{ "a" "b" } } "<x this='a' this='b'/>" xml-error-test
|
T{ duplicate-attr f 1 21 T{ name { space "" } { main "this" } } V{ "a" "b" } } "<x this='a' this='b'/>" xml-error-test
|
||||||
T{ bad-cdata f 1 3 } "<![CDATA[]]><x/>" xml-error-test
|
T{ bad-cdata f 1 3 } "<![CDATA[]]><x/>" xml-error-test
|
||||||
T{ bad-cdata f 1 7 } "<x/><![CDATA[]]>" xml-error-test
|
T{ bad-cdata f 1 7 } "<x/><![CDATA[]]>" xml-error-test
|
||||||
T{ pre/post-content f "&" t } "&32;<x/>" xml-error-test
|
T{ pre/post-content f "&" t } " <x/>" xml-error-test
|
||||||
T{ bad-doctype f 1 17 "a" } "<!DOCTYPE foo [ a ]><x/>" xml-error-test
|
T{ bad-doctype f 1 17 "a" } "<!DOCTYPE foo [ a ]><x/>" xml-error-test
|
||||||
T{ bad-doctype f 1 22 T{ opener { name T{ name f "" "foo" "" } } { attrs T{ attrs } } } } "<!DOCTYPE foo [ <foo> ]><x/>" xml-error-test
|
T{ bad-doctype f 1 22 T{ opener { name T{ name f "" "foo" "" } } { attrs T{ attrs } } } } "<!DOCTYPE foo [ <foo> ]><x/>" xml-error-test
|
||||||
|
T{ disallowed-char f 1 3 1 } "<x>\u000001</x>" xml-error-test
|
||||||
|
T{ missing-close f 1 9 } "<!-- foo" xml-error-test
|
||||||
|
T{ misplaced-directive f 1 9 "ENTITY" } "<!ENTITY foo 'bar'><x/>" xml-error-test
|
||||||
|
|
|
@ -5,22 +5,22 @@ debugger sequences xml.state accessors summary
|
||||||
namespaces io.streams.string ;
|
namespaces io.streams.string ;
|
||||||
IN: xml.errors
|
IN: xml.errors
|
||||||
|
|
||||||
TUPLE: parsing-error line column ;
|
TUPLE: xml-error-at line column ;
|
||||||
|
|
||||||
: parsing-error ( class -- obj )
|
: xml-error-at ( class -- obj )
|
||||||
new
|
new
|
||||||
get-line >>line
|
get-line >>line
|
||||||
get-column >>column ;
|
get-column >>column ;
|
||||||
M: parsing-error summary ( obj -- str )
|
M: xml-error-at summary ( obj -- str )
|
||||||
[
|
[
|
||||||
"Parsing error" print
|
"XML parsing error" print
|
||||||
"Line: " write dup line>> .
|
"Line: " write dup line>> .
|
||||||
"Column: " write column>> .
|
"Column: " write column>> .
|
||||||
] with-string-writer ;
|
] with-string-writer ;
|
||||||
|
|
||||||
TUPLE: expected < parsing-error should-be was ;
|
TUPLE: expected < xml-error-at should-be was ;
|
||||||
: expected ( should-be was -- * )
|
: expected ( should-be was -- * )
|
||||||
\ expected parsing-error
|
\ expected xml-error-at
|
||||||
swap >>was
|
swap >>was
|
||||||
swap >>should-be throw ;
|
swap >>should-be throw ;
|
||||||
M: expected summary ( obj -- str )
|
M: expected summary ( obj -- str )
|
||||||
|
@ -30,26 +30,26 @@ M: expected summary ( obj -- str )
|
||||||
"Token present: " write was>> print
|
"Token present: " write was>> print
|
||||||
] with-string-writer ;
|
] with-string-writer ;
|
||||||
|
|
||||||
TUPLE: unexpected-end < parsing-error ;
|
TUPLE: unexpected-end < xml-error-at ;
|
||||||
: unexpected-end ( -- * ) \ unexpected-end parsing-error throw ;
|
: unexpected-end ( -- * ) \ unexpected-end xml-error-at throw ;
|
||||||
M: unexpected-end summary ( obj -- str )
|
M: unexpected-end summary ( obj -- str )
|
||||||
[
|
[
|
||||||
call-next-method write
|
call-next-method write
|
||||||
"File unexpectedly ended." print
|
"File unexpectedly ended." print
|
||||||
] with-string-writer ;
|
] with-string-writer ;
|
||||||
|
|
||||||
TUPLE: missing-close < parsing-error ;
|
TUPLE: missing-close < xml-error-at ;
|
||||||
: missing-close ( -- * ) \ missing-close parsing-error throw ;
|
: missing-close ( -- * ) \ missing-close xml-error-at throw ;
|
||||||
M: missing-close summary ( obj -- str )
|
M: missing-close summary ( obj -- str )
|
||||||
[
|
[
|
||||||
call-next-method write
|
call-next-method write
|
||||||
"Missing closing token." print
|
"Missing closing token." print
|
||||||
] with-string-writer ;
|
] with-string-writer ;
|
||||||
|
|
||||||
TUPLE: disallowed-char < parsing-error char ;
|
TUPLE: disallowed-char < xml-error-at char ;
|
||||||
|
|
||||||
: disallowed-char ( char -- * )
|
: disallowed-char ( char -- * )
|
||||||
\ disallowed-char parsing-error swap >>char throw ;
|
\ disallowed-char xml-error-at swap >>char throw ;
|
||||||
|
|
||||||
M: disallowed-char summary
|
M: disallowed-char summary
|
||||||
[ call-next-method ]
|
[ call-next-method ]
|
||||||
|
@ -72,10 +72,10 @@ M: pre/post-content summary ( obj -- str )
|
||||||
" the main tag." print
|
" the main tag." print
|
||||||
] with-string-writer ;
|
] with-string-writer ;
|
||||||
|
|
||||||
TUPLE: no-entity < parsing-error thing ;
|
TUPLE: no-entity < xml-error-at thing ;
|
||||||
|
|
||||||
: no-entity ( string -- * )
|
: no-entity ( string -- * )
|
||||||
\ no-entity parsing-error swap >>thing throw ;
|
\ no-entity xml-error-at swap >>thing throw ;
|
||||||
|
|
||||||
M: no-entity summary ( obj -- str )
|
M: no-entity summary ( obj -- str )
|
||||||
[
|
[
|
||||||
|
@ -83,10 +83,10 @@ M: no-entity summary ( obj -- str )
|
||||||
"Entity does not exist: &" write thing>> write ";" print
|
"Entity does not exist: &" write thing>> write ";" print
|
||||||
] with-string-writer ;
|
] with-string-writer ;
|
||||||
|
|
||||||
TUPLE: mismatched < parsing-error open close ;
|
TUPLE: mismatched < xml-error-at open close ;
|
||||||
|
|
||||||
: mismatched ( open close -- * )
|
: mismatched ( open close -- * )
|
||||||
\ mismatched parsing-error swap >>close swap >>open throw ;
|
\ mismatched xml-error-at swap >>close swap >>open throw ;
|
||||||
|
|
||||||
M: mismatched summary ( obj -- str )
|
M: mismatched summary ( obj -- str )
|
||||||
[
|
[
|
||||||
|
@ -96,10 +96,10 @@ M: mismatched summary ( obj -- str )
|
||||||
"Closing tag: </" write close>> print-name ">" print
|
"Closing tag: </" write close>> print-name ">" print
|
||||||
] with-string-writer ;
|
] with-string-writer ;
|
||||||
|
|
||||||
TUPLE: unclosed < parsing-error tags ;
|
TUPLE: unclosed < xml-error-at tags ;
|
||||||
|
|
||||||
: unclosed ( -- * )
|
: unclosed ( -- * )
|
||||||
\ unclosed parsing-error
|
\ unclosed xml-error-at
|
||||||
xml-stack get rest-slice [ first name>> ] map >>tags
|
xml-stack get rest-slice [ first name>> ] map >>tags
|
||||||
throw ;
|
throw ;
|
||||||
|
|
||||||
|
@ -111,10 +111,10 @@ M: unclosed summary ( obj -- str )
|
||||||
tags>> [ " <" write print-name ">" print ] each
|
tags>> [ " <" write print-name ">" print ] each
|
||||||
] with-string-writer ;
|
] with-string-writer ;
|
||||||
|
|
||||||
TUPLE: bad-uri < parsing-error string ;
|
TUPLE: bad-uri < xml-error-at string ;
|
||||||
|
|
||||||
: bad-uri ( string -- * )
|
: bad-uri ( string -- * )
|
||||||
\ bad-uri parsing-error swap >>string throw ;
|
\ bad-uri xml-error-at swap >>string throw ;
|
||||||
|
|
||||||
M: bad-uri summary ( obj -- str )
|
M: bad-uri summary ( obj -- str )
|
||||||
[
|
[
|
||||||
|
@ -122,10 +122,10 @@ M: bad-uri summary ( obj -- str )
|
||||||
"Bad URI:" print string>> .
|
"Bad URI:" print string>> .
|
||||||
] with-string-writer ;
|
] with-string-writer ;
|
||||||
|
|
||||||
TUPLE: nonexist-ns < parsing-error name ;
|
TUPLE: nonexist-ns < xml-error-at name ;
|
||||||
|
|
||||||
: nonexist-ns ( name-string -- * )
|
: nonexist-ns ( name-string -- * )
|
||||||
\ nonexist-ns parsing-error swap >>name throw ;
|
\ nonexist-ns xml-error-at swap >>name throw ;
|
||||||
|
|
||||||
M: nonexist-ns summary ( obj -- str )
|
M: nonexist-ns summary ( obj -- str )
|
||||||
[
|
[
|
||||||
|
@ -133,10 +133,10 @@ M: nonexist-ns summary ( obj -- str )
|
||||||
"Namespace " write name>> write " has not been declared" print
|
"Namespace " write name>> write " has not been declared" print
|
||||||
] with-string-writer ;
|
] with-string-writer ;
|
||||||
|
|
||||||
TUPLE: unopened < parsing-error ; ! this should give which tag was unopened
|
TUPLE: unopened < xml-error-at ; ! this should give which tag was unopened
|
||||||
|
|
||||||
: unopened ( -- * )
|
: unopened ( -- * )
|
||||||
\ unopened parsing-error throw ;
|
\ unopened xml-error-at throw ;
|
||||||
|
|
||||||
M: unopened summary ( obj -- str )
|
M: unopened summary ( obj -- str )
|
||||||
[
|
[
|
||||||
|
@ -144,10 +144,10 @@ M: unopened summary ( obj -- str )
|
||||||
"Closed an unopened tag" print
|
"Closed an unopened tag" print
|
||||||
] with-string-writer ;
|
] with-string-writer ;
|
||||||
|
|
||||||
TUPLE: not-yes/no < parsing-error text ;
|
TUPLE: not-yes/no < xml-error-at text ;
|
||||||
|
|
||||||
: not-yes/no ( text -- * )
|
: not-yes/no ( text -- * )
|
||||||
\ not-yes/no parsing-error swap >>text throw ;
|
\ not-yes/no xml-error-at swap >>text throw ;
|
||||||
|
|
||||||
M: not-yes/no summary ( obj -- str )
|
M: not-yes/no summary ( obj -- str )
|
||||||
[
|
[
|
||||||
|
@ -157,10 +157,10 @@ M: not-yes/no summary ( obj -- str )
|
||||||
] with-string-writer ;
|
] with-string-writer ;
|
||||||
|
|
||||||
! this should actually print the names
|
! this should actually print the names
|
||||||
TUPLE: extra-attrs < parsing-error attrs ;
|
TUPLE: extra-attrs < xml-error-at attrs ;
|
||||||
|
|
||||||
: extra-attrs ( attrs -- * )
|
: extra-attrs ( attrs -- * )
|
||||||
\ extra-attrs parsing-error swap >>attrs throw ;
|
\ extra-attrs xml-error-at swap >>attrs throw ;
|
||||||
|
|
||||||
M: extra-attrs summary ( obj -- str )
|
M: extra-attrs summary ( obj -- str )
|
||||||
[
|
[
|
||||||
|
@ -169,10 +169,10 @@ M: extra-attrs summary ( obj -- str )
|
||||||
attrs>> .
|
attrs>> .
|
||||||
] with-string-writer ;
|
] with-string-writer ;
|
||||||
|
|
||||||
TUPLE: bad-version < parsing-error num ;
|
TUPLE: bad-version < xml-error-at num ;
|
||||||
|
|
||||||
: bad-version ( num -- * )
|
: bad-version ( num -- * )
|
||||||
\ bad-version parsing-error swap >>num throw ;
|
\ bad-version xml-error-at swap >>num throw ;
|
||||||
|
|
||||||
M: bad-version summary ( obj -- str )
|
M: bad-version summary ( obj -- str )
|
||||||
[
|
[
|
||||||
|
@ -185,10 +185,10 @@ ERROR: notags ;
|
||||||
M: notags summary ( obj -- str )
|
M: notags summary ( obj -- str )
|
||||||
drop "XML document lacks a main tag" ;
|
drop "XML document lacks a main tag" ;
|
||||||
|
|
||||||
TUPLE: bad-prolog < parsing-error prolog ;
|
TUPLE: bad-prolog < xml-error-at prolog ;
|
||||||
|
|
||||||
: bad-prolog ( prolog -- * )
|
: bad-prolog ( prolog -- * )
|
||||||
\ bad-prolog parsing-error swap >>prolog throw ;
|
\ bad-prolog xml-error-at swap >>prolog throw ;
|
||||||
|
|
||||||
M: bad-prolog summary ( obj -- str )
|
M: bad-prolog summary ( obj -- str )
|
||||||
[
|
[
|
||||||
|
@ -197,10 +197,10 @@ M: bad-prolog summary ( obj -- str )
|
||||||
prolog>> write-prolog nl
|
prolog>> write-prolog nl
|
||||||
] with-string-writer ;
|
] with-string-writer ;
|
||||||
|
|
||||||
TUPLE: capitalized-prolog < parsing-error name ;
|
TUPLE: capitalized-prolog < xml-error-at name ;
|
||||||
|
|
||||||
: capitalized-prolog ( name -- capitalized-prolog )
|
: capitalized-prolog ( name -- capitalized-prolog )
|
||||||
\ capitalized-prolog parsing-error swap >>name throw ;
|
\ capitalized-prolog xml-error-at swap >>name throw ;
|
||||||
|
|
||||||
M: capitalized-prolog summary ( obj -- str )
|
M: capitalized-prolog summary ( obj -- str )
|
||||||
[
|
[
|
||||||
|
@ -210,10 +210,10 @@ M: capitalized-prolog summary ( obj -- str )
|
||||||
" instead of <?xml...?>" print
|
" instead of <?xml...?>" print
|
||||||
] with-string-writer ;
|
] with-string-writer ;
|
||||||
|
|
||||||
TUPLE: versionless-prolog < parsing-error ;
|
TUPLE: versionless-prolog < xml-error-at ;
|
||||||
|
|
||||||
: versionless-prolog ( -- * )
|
: versionless-prolog ( -- * )
|
||||||
\ versionless-prolog parsing-error throw ;
|
\ versionless-prolog xml-error-at throw ;
|
||||||
|
|
||||||
M: versionless-prolog summary ( obj -- str )
|
M: versionless-prolog summary ( obj -- str )
|
||||||
[
|
[
|
||||||
|
@ -221,10 +221,10 @@ M: versionless-prolog summary ( obj -- str )
|
||||||
"XML prolog lacks a version declaration" print
|
"XML prolog lacks a version declaration" print
|
||||||
] with-string-writer ;
|
] with-string-writer ;
|
||||||
|
|
||||||
TUPLE: bad-directive < parsing-error dir ;
|
TUPLE: bad-directive < xml-error-at dir ;
|
||||||
|
|
||||||
: bad-directive ( directive -- * )
|
: bad-directive ( directive -- * )
|
||||||
\ bad-directive parsing-error swap >>dir throw ;
|
\ bad-directive xml-error-at swap >>dir throw ;
|
||||||
|
|
||||||
M: bad-directive summary ( obj -- str )
|
M: bad-directive summary ( obj -- str )
|
||||||
[
|
[
|
||||||
|
@ -233,26 +233,26 @@ M: bad-directive summary ( obj -- str )
|
||||||
dir>> write
|
dir>> write
|
||||||
] with-string-writer ;
|
] with-string-writer ;
|
||||||
|
|
||||||
TUPLE: bad-decl < parsing-error ;
|
TUPLE: bad-decl < xml-error-at ;
|
||||||
|
|
||||||
: bad-decl ( -- * )
|
: bad-decl ( -- * )
|
||||||
\ bad-decl parsing-error throw ;
|
\ bad-decl xml-error-at throw ;
|
||||||
|
|
||||||
M: bad-decl summary ( obj -- str )
|
M: bad-decl summary ( obj -- str )
|
||||||
call-next-method "\nExtra content in directive" append ;
|
call-next-method "\nExtra content in directive" append ;
|
||||||
|
|
||||||
TUPLE: bad-external-id < parsing-error ;
|
TUPLE: bad-external-id < xml-error-at ;
|
||||||
|
|
||||||
: bad-external-id ( -- * )
|
: bad-external-id ( -- * )
|
||||||
\ bad-external-id parsing-error throw ;
|
\ bad-external-id xml-error-at throw ;
|
||||||
|
|
||||||
M: bad-external-id summary ( obj -- str )
|
M: bad-external-id summary ( obj -- str )
|
||||||
call-next-method "\nBad external ID" append ;
|
call-next-method "\nBad external ID" append ;
|
||||||
|
|
||||||
TUPLE: misplaced-directive < parsing-error dir ;
|
TUPLE: misplaced-directive < xml-error-at dir ;
|
||||||
|
|
||||||
: misplaced-directive ( directive -- * )
|
: misplaced-directive ( directive -- * )
|
||||||
\ misplaced-directive parsing-error swap >>dir throw ;
|
\ misplaced-directive xml-error-at swap >>dir throw ;
|
||||||
|
|
||||||
M: misplaced-directive summary ( obj -- str )
|
M: misplaced-directive summary ( obj -- str )
|
||||||
[
|
[
|
||||||
|
@ -261,86 +261,82 @@ M: misplaced-directive summary ( obj -- str )
|
||||||
dir>> write-xml-chunk nl
|
dir>> write-xml-chunk nl
|
||||||
] with-string-writer ;
|
] with-string-writer ;
|
||||||
|
|
||||||
TUPLE: bad-name < parsing-error name ;
|
TUPLE: bad-name < xml-error-at name ;
|
||||||
|
|
||||||
: bad-name ( name -- * )
|
: bad-name ( name -- * )
|
||||||
\ bad-name parsing-error swap >>name throw ;
|
\ bad-name xml-error-at swap >>name throw ;
|
||||||
|
|
||||||
M: bad-name summary ( obj -- str )
|
M: bad-name summary ( obj -- str )
|
||||||
[ call-next-method ]
|
[ call-next-method ]
|
||||||
[ "Invalid name: " swap name>> "\n" 3append ]
|
[ "Invalid name: " swap name>> "\n" 3append ]
|
||||||
bi append ;
|
bi append ;
|
||||||
|
|
||||||
TUPLE: unclosed-quote < parsing-error ;
|
TUPLE: unclosed-quote < xml-error-at ;
|
||||||
|
|
||||||
: unclosed-quote ( -- * )
|
: unclosed-quote ( -- * )
|
||||||
\ unclosed-quote parsing-error throw ;
|
\ unclosed-quote xml-error-at throw ;
|
||||||
|
|
||||||
M: unclosed-quote summary
|
M: unclosed-quote summary
|
||||||
call-next-method
|
call-next-method
|
||||||
"XML document ends with quote still open\n" append ;
|
"XML document ends with quote still open\n" append ;
|
||||||
|
|
||||||
TUPLE: quoteless-attr < parsing-error ;
|
TUPLE: quoteless-attr < xml-error-at ;
|
||||||
|
|
||||||
: quoteless-attr ( -- * )
|
: quoteless-attr ( -- * )
|
||||||
\ quoteless-attr parsing-error throw ;
|
\ quoteless-attr xml-error-at throw ;
|
||||||
|
|
||||||
M: quoteless-attr summary
|
M: quoteless-attr summary
|
||||||
call-next-method "Attribute lacks quotes around value\n" append ;
|
call-next-method "Attribute lacks quotes around value\n" append ;
|
||||||
|
|
||||||
TUPLE: attr-w/< < parsing-error ;
|
TUPLE: attr-w/< < xml-error-at ;
|
||||||
|
|
||||||
: attr-w/< ( value -- * )
|
: attr-w/< ( value -- * )
|
||||||
\ attr-w/< parsing-error throw ;
|
\ attr-w/< xml-error-at throw ;
|
||||||
|
|
||||||
M: attr-w/< summary
|
M: attr-w/< summary
|
||||||
call-next-method
|
call-next-method
|
||||||
"Attribute value contains literal <" append ;
|
"Attribute value contains literal <" append ;
|
||||||
|
|
||||||
TUPLE: text-w/]]> < parsing-error ;
|
TUPLE: text-w/]]> < xml-error-at ;
|
||||||
|
|
||||||
: text-w/]]> ( text -- * )
|
: text-w/]]> ( text -- * )
|
||||||
\ text-w/]]> parsing-error throw ;
|
\ text-w/]]> xml-error-at throw ;
|
||||||
|
|
||||||
M: text-w/]]> summary
|
M: text-w/]]> summary
|
||||||
call-next-method
|
call-next-method
|
||||||
"Text node contains ']]>'" append ;
|
"Text node contains ']]>'" append ;
|
||||||
|
|
||||||
TUPLE: duplicate-attr < parsing-error key values ;
|
TUPLE: duplicate-attr < xml-error-at key values ;
|
||||||
|
|
||||||
: duplicate-attr ( key values -- * )
|
: duplicate-attr ( key values -- * )
|
||||||
\ duplicate-attr parsing-error
|
\ duplicate-attr xml-error-at
|
||||||
swap >>values swap >>key throw ;
|
swap >>values swap >>key throw ;
|
||||||
|
|
||||||
M: duplicate-attr summary
|
M: duplicate-attr summary
|
||||||
call-next-method "\nDuplicate attribute" append ;
|
call-next-method "\nDuplicate attribute" append ;
|
||||||
|
|
||||||
TUPLE: bad-cdata < parsing-error ;
|
TUPLE: bad-cdata < xml-error-at ;
|
||||||
|
|
||||||
: bad-cdata ( -- * )
|
: bad-cdata ( -- * )
|
||||||
\ bad-cdata parsing-error throw ;
|
\ bad-cdata xml-error-at throw ;
|
||||||
|
|
||||||
M: bad-cdata summary
|
M: bad-cdata summary
|
||||||
call-next-method "\nCDATA occurs before or after main tag" append ;
|
call-next-method "\nCDATA occurs before or after main tag" append ;
|
||||||
|
|
||||||
TUPLE: not-enough-characters < parsing-error ;
|
TUPLE: not-enough-characters < xml-error-at ;
|
||||||
: not-enough-characters ( -- * )
|
: not-enough-characters ( -- * )
|
||||||
\ not-enough-characters parsing-error throw ;
|
\ not-enough-characters xml-error-at throw ;
|
||||||
M: not-enough-characters summary ( obj -- str )
|
M: not-enough-characters summary ( obj -- str )
|
||||||
[
|
[
|
||||||
call-next-method write
|
call-next-method write
|
||||||
"Not enough characters" print
|
"Not enough characters" print
|
||||||
] with-string-writer ;
|
] with-string-writer ;
|
||||||
|
|
||||||
TUPLE: bad-doctype < parsing-error contents ;
|
TUPLE: bad-doctype < xml-error-at contents ;
|
||||||
: bad-doctype ( contents -- * )
|
: bad-doctype ( contents -- * )
|
||||||
\ bad-doctype parsing-error swap >>contents throw ;
|
\ bad-doctype xml-error-at swap >>contents throw ;
|
||||||
M: bad-doctype summary
|
M: bad-doctype summary
|
||||||
call-next-method "\nDTD contains invalid object" append ;
|
call-next-method "\nDTD contains invalid object" append ;
|
||||||
|
|
||||||
UNION: xml-parse-error
|
UNION: xml-error
|
||||||
multitags notags extra-attrs nonexist-ns bad-decl
|
multitags notags pre/post-content xml-error-at ;
|
||||||
not-yes/no unclosed mismatched expected no-entity
|
|
||||||
bad-prolog versionless-prolog capitalized-prolog
|
|
||||||
bad-directive bad-name unclosed-quote quoteless-attr
|
|
||||||
attr-w/< text-w/]]> duplicate-attr ;
|
|
||||||
|
|
|
@ -0,0 +1,60 @@
|
||||||
|
USING: help.markup help.syntax present multiline ;
|
||||||
|
IN: xml.interpolate
|
||||||
|
|
||||||
|
ABOUT: "xml.interpolate"
|
||||||
|
|
||||||
|
ARTICLE: "xml.interpolate" "XML literal interpolation"
|
||||||
|
"The " { $vocab-link "xml.interpolate" } " vocabulary provides a convenient syntax for generating XML documents and chunks. It defines the following parsing words:"
|
||||||
|
{ $subsection POSTPONE: <XML }
|
||||||
|
{ $subsection POSTPONE: [XML }
|
||||||
|
"For a description of the common syntax of these two, see"
|
||||||
|
{ $subsection { "xml.interpolate" "in-depth" } } ;
|
||||||
|
|
||||||
|
HELP: <XML
|
||||||
|
{ $syntax "<XML <?xml version=\"1.0\"?><document>...</document> XML>" }
|
||||||
|
{ $description "This syntax allows the interpolation of XML documents. When evaluated, there is an XML document on the stack. For more information about XML interpolation, see " { $link { "xml.interpolate" "in-depth" } } "." } ;
|
||||||
|
|
||||||
|
HELP: [XML
|
||||||
|
{ $syntax "[XML foo <x>...</x> bar <y>...</y> baz XML]" }
|
||||||
|
{ $description "This syntax allows the interpolation of XML chunks. When evaluated, there is a sequence of XML elements (tags, strings, comments, etc) on the stack. For more information about XML interpolation, see " { $link { "xml.interpolate" "in-depth" } } "." } ;
|
||||||
|
|
||||||
|
ARTICLE: { "xml.interpolate" "in-depth" } "XML interpolation syntax"
|
||||||
|
"XML interpolation has two forms for each of the words " { $link POSTPONE: <XML } " and " { $link POSTPONE: [XML } ": a fry-like form and a locals form. To splice locals in, use the syntax " { $snippet "<-variable->" } ". To splice something in from the stack, in the style of " { $vocab-link "fry" } ", use the syntax " { $snippet "<->" } ". An XML interpolation form may only use one of these styles."
|
||||||
|
$nl
|
||||||
|
"These forms can be used where a tag might go, as in " { $snippet "[XML <foo><-></foo> XML]" } " or where an attribute might go, as in " { $snippet "[XML <foo bar=<->/> XML]" } ". When an attribute is spliced in, it is not included if the value is " { $snippet "f" } " and if the value is not a string, the value is put through " { $link present } ". Here is an example of the fry style of XML interpolation:"
|
||||||
|
{ $example
|
||||||
|
{" USING: splitting sequences xml.writer xml.interpolate ;
|
||||||
|
"one two three" " " split
|
||||||
|
[ [XML <item><-></item> XML] ] map
|
||||||
|
<XML <doc><-></doc> XML> pprint-xml"}
|
||||||
|
{" <?xml version="1.0" encoding="UTF-8"?>
|
||||||
|
<doc>
|
||||||
|
<item>
|
||||||
|
one
|
||||||
|
</item>
|
||||||
|
<item>
|
||||||
|
two
|
||||||
|
</item>
|
||||||
|
<item>
|
||||||
|
three
|
||||||
|
</item>
|
||||||
|
</doc>"} }
|
||||||
|
"Here is an example of the locals version:"
|
||||||
|
{ $example
|
||||||
|
{" USING: locals urls xml.interpolate xml.writer ;
|
||||||
|
[let |
|
||||||
|
number [ 3 ]
|
||||||
|
false [ f ]
|
||||||
|
url [ URL" http://factorcode.org/" ]
|
||||||
|
string [ "hello" ]
|
||||||
|
word [ \ drop ] |
|
||||||
|
<XML
|
||||||
|
<x
|
||||||
|
number=<-number->
|
||||||
|
false=<-false->
|
||||||
|
url=<-url->
|
||||||
|
string=<-string->
|
||||||
|
word=<-word-> />
|
||||||
|
XML> pprint-xml ] "}
|
||||||
|
{" <?xml version="1.0" encoding="UTF-8"?>
|
||||||
|
<x number="3" url="http://factorcode.org/" string="hello" word="drop"/>"} } ;
|
|
@ -2,12 +2,12 @@
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: tools.test xml.interpolate multiline kernel assocs
|
USING: tools.test xml.interpolate multiline kernel assocs
|
||||||
sequences accessors xml.writer xml.interpolate.private
|
sequences accessors xml.writer xml.interpolate.private
|
||||||
locals splitting ;
|
locals splitting urls ;
|
||||||
IN: xml.interpolate.tests
|
IN: xml.interpolate.tests
|
||||||
|
|
||||||
[ "a" "c" { "a" "c" f } ] [
|
[ "a" "c" { "a" "c" f } ] [
|
||||||
"<?xml version='1.0'?><x><-a-><b val=<-c->/><-></x>"
|
"<?xml version='1.0'?><x><-a-><b val=<-c->/><-></x>"
|
||||||
interpolated-doc
|
string>doc
|
||||||
[ second var>> ]
|
[ second var>> ]
|
||||||
[ fourth "val" swap at var>> ]
|
[ fourth "val" swap at var>> ]
|
||||||
[ extract-variables ] tri
|
[ extract-variables ] tri
|
||||||
|
@ -44,3 +44,16 @@ IN: xml.interpolate.tests
|
||||||
[ [XML <item><-></item> XML] ] map
|
[ [XML <item><-></item> XML] ] map
|
||||||
<XML <doc><-></doc> XML> pprint-xml>string
|
<XML <doc><-></doc> XML> pprint-xml>string
|
||||||
] unit-test
|
] unit-test
|
||||||
|
|
||||||
|
[ {" <?xml version="1.0" encoding="UTF-8"?>
|
||||||
|
<x number="3" url="http://factorcode.org/" string="hello" word="drop"/>"} ]
|
||||||
|
[ 3 f URL" http://factorcode.org/" "hello" \ drop
|
||||||
|
<XML <x number=<-> false=<-> url=<-> string=<-> word=<->/> XML>
|
||||||
|
pprint-xml>string ] unit-test
|
||||||
|
|
||||||
|
[ "<x>3</x>" ] [ 3 [XML <x><-></x> XML] xml-chunk>string ] unit-test
|
||||||
|
[ "<x></x>" ] [ f [XML <x><-></x> XML] xml-chunk>string ] unit-test
|
||||||
|
|
||||||
|
\ parse-def must-infer
|
||||||
|
[ "" interpolate-chunk ] must-infer
|
||||||
|
[ [XML <foo><-></foo> <bar val=<->/> XML] ] must-infer
|
||||||
|
|
|
@ -2,22 +2,25 @@
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: xml xml.state kernel sequences fry assocs xml.data
|
USING: xml xml.state kernel sequences fry assocs xml.data
|
||||||
accessors strings make multiline parser namespaces macros
|
accessors strings make multiline parser namespaces macros
|
||||||
sequences.deep generalizations locals words combinators
|
sequences.deep generalizations words combinators
|
||||||
math ;
|
math present arrays ;
|
||||||
IN: xml.interpolate
|
IN: xml.interpolate
|
||||||
|
|
||||||
<PRIVATE
|
<PRIVATE
|
||||||
|
|
||||||
: interpolated-chunk ( string -- chunk )
|
: string>chunk ( string -- chunk )
|
||||||
t interpolating? [ string>xml-chunk ] with-variable ;
|
t interpolating? [ string>xml-chunk ] with-variable ;
|
||||||
|
|
||||||
: interpolated-doc ( string -- xml )
|
: string>doc ( string -- xml )
|
||||||
t interpolating? [ string>xml ] with-variable ;
|
t interpolating? [ string>xml ] with-variable ;
|
||||||
|
|
||||||
DEFER: interpolate-sequence
|
DEFER: interpolate-sequence
|
||||||
|
|
||||||
: interpolate-attrs ( table attrs -- attrs )
|
: interpolate-attrs ( table attrs -- attrs )
|
||||||
swap '[ dup interpolated? [ var>> _ at ] when ] assoc-map ;
|
swap '[
|
||||||
|
dup interpolated?
|
||||||
|
[ var>> _ at dup [ present ] when ] when
|
||||||
|
] assoc-map [ nip ] assoc-filter ;
|
||||||
|
|
||||||
: interpolate-tag ( table tag -- tag )
|
: interpolate-tag ( table tag -- tag )
|
||||||
[ nip name>> ]
|
[ nip name>> ]
|
||||||
|
@ -27,8 +30,11 @@ DEFER: interpolate-sequence
|
||||||
|
|
||||||
GENERIC: push-item ( item -- )
|
GENERIC: push-item ( item -- )
|
||||||
M: string push-item , ;
|
M: string push-item , ;
|
||||||
M: object push-item , ;
|
M: xml-data push-item , ;
|
||||||
M: sequence push-item % ;
|
M: object push-item present , ;
|
||||||
|
M: sequence push-item
|
||||||
|
[ dup array? [ % ] [ , ] if ] each ;
|
||||||
|
M: number push-item present , ;
|
||||||
|
|
||||||
GENERIC: interpolate-item ( table item -- )
|
GENERIC: interpolate-item ( table item -- )
|
||||||
M: object interpolate-item nip , ;
|
M: object interpolate-item nip , ;
|
||||||
|
@ -42,27 +48,29 @@ M: interpolated interpolate-item
|
||||||
: interpolate-xml-doc ( table xml -- xml )
|
: interpolate-xml-doc ( table xml -- xml )
|
||||||
(clone) [ interpolate-tag ] change-body ;
|
(clone) [ interpolate-tag ] change-body ;
|
||||||
|
|
||||||
GENERIC# (each-interpolated) 1 ( item quot -- ) inline
|
: (each-interpolated) ( item quot: ( interpolated -- ) -- )
|
||||||
M: interpolated (each-interpolated) call ;
|
{
|
||||||
M: tag (each-interpolated)
|
{ [ over interpolated? ] [ call ] }
|
||||||
swap attrs>> values
|
{ [ over tag? ] [
|
||||||
[ interpolated? ] filter
|
[ attrs>> values [ interpolated? ] filter ] dip each
|
||||||
swap each ;
|
] }
|
||||||
M: object (each-interpolated) 2drop ;
|
{ [ over xml? ] [ [ body>> ] dip (each-interpolated) ] }
|
||||||
|
[ 2drop ]
|
||||||
|
} cond ; inline recursive
|
||||||
|
|
||||||
: each-interpolated ( xml quot -- )
|
: each-interpolated ( xml quot -- )
|
||||||
'[ _ (each-interpolated) ] deep-each ; inline
|
'[ _ (each-interpolated) ] deep-each ; inline
|
||||||
|
|
||||||
:: number<-> ( doc -- doc )
|
: number<-> ( doc -- dup )
|
||||||
0 :> n! doc [
|
0 over [
|
||||||
dup var>> [ n >>var n 1+ n! ] unless drop
|
dup var>> [ over >>var [ 1+ ] dip ] unless drop
|
||||||
] each-interpolated doc ;
|
] each-interpolated drop ;
|
||||||
|
|
||||||
MACRO: interpolate-xml ( string -- doc )
|
MACRO: interpolate-xml ( string -- doc )
|
||||||
interpolated-doc number<-> '[ _ interpolate-xml-doc ] ;
|
string>doc number<-> '[ _ interpolate-xml-doc ] ;
|
||||||
|
|
||||||
MACRO: interpolate-chunk ( string -- chunk )
|
MACRO: interpolate-chunk ( string -- chunk )
|
||||||
interpolated-chunk number<-> '[ _ interpolate-sequence ] ;
|
string>chunk number<-> '[ _ interpolate-sequence ] ;
|
||||||
|
|
||||||
: >search-hash ( seq -- hash )
|
: >search-hash ( seq -- hash )
|
||||||
[ dup search ] H{ } map>assoc ;
|
[ dup search ] H{ } map>assoc ;
|
||||||
|
@ -70,19 +78,22 @@ MACRO: interpolate-chunk ( string -- chunk )
|
||||||
: extract-variables ( xml -- seq )
|
: extract-variables ( xml -- seq )
|
||||||
[ [ var>> , ] each-interpolated ] { } make ;
|
[ [ var>> , ] each-interpolated ] { } make ;
|
||||||
|
|
||||||
|
: nenum ( ... n -- assoc )
|
||||||
|
narray <enum> ; inline
|
||||||
|
|
||||||
: collect ( accum seq -- accum )
|
: collect ( accum seq -- accum )
|
||||||
{
|
{
|
||||||
{ [ dup [ ] all? ] [ >search-hash parsed ] } ! locals
|
{ [ dup [ ] all? ] [ >search-hash parsed ] } ! locals
|
||||||
{ [ dup [ not ] all? ] [ ! fry
|
{ [ dup [ not ] all? ] [ ! fry
|
||||||
length parsed \ narray parsed \ <enum> parsed
|
length parsed \ nenum parsed
|
||||||
] }
|
] }
|
||||||
[ drop "XML interpolation contains both fry and locals" throw ] ! mixed
|
[ drop "XML interpolation contains both fry and locals" throw ] ! mixed
|
||||||
} cond ;
|
} cond ;
|
||||||
|
|
||||||
: parse-def ( accum delimiter word -- accum )
|
: parse-def ( accum delimiter word -- accum )
|
||||||
[
|
[
|
||||||
parse-multiline-string
|
parse-multiline-string but-last
|
||||||
[ interpolated-chunk extract-variables collect ] keep
|
[ string>chunk extract-variables collect ] keep
|
||||||
parsed
|
parsed
|
||||||
] dip parsed ;
|
] dip parsed ;
|
||||||
|
|
||||||
|
|
|
@ -0,0 +1 @@
|
||||||
|
Syntax for XML interpolation
|
|
@ -0,0 +1,2 @@
|
||||||
|
syntax
|
||||||
|
enterprise
|
|
@ -1,4 +1,4 @@
|
||||||
! Copyright (C) 2005, 2006 Daniel Ehrenberg
|
! Copyright (C) 2005, 2009 Daniel Ehrenberg
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
IN: xml.tests
|
IN: xml.tests
|
||||||
USING: kernel xml tools.test io namespaces make sequences
|
USING: kernel xml tools.test io namespaces make sequences
|
||||||
|
@ -8,7 +8,7 @@ sequences.deep accessors io.streams.string ;
|
||||||
|
|
||||||
! This is insufficient
|
! This is insufficient
|
||||||
\ read-xml must-infer
|
\ read-xml must-infer
|
||||||
[ [ drop ] sax ] must-infer
|
[ [ drop ] each-element ] must-infer
|
||||||
\ string>xml must-infer
|
\ string>xml must-infer
|
||||||
|
|
||||||
SYMBOL: xml-file
|
SYMBOL: xml-file
|
||||||
|
@ -22,7 +22,7 @@ SYMBOL: xml-file
|
||||||
xml-file get T{ name f "" "this" "http://d.de" } swap at
|
xml-file get T{ name f "" "this" "http://d.de" } swap at
|
||||||
] unit-test
|
] unit-test
|
||||||
[ t ] [ xml-file get children>> second contained-tag? ] unit-test
|
[ t ] [ xml-file get children>> second contained-tag? ] unit-test
|
||||||
[ "<a></b>" string>xml ] [ xml-parse-error? ] must-fail-with
|
[ "<a></b>" string>xml ] [ xml-error? ] must-fail-with
|
||||||
[ T{ comment f "This is where the fun begins!" } ] [
|
[ T{ comment f "This is where the fun begins!" } ] [
|
||||||
xml-file get before>> [ comment? ] find nip
|
xml-file get before>> [ comment? ] find nip
|
||||||
] unit-test
|
] unit-test
|
||||||
|
|
|
@ -0,0 +1 @@
|
||||||
|
syntax
|
|
@ -6,11 +6,6 @@ IN: xml.utilities
|
||||||
ABOUT: "xml.utilities"
|
ABOUT: "xml.utilities"
|
||||||
|
|
||||||
ARTICLE: "xml.utilities" "Utilities for processing XML"
|
ARTICLE: "xml.utilities" "Utilities for processing XML"
|
||||||
"Utilities for processing XML include..."
|
|
||||||
$nl
|
|
||||||
"System sfor creating words which dispatch on XML tags:"
|
|
||||||
{ $subsection POSTPONE: PROCESS: }
|
|
||||||
{ $subsection POSTPONE: TAG: }
|
|
||||||
"Getting parts of an XML document or tag:"
|
"Getting parts of an XML document or tag:"
|
||||||
$nl
|
$nl
|
||||||
"Note: the difference between deep-tag-named and tag-named is that the former searches recursively among all children and children of children of the tag, while the latter only looks at the direct children, and is therefore more efficient."
|
"Note: the difference between deep-tag-named and tag-named is that the former searches recursively among all children and children of children of the tag, while the latter only looks at the direct children, and is therefore more efficient."
|
||||||
|
@ -19,11 +14,7 @@ ARTICLE: "xml.utilities" "Utilities for processing XML"
|
||||||
{ $subsection deep-tag-named }
|
{ $subsection deep-tag-named }
|
||||||
{ $subsection deep-tags-named }
|
{ $subsection deep-tags-named }
|
||||||
{ $subsection get-id }
|
{ $subsection get-id }
|
||||||
"Words for simplified generation of XML:"
|
"To get at the contents of a single tag, use"
|
||||||
{ $subsection build-tag* }
|
|
||||||
{ $subsection build-tag }
|
|
||||||
{ $subsection build-xml }
|
|
||||||
"Other relevant words:"
|
|
||||||
{ $subsection children>string }
|
{ $subsection children>string }
|
||||||
{ $subsection children-tags }
|
{ $subsection children-tags }
|
||||||
{ $subsection first-child-tag }
|
{ $subsection first-child-tag }
|
||||||
|
@ -31,71 +22,42 @@ ARTICLE: "xml.utilities" "Utilities for processing XML"
|
||||||
|
|
||||||
HELP: deep-tag-named
|
HELP: deep-tag-named
|
||||||
{ $values { "tag" "an XML tag or document" } { "name/string" "an XML name or string representing a name" } { "matching-tag" tag } }
|
{ $values { "tag" "an XML tag or document" } { "name/string" "an XML name or string representing a name" } { "matching-tag" tag } }
|
||||||
{ $description "finds an XML tag with a matching name, recursively searching children and children of children" }
|
{ $description "Finds an XML tag with a matching name, recursively searching children and children of children." }
|
||||||
{ $see-also tags-named tag-named deep-tags-named } ;
|
{ $see-also tags-named tag-named deep-tags-named } ;
|
||||||
|
|
||||||
HELP: deep-tags-named
|
HELP: deep-tags-named
|
||||||
{ $values { "tag" "an XML tag or document" } { "name/string" "an XML name or string representing a name" } { "tags-seq" "a sequence of tags" } }
|
{ $values { "tag" "an XML tag or document" } { "name/string" "an XML name or string representing a name" } { "tags-seq" "a sequence of tags" } }
|
||||||
{ $description "returns a sequence of all tags of a matching name, recursively searching children and children of children" }
|
{ $description "Returns a sequence of all tags of a matching name, recursively searching children and children of children." }
|
||||||
{ $see-also tag-named deep-tag-named tags-named } ;
|
{ $see-also tag-named deep-tag-named tags-named } ;
|
||||||
|
|
||||||
HELP: children>string
|
HELP: children>string
|
||||||
{ $values { "tag" "an XML tag or document" } { "string" "a string" } }
|
{ $values { "tag" "an XML tag or document" } { "string" "a string" } }
|
||||||
{ $description "concatenates the children of the tag, ignoring everything that's not a string" } ;
|
{ $description "Concatenates the children of the tag, throwing an exception when there is a non-string child." } ;
|
||||||
|
|
||||||
HELP: children-tags
|
HELP: children-tags
|
||||||
{ $values { "tag" "an XML tag or document" } { "sequence" sequence } }
|
{ $values { "tag" "an XML tag or document" } { "sequence" sequence } }
|
||||||
{ $description "gets the children of the tag that are themselves tags" }
|
{ $description "Gets the children of the tag that are themselves tags." }
|
||||||
{ $see-also first-child-tag } ;
|
{ $see-also first-child-tag } ;
|
||||||
|
|
||||||
HELP: first-child-tag
|
HELP: first-child-tag
|
||||||
{ $values { "tag" "an XML tag or document" } { "tag" tag } }
|
{ $values { "tag" "an XML tag or document" } { "tag" tag } }
|
||||||
{ $description "returns the first child of the given tag that is a tag" }
|
{ $description "Returns the first child of the given tag that is a tag." }
|
||||||
{ $see-also children-tags } ;
|
{ $see-also children-tags } ;
|
||||||
|
|
||||||
HELP: tag-named
|
HELP: tag-named
|
||||||
{ $values { "tag" "an XML tag or document" }
|
{ $values { "tag" "an XML tag or document" }
|
||||||
{ "name/string" "an XML name or string representing the name" }
|
{ "name/string" "an XML name or string representing the name" }
|
||||||
{ "matching-tag" tag } }
|
{ "matching-tag" tag } }
|
||||||
{ $description "finds the first tag with matching name which is the direct child of the given tag" }
|
{ $description "Finds the first tag with matching name which is the direct child of the given tag." }
|
||||||
{ $see-also deep-tags-named deep-tag-named tags-named } ;
|
{ $see-also deep-tags-named deep-tag-named tags-named } ;
|
||||||
|
|
||||||
HELP: tags-named
|
HELP: tags-named
|
||||||
{ $values { "tag" "an XML tag or document" }
|
{ $values { "tag" "an XML tag or document" }
|
||||||
{ "name/string" "an XML name or string representing the name" }
|
{ "name/string" "an XML name or string representing the name" }
|
||||||
{ "tags-seq" "a sequence of tags" } }
|
{ "tags-seq" "a sequence of tags" } }
|
||||||
{ $description "finds all tags with matching name that are the direct children of the given tag" }
|
{ $description "Finds all tags with matching name that are the direct children of the given tag." }
|
||||||
{ $see-also deep-tag-named deep-tags-named tag-named } ;
|
{ $see-also deep-tag-named deep-tags-named tag-named } ;
|
||||||
|
|
||||||
HELP: get-id
|
HELP: get-id
|
||||||
{ $values { "tag" "an XML tag or document" } { "id" "a string" } { "elem" "an XML element or f" } }
|
{ $values { "tag" "an XML tag or document" } { "id" "a string" } { "elem" "an XML element or f" } }
|
||||||
{ $description "finds the XML tag with the specified id, ignoring the namespace" } ;
|
{ $description "Finds the XML tag with the specified id, ignoring the namespace." } ;
|
||||||
|
|
||||||
HELP: PROCESS:
|
|
||||||
{ $syntax "PROCESS: word" }
|
|
||||||
{ $values { "word" "a new word to define" } }
|
|
||||||
{ $description "creates a new word to process XML tags" }
|
|
||||||
{ $see-also POSTPONE: TAG: } ;
|
|
||||||
|
|
||||||
HELP: TAG:
|
|
||||||
{ $syntax "TAG: tag word definition... ;" }
|
|
||||||
{ $values { "tag" "an xml tag name" } { "word" "an XML process" } }
|
|
||||||
{ $description "defines what a process should do when it encounters a specific tag" }
|
|
||||||
{ $examples { $code "PROCESS: x ( tag -- )\nTAG: a x drop \"hi\" write ;" } }
|
|
||||||
{ $see-also POSTPONE: PROCESS: } ;
|
|
||||||
|
|
||||||
HELP: build-tag*
|
|
||||||
{ $values { "items" "sequence of elements" } { "name" "string" }
|
|
||||||
{ "tag" tag } }
|
|
||||||
{ $description "builds a " { $link tag } " with the specified name, in the namespace \"\" and URL \"\" containing the children listed in item" }
|
|
||||||
{ $see-also build-tag build-xml } ;
|
|
||||||
|
|
||||||
HELP: build-tag
|
|
||||||
{ $values { "item" "an element" } { "name" string } { "tag" tag } }
|
|
||||||
{ $description "builds a " { $link tag } " with the specified name containing the single child item" }
|
|
||||||
{ $see-also build-tag* build-xml } ;
|
|
||||||
|
|
||||||
HELP: build-xml
|
|
||||||
{ $values { "tag" tag } { "xml" "an XML document" } }
|
|
||||||
{ $description "builds an XML document out of a tag" }
|
|
||||||
{ $see-also build-tag* build-tag } ;
|
|
||||||
|
|
|
@ -1,8 +1,14 @@
|
||||||
|
! Copyright (C) 2005, 2009 Daniel Ehrenberg
|
||||||
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
|
USING: xml xml.utilities tools.test xml.data ;
|
||||||
IN: xml.utilities.tests
|
IN: xml.utilities.tests
|
||||||
USING: xml xml.utilities tools.test ;
|
|
||||||
|
|
||||||
[ "bar" ] [ "<foo>bar</foo>" string>xml children>string ] unit-test
|
[ "bar" ] [ "<foo>bar</foo>" string>xml children>string ] unit-test
|
||||||
|
|
||||||
[ "" ] [ "<foo></foo>" string>xml children>string ] unit-test
|
[ "" ] [ "<foo></foo>" string>xml children>string ] unit-test
|
||||||
|
|
||||||
[ "" ] [ "<foo/>" string>xml children>string ] unit-test
|
[ "" ] [ "<foo/>" string>xml children>string ] unit-test
|
||||||
|
|
||||||
|
XML-NS: foo http://blah.com
|
||||||
|
|
||||||
|
[ T{ name { main "bling" } { url "http://blah.com" } } ] [ "bling" foo ] unit-test
|
||||||
|
|
|
@ -1,52 +1,10 @@
|
||||||
! Copyright (C) 2005, 2006 Daniel Ehrenberg
|
! Copyright (C) 2005, 2009 Daniel Ehrenberg
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: accessors kernel namespaces sequences words io assocs
|
USING: accessors kernel namespaces sequences words io assocs
|
||||||
quotations strings parser lexer arrays xml.data xml.writer debugger
|
quotations strings parser lexer arrays xml.data xml.writer debugger
|
||||||
splitting vectors sequences.deep combinators fry ;
|
splitting vectors sequences.deep combinators fry memoize ;
|
||||||
IN: xml.utilities
|
IN: xml.utilities
|
||||||
|
|
||||||
! * System for words specialized on tag names
|
|
||||||
|
|
||||||
TUPLE: process-missing process tag ;
|
|
||||||
M: process-missing error.
|
|
||||||
"Tag <" write
|
|
||||||
dup tag>> print-name
|
|
||||||
"> not implemented on process process " write
|
|
||||||
name>> print ;
|
|
||||||
|
|
||||||
: run-process ( tag word -- )
|
|
||||||
2dup "xtable" word-prop
|
|
||||||
[ dup main>> ] dip at* [ 2nip call ] [
|
|
||||||
drop \ process-missing boa throw
|
|
||||||
] if ;
|
|
||||||
|
|
||||||
: PROCESS:
|
|
||||||
CREATE
|
|
||||||
dup H{ } clone "xtable" set-word-prop
|
|
||||||
dup '[ _ run-process ] define ; parsing
|
|
||||||
|
|
||||||
: TAG:
|
|
||||||
scan scan-word
|
|
||||||
parse-definition
|
|
||||||
swap "xtable" word-prop
|
|
||||||
rot "/" split [ [ 2dup ] dip swap set-at ] each 2drop ;
|
|
||||||
parsing
|
|
||||||
|
|
||||||
|
|
||||||
! * Common utility functions
|
|
||||||
|
|
||||||
: build-tag* ( items name -- tag )
|
|
||||||
assure-name swap f swap <tag> ;
|
|
||||||
|
|
||||||
: build-tag ( item name -- tag )
|
|
||||||
[ 1array ] dip build-tag* ;
|
|
||||||
|
|
||||||
: standard-prolog ( -- prolog )
|
|
||||||
T{ prolog f "1.0" "UTF-8" f } ;
|
|
||||||
|
|
||||||
: build-xml ( tag -- xml )
|
|
||||||
standard-prolog { } rot { } <xml> ;
|
|
||||||
|
|
||||||
: children>string ( tag -- string )
|
: children>string ( tag -- string )
|
||||||
children>> {
|
children>> {
|
||||||
{ [ dup empty? ] [ drop "" ] }
|
{ [ dup empty? ] [ drop "" ] }
|
||||||
|
@ -115,3 +73,7 @@ M: process-missing error.
|
||||||
|
|
||||||
: insert-child ( child tag -- )
|
: insert-child ( child tag -- )
|
||||||
[ 1vector ] dip insert-children ;
|
[ 1vector ] dip insert-children ;
|
||||||
|
|
||||||
|
: XML-NS:
|
||||||
|
CREATE-WORD (( string -- name )) over set-stack-effect
|
||||||
|
scan '[ f swap _ <name> ] define-memoized ; parsing
|
||||||
|
|
|
@ -155,6 +155,9 @@ M: directive write-xml-chunk
|
||||||
M: instruction write-xml-chunk
|
M: instruction write-xml-chunk
|
||||||
"<?" write text>> write "?>" write ;
|
"<?" write text>> write "?>" write ;
|
||||||
|
|
||||||
|
M: number write-xml-chunk
|
||||||
|
"Numbers are not allowed in XML" throw ;
|
||||||
|
|
||||||
M: sequence write-xml-chunk
|
M: sequence write-xml-chunk
|
||||||
[ write-xml-chunk ] each ;
|
[ write-xml-chunk ] each ;
|
||||||
|
|
||||||
|
|
|
@ -1,66 +1,82 @@
|
||||||
! Copyright (C) 2005, 2009 Daniel Ehrenberg
|
! Copyright (C) 2005, 2009 Daniel Ehrenberg
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: help.markup help.syntax xml.data io ;
|
USING: help.markup help.syntax xml.data io strings ;
|
||||||
IN: xml
|
IN: xml
|
||||||
|
|
||||||
HELP: string>xml
|
HELP: string>xml
|
||||||
{ $values { "string" "a string" } { "xml" "an xml document" } }
|
{ $values { "string" string } { "xml" xml } }
|
||||||
{ $description "converts a string into an " { $link xml }
|
{ $description "Converts a string into an " { $link xml }
|
||||||
" datatype for further processing" } ;
|
" tree for further processing." } ;
|
||||||
|
|
||||||
HELP: read-xml
|
HELP: read-xml
|
||||||
{ $values { "stream" "a stream that supports readln" }
|
{ $values { "stream" "an input stream" } { "xml" xml } }
|
||||||
{ "xml" "an XML document" } }
|
{ $description "Exausts the given stream, reading an XML document from it. A binary stream, one without encoding, should be used as input, and the encoding is automatically detected." } ;
|
||||||
{ $description "exausts the given stream, reading an XML document from it. A binary stream, one without encoding, should be used as input, and the encoding is automatically detected." } ;
|
|
||||||
|
|
||||||
HELP: file>xml
|
HELP: file>xml
|
||||||
{ $values { "filename" "a string representing a filename" }
|
{ $values { "filename" string } { "xml" xml } }
|
||||||
{ "xml" "an XML document" } }
|
{ $description "Opens the given file, reads it in as XML, closes the file and returns the corresponding XML tree. The encoding is automatically detected." } ;
|
||||||
{ $description "opens the given file, reads it in as XML, closes the file and returns the corresponding XML tree" } ;
|
|
||||||
|
|
||||||
{ string>xml read-xml file>xml } related-words
|
{ string>xml read-xml file>xml } related-words
|
||||||
|
|
||||||
HELP: read-xml-chunk
|
HELP: read-xml-chunk
|
||||||
{ $values { "stream" "an input stream" } { "seq" "a sequence of elements" } }
|
{ $values { "stream" "an input stream" } { "seq" "a sequence of elements" } }
|
||||||
{ $description "rather than parse a document, as " { $link read-xml } " does, this word parses and returns a sequence of XML elements (tags, strings, etc), ie a document fragment. This is useful for pieces of XML which may have more than one main tag." }
|
{ $description "Rather than parse a document, as " { $link read-xml } " does, this word parses and returns a sequence of XML elements (tags, strings, etc), ie a document fragment. This is useful for pieces of XML which may have more than one main tag." }
|
||||||
{ $see-also read-xml } ;
|
{ $see-also read-xml } ;
|
||||||
|
|
||||||
HELP: sax
|
HELP: each-element
|
||||||
{ $values { "stream" "an input stream" } { "quot" "a quotation ( xml-elem -- )" } }
|
{ $values { "stream" "an input stream" } { "quot" "a quotation ( xml-elem -- )" } }
|
||||||
{ $description "parses the XML document, and whenever an event is encountered (a tag piece, comment, parsing instruction, directive or string element), the quotation is called with that event on the stack. The quotation has all responsibility to deal with the event properly, and it is advised that generic words be used in dispatching on the event class." }
|
{ $description "Parses the XML document, and whenever an event is encountered (a tag piece, comment, parsing instruction, directive or string element), the quotation is called with that event on the stack. The quotation has all responsibility to deal with the event properly, and it is advised that generic words be used in dispatching on the event class." }
|
||||||
{ $notes "It is important to note that this is not SAX, merely an event-based XML view" }
|
{ $notes "It is important to note that this is not SAX, merely an event-based XML view" }
|
||||||
{ $see-also read-xml } ;
|
{ $see-also read-xml } ;
|
||||||
|
|
||||||
HELP: pull-xml
|
HELP: pull-xml
|
||||||
{ $class-description "represents the state of a pull-parser for XML. Has one slot, scope, which is a namespace which contains all relevant state information." }
|
{ $class-description "Represents the state of a pull-parser for XML. Has one slot, scope, which is a namespace which contains all relevant state information." }
|
||||||
{ $see-also <pull-xml> pull-event pull-elem } ;
|
{ $see-also <pull-xml> pull-event pull-elem } ;
|
||||||
|
|
||||||
HELP: <pull-xml>
|
HELP: <pull-xml>
|
||||||
{ $values { "pull-xml" "a pull-xml tuple" } }
|
{ $values { "pull-xml" "a pull-xml tuple" } }
|
||||||
{ $description "creates an XML pull-based parser which reads from " { $link input-stream } ", executing all initial XML commands to set up the parser." }
|
{ $description "Creates an XML pull-based parser which reads from " { $link input-stream } ", executing all initial XML commands to set up the parser." }
|
||||||
{ $see-also pull-xml pull-elem pull-event } ;
|
{ $see-also pull-xml pull-elem pull-event } ;
|
||||||
|
|
||||||
HELP: pull-elem
|
HELP: pull-elem
|
||||||
{ $values { "pull" "an XML pull parser" } { "xml-elem/f" "an XML tag, string, or f" } }
|
{ $values { "pull" "an XML pull parser" } { "xml-elem/f" "an XML tag, string, or f" } }
|
||||||
{ $description "gets the next XML element from the given XML pull parser. Returns f upon exhaustion." }
|
{ $description "Gets the next XML element from the given XML pull parser. Returns f upon exhaustion." }
|
||||||
{ $see-also pull-xml <pull-xml> pull-event } ;
|
{ $see-also pull-xml <pull-xml> pull-event } ;
|
||||||
|
|
||||||
HELP: pull-event
|
HELP: pull-event
|
||||||
{ $values { "pull" "an XML pull parser" } { "xml-event/f" "an XML tag event, string, or f" } }
|
{ $values { "pull" "an XML pull parser" } { "xml-event/f" "an XML tag event, string, or f" } }
|
||||||
{ $description "gets the next XML event from the given XML pull parser. Returns f upon exhaustion." }
|
{ $description "Gets the next XML event from the given XML pull parser. Returns f upon exhaustion." }
|
||||||
{ $see-also pull-xml <pull-xml> pull-elem } ;
|
{ $see-also pull-xml <pull-xml> pull-elem } ;
|
||||||
|
|
||||||
|
HELP: read-dtd
|
||||||
|
{ $values { "stream" "an input stream" } { "dtd" dtd } }
|
||||||
|
{ $description "Exhausts a stream, producing a " { $link dtd } " from the contents." } ;
|
||||||
|
|
||||||
|
HELP: file>dtd
|
||||||
|
{ $values { "filename" string } { "dtd" dtd } }
|
||||||
|
{ $description "Reads a file in UTF-8, converting it into an XML " { $link dtd } "." } ;
|
||||||
|
|
||||||
|
HELP: string>dtd
|
||||||
|
{ $values { "string" string } { "dtd" dtd } }
|
||||||
|
{ $description "Interprets a string as an XML " { $link dtd } "." } ;
|
||||||
|
|
||||||
|
{ read-dtd file>dtd string>dtd } related-words
|
||||||
|
|
||||||
ARTICLE: { "xml" "reading" } "Reading XML"
|
ARTICLE: { "xml" "reading" } "Reading XML"
|
||||||
"The following words are used to read something into an XML document"
|
"The following words are used to read something into an XML document"
|
||||||
{ $subsection string>xml }
|
{ $subsection string>xml }
|
||||||
{ $subsection read-xml }
|
{ $subsection read-xml }
|
||||||
{ $subsection read-xml-chunk }
|
{ $subsection read-xml-chunk }
|
||||||
{ $subsection string>xml-chunk }
|
{ $subsection string>xml-chunk }
|
||||||
{ $subsection file>xml } ;
|
{ $subsection file>xml }
|
||||||
|
"To read a DTD:"
|
||||||
|
{ $subsection read-dtd }
|
||||||
|
{ $subsection file>dtd }
|
||||||
|
{ $subsection string>dtd } ;
|
||||||
|
|
||||||
ARTICLE: { "xml" "events" } "Event-based XML parsing"
|
ARTICLE: { "xml" "events" } "Event-based XML parsing"
|
||||||
"In addition to DOM-style parsing based around " { $link read-xml } ", the XML module also provides SAX-style event-based parsing. This uses much of the same data structures as normal XML, with the exception of the classes " { $link xml } " and " { $link tag } " and as such, the article " { $vocab-link "xml.data" } " may be useful in learning how to process documents in this way. Other useful words are:"
|
"In addition to DOM-style parsing based around " { $link read-xml } ", the XML module also provides SAX-style event-based parsing. This uses much of the same data structures as normal XML, with the exception of the classes " { $link xml } " and " { $link tag } " and as such, the article " { $vocab-link "xml.data" } " may be useful in learning how to process documents in this way. Other useful words are:"
|
||||||
{ $subsection sax }
|
{ $subsection each-element }
|
||||||
{ $subsection opener }
|
{ $subsection opener }
|
||||||
{ $subsection closer }
|
{ $subsection closer }
|
||||||
{ $subsection contained }
|
{ $subsection contained }
|
||||||
|
@ -74,10 +90,11 @@ ARTICLE: "xml" "XML parser"
|
||||||
"The " { $vocab-link "xml" } " vocabulary implements the XML 1.0 and 1.1 standards, converting strings of text into XML and vice versa."
|
"The " { $vocab-link "xml" } " vocabulary implements the XML 1.0 and 1.1 standards, converting strings of text into XML and vice versa."
|
||||||
{ $subsection { "xml" "reading" } }
|
{ $subsection { "xml" "reading" } }
|
||||||
{ $subsection { "xml" "events" } }
|
{ $subsection { "xml" "events" } }
|
||||||
{ $vocab-subsection "Utilities for processing XML" "xml.utilities" }
|
|
||||||
{ $vocab-subsection "Writing XML" "xml.writer" }
|
{ $vocab-subsection "Writing XML" "xml.writer" }
|
||||||
{ $vocab-subsection "XML parsing errors" "xml.errors" }
|
{ $vocab-subsection "XML parsing errors" "xml.errors" }
|
||||||
{ $vocab-subsection "XML entities" "xml.entities" }
|
{ $vocab-subsection "XML entities" "xml.entities" }
|
||||||
{ $vocab-subsection "XML data types" "xml.data" } ;
|
{ $vocab-subsection "XML data types" "xml.data" }
|
||||||
|
{ $vocab-subsection "Utilities for processing XML" "xml.utilities" }
|
||||||
|
{ $vocab-subsection "Dispatch on XML tag names" "xml.dispatch" } ;
|
||||||
|
|
||||||
ABOUT: "xml"
|
ABOUT: "xml"
|
||||||
|
|
|
@ -6,7 +6,7 @@ xml.data xml.errors xml.elements ascii xml.entities
|
||||||
xml.writer xml.state xml.autoencoding assocs xml.tokenize xml.name ;
|
xml.writer xml.state xml.autoencoding assocs xml.tokenize xml.name ;
|
||||||
IN: xml
|
IN: xml
|
||||||
|
|
||||||
! -- Overall parser with data tree
|
<PRIVATE
|
||||||
|
|
||||||
: add-child ( object -- )
|
: add-child ( object -- )
|
||||||
xml-stack get peek second push ;
|
xml-stack get peek second push ;
|
||||||
|
@ -89,6 +89,8 @@ M: closer process
|
||||||
|
|
||||||
SYMBOL: text-now?
|
SYMBOL: text-now?
|
||||||
|
|
||||||
|
PRIVATE>
|
||||||
|
|
||||||
TUPLE: pull-xml scope ;
|
TUPLE: pull-xml scope ;
|
||||||
: <pull-xml> ( -- pull-xml )
|
: <pull-xml> ( -- pull-xml )
|
||||||
[
|
[
|
||||||
|
@ -106,6 +108,8 @@ TUPLE: pull-xml scope ;
|
||||||
] if text-now? set
|
] if text-now? set
|
||||||
] bind ;
|
] bind ;
|
||||||
|
|
||||||
|
<PRIVATE
|
||||||
|
|
||||||
: done? ( -- ? )
|
: done? ( -- ? )
|
||||||
xml-stack get length 1 = ;
|
xml-stack get length 1 = ;
|
||||||
|
|
||||||
|
@ -116,27 +120,33 @@ TUPLE: pull-xml scope ;
|
||||||
[ (pull-elem) ] if
|
[ (pull-elem) ] if
|
||||||
] if ;
|
] if ;
|
||||||
|
|
||||||
|
PRIVATE>
|
||||||
|
|
||||||
: pull-elem ( pull -- xml-elem/f )
|
: pull-elem ( pull -- xml-elem/f )
|
||||||
[ init-xml-stack (pull-elem) ] with-scope ;
|
[ init-xml-stack (pull-elem) ] with-scope ;
|
||||||
|
|
||||||
|
<PRIVATE
|
||||||
|
|
||||||
: call-under ( quot object -- quot )
|
: call-under ( quot object -- quot )
|
||||||
swap dup slip ; inline
|
swap dup slip ; inline
|
||||||
|
|
||||||
: sax-loop ( quot: ( xml-elem -- ) -- )
|
: xml-loop ( quot: ( xml-elem -- ) -- )
|
||||||
parse-text call-under
|
parse-text call-under
|
||||||
get-char [ make-tag call-under sax-loop ]
|
get-char [ make-tag call-under xml-loop ]
|
||||||
[ drop ] if ; inline recursive
|
[ drop ] if ; inline recursive
|
||||||
|
|
||||||
: sax ( stream quot: ( xml-elem -- ) -- )
|
PRIVATE>
|
||||||
|
|
||||||
|
: each-element ( stream quot: ( xml-elem -- ) -- )
|
||||||
swap [
|
swap [
|
||||||
reset-prolog init-ns-stack
|
reset-prolog init-ns-stack
|
||||||
start-document [ call-under ] when*
|
start-document [ call-under ] when*
|
||||||
sax-loop
|
xml-loop
|
||||||
] with-state ; inline recursive
|
] with-state ; inline
|
||||||
|
|
||||||
: (read-xml) ( -- )
|
: (read-xml) ( -- )
|
||||||
start-document [ process ] when*
|
start-document [ process ] when*
|
||||||
[ process ] sax-loop ; inline
|
[ process ] xml-loop ; inline
|
||||||
|
|
||||||
: (read-xml-chunk) ( stream -- prolog seq )
|
: (read-xml-chunk) ( stream -- prolog seq )
|
||||||
[
|
[
|
||||||
|
@ -155,7 +165,8 @@ TUPLE: pull-xml scope ;
|
||||||
[ (read-xml-chunk) nip ] with-variable ;
|
[ (read-xml-chunk) nip ] with-variable ;
|
||||||
|
|
||||||
: string>xml ( string -- xml )
|
: string>xml ( string -- xml )
|
||||||
<string-reader> read-xml ;
|
t string-input?
|
||||||
|
[ <string-reader> read-xml ] with-variable ;
|
||||||
|
|
||||||
: string>xml-chunk ( string -- xml )
|
: string>xml-chunk ( string -- xml )
|
||||||
t string-input?
|
t string-input?
|
||||||
|
|
|
@ -1,48 +1,45 @@
|
||||||
USING: xmode.tokens xmode.marker xmode.catalog kernel
|
USING: xmode.tokens xmode.marker xmode.catalog kernel locals
|
||||||
html.elements io io.files sequences words io.encodings.utf8
|
html.elements io io.files sequences words io.encodings.utf8
|
||||||
namespaces xml.entities accessors ;
|
namespaces xml.entities accessors xml.interpolate locals xml.writer ;
|
||||||
IN: xmode.code2html
|
IN: xmode.code2html
|
||||||
|
|
||||||
: htmlize-tokens ( tokens -- )
|
: htmlize-tokens ( tokens -- xml )
|
||||||
[
|
[
|
||||||
[ str>> ] [ id>> ] bi [
|
[ str>> ] [ id>> ] bi [
|
||||||
<span name>> =class span> escape-string write </span>
|
name>> swap
|
||||||
] [
|
[XML <span class=<->><-></span> XML]
|
||||||
escape-string write
|
] [ ] if*
|
||||||
] if*
|
] map ;
|
||||||
] each ;
|
|
||||||
|
|
||||||
: htmlize-line ( line-context line rules -- line-context' )
|
: htmlize-line ( line-context line rules -- line-context' xml )
|
||||||
tokenize-line htmlize-tokens ;
|
tokenize-line htmlize-tokens ;
|
||||||
|
|
||||||
: htmlize-lines ( lines mode -- )
|
: htmlize-lines ( lines mode -- xml )
|
||||||
f swap load-mode [ htmlize-line nl ] curry reduce drop ;
|
f -rot load-mode [ htmlize-line ] curry map nip ;
|
||||||
|
|
||||||
: default-stylesheet ( -- )
|
: default-stylesheet ( -- xml )
|
||||||
<style>
|
"resource:basis/xmode/code2html/stylesheet.css"
|
||||||
"resource:basis/xmode/code2html/stylesheet.css"
|
utf8 file-contents
|
||||||
utf8 file-contents escape-string write
|
[XML <style><-></style> XML] ;
|
||||||
</style> ;
|
|
||||||
|
|
||||||
: htmlize-stream ( path stream -- )
|
:: htmlize-stream ( path stream -- xml )
|
||||||
lines swap
|
stream lines
|
||||||
<html>
|
[ "" ] [ first find-mode path swap htmlize-lines ]
|
||||||
|
if-empty :> input
|
||||||
|
default-stylesheet :> stylesheet
|
||||||
|
<XML <html>
|
||||||
<head>
|
<head>
|
||||||
default-stylesheet
|
<-stylesheet->
|
||||||
<title> dup escape-string write </title>
|
<title><-path-></title>
|
||||||
</head>
|
</head>
|
||||||
<body>
|
<body>
|
||||||
<pre>
|
<pre><-input-></pre>
|
||||||
over empty?
|
|
||||||
[ 2drop ]
|
|
||||||
[ over first find-mode htmlize-lines ] if
|
|
||||||
</pre>
|
|
||||||
</body>
|
</body>
|
||||||
</html> ;
|
</html> XML> ;
|
||||||
|
|
||||||
: htmlize-file ( path -- )
|
: htmlize-file ( path -- )
|
||||||
dup utf8 [
|
dup utf8 [
|
||||||
dup ".html" append utf8 [
|
dup ".html" append utf8 [
|
||||||
input-stream get htmlize-stream
|
input-stream get htmlize-stream write-xml
|
||||||
] with-file-writer
|
] with-file-writer
|
||||||
] with-file-reader ;
|
] with-file-reader ;
|
||||||
|
|
|
@ -1,7 +1,7 @@
|
||||||
! Copyright (C) 2007 Daniel Ehrenberg, Slava Pestov, and Doug Coleman
|
! Copyright (C) 2007, 2009 Daniel Ehrenberg, Slava Pestov, and Doug Coleman
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: help.markup help.syntax kernel sequences
|
USING: help.markup help.syntax kernel sequences
|
||||||
sequences.private namespaces math quotations ;
|
sequences.private namespaces math quotations assocs.private ;
|
||||||
IN: assocs
|
IN: assocs
|
||||||
|
|
||||||
ARTICLE: "alists" "Association lists"
|
ARTICLE: "alists" "Association lists"
|
||||||
|
@ -21,7 +21,7 @@ ARTICLE: "enums" "Enumerations"
|
||||||
{ $subsection enum }
|
{ $subsection enum }
|
||||||
{ $subsection <enum> }
|
{ $subsection <enum> }
|
||||||
"Inverting a permutation using enumerations:"
|
"Inverting a permutation using enumerations:"
|
||||||
{ $example "USING: assocs sorting prettyprint ;" ": invert <enum> >alist sort-values keys ;" "{ 2 0 4 1 3 } invert ." "{ 1 3 0 4 2 }" } ;
|
{ $example "USING: assocs sorting prettyprint ;" "IN: scratchpad" ": invert ( perm -- perm' )" " <enum> >alist sort-values keys ;" "{ 2 0 4 1 3 } invert ." "{ 1 3 0 4 2 }" } ;
|
||||||
|
|
||||||
HELP: enum
|
HELP: enum
|
||||||
{ $class-description "An associative structure which wraps a sequence and maps integers to the corresponding elements of the sequence."
|
{ $class-description "An associative structure which wraps a sequence and maps integers to the corresponding elements of the sequence."
|
||||||
|
@ -113,7 +113,6 @@ $nl
|
||||||
{ $subsection assoc-each }
|
{ $subsection assoc-each }
|
||||||
{ $subsection assoc-find }
|
{ $subsection assoc-find }
|
||||||
{ $subsection assoc-map }
|
{ $subsection assoc-map }
|
||||||
{ $subsection assoc-push-if }
|
|
||||||
{ $subsection assoc-filter }
|
{ $subsection assoc-filter }
|
||||||
{ $subsection assoc-filter-as }
|
{ $subsection assoc-filter-as }
|
||||||
{ $subsection assoc-contains? }
|
{ $subsection assoc-contains? }
|
||||||
|
@ -122,10 +121,7 @@ $nl
|
||||||
{ $subsection cache }
|
{ $subsection cache }
|
||||||
{ $subsection map>assoc }
|
{ $subsection map>assoc }
|
||||||
{ $subsection assoc>map }
|
{ $subsection assoc>map }
|
||||||
{ $subsection assoc-map-as }
|
{ $subsection assoc-map-as } ;
|
||||||
{ $subsection search-alist }
|
|
||||||
"Utility word:"
|
|
||||||
{ $subsection assoc-pusher } ;
|
|
||||||
|
|
||||||
ARTICLE: "assocs" "Associative mapping operations"
|
ARTICLE: "assocs" "Associative mapping operations"
|
||||||
"An " { $emphasis "associative mapping" } ", abbreviated " { $emphasis "assoc" } ", is a collection of key/value pairs which provides efficient lookup and storage indexed by key."
|
"An " { $emphasis "associative mapping" } ", abbreviated " { $emphasis "assoc" } ", is a collection of key/value pairs which provides efficient lookup and storage indexed by key."
|
||||||
|
@ -225,10 +221,6 @@ HELP: assoc-map
|
||||||
|
|
||||||
{ assoc-map assoc-map-as } related-words
|
{ assoc-map assoc-map-as } related-words
|
||||||
|
|
||||||
HELP: assoc-push-if
|
|
||||||
{ $values { "accum" "a resizable mutable sequence" } { "quot" { $quotation "( key value -- ? )" } } { "key" object } { "value" object } }
|
|
||||||
{ $description "If the quotation yields true when applied to the key/value pair, adds the key/value pair at the end of " { $snippet "accum" } "." } ;
|
|
||||||
|
|
||||||
HELP: assoc-filter
|
HELP: assoc-filter
|
||||||
{ $values { "assoc" assoc } { "quot" { $quotation "( key value -- ? )" } } { "subassoc" "a new assoc" } }
|
{ $values { "assoc" assoc } { "quot" { $quotation "( key value -- ? )" } } { "subassoc" "a new assoc" } }
|
||||||
{ $description "Outputs an assoc of the same type as " { $snippet "assoc" } " consisting of all entries for which the predicate quotation yields true." } ;
|
{ $description "Outputs an assoc of the same type as " { $snippet "assoc" } " consisting of all entries for which the predicate quotation yields true." } ;
|
||||||
|
@ -388,18 +380,6 @@ HELP: assoc-map-as
|
||||||
{ $description "Applies the quotation to each entry in the input assoc and collects the results in a new assoc of the stame type as the exemplar." }
|
{ $description "Applies the quotation to each entry in the input assoc and collects the results in a new assoc of the stame type as the exemplar." }
|
||||||
{ $examples { $example "USING: prettyprint assocs hashtables math ;" " H{ { 1 2 } { 3 4 } } [ sq ] { } assoc-map-as ." "{ { 1 4 } { 3 16 } }" } } ;
|
{ $examples { $example "USING: prettyprint assocs hashtables math ;" " H{ { 1 2 } { 3 4 } } [ sq ] { } assoc-map-as ." "{ { 1 4 } { 3 16 } }" } } ;
|
||||||
|
|
||||||
HELP: assoc-pusher
|
|
||||||
{ $values
|
|
||||||
{ "quot" "a predicate quotation" }
|
|
||||||
{ "quot'" quotation } { "accum" assoc } }
|
|
||||||
{ $description "Creates a new " { $snippet "assoc" } " to accumulate the key/value pairs which return true for a predicate. Returns a new quotation which accepts a pair of object to be tested and stored in the accumulator if the test yields true. The accumulator is left on the stack for convenience." }
|
|
||||||
{ $example "! Find only the pairs that sum to 5:" "USING: prettyprint assocs math kernel ;"
|
|
||||||
"{ { 1 2 } { 2 3 } { 3 4 } } [ + 5 = ] assoc-pusher [ assoc-each ] dip ."
|
|
||||||
"V{ { 2 3 } }"
|
|
||||||
}
|
|
||||||
{ $notes "Used to implement the " { $link assoc-filter } " word." } ;
|
|
||||||
|
|
||||||
|
|
||||||
HELP: extract-keys
|
HELP: extract-keys
|
||||||
{ $values
|
{ $values
|
||||||
{ "seq" sequence } { "assoc" assoc }
|
{ "seq" sequence } { "assoc" assoc }
|
||||||
|
@ -425,11 +405,12 @@ HELP: search-alist
|
||||||
{ $values
|
{ $values
|
||||||
{ "key" object } { "alist" "an array of key/value pairs" }
|
{ "key" object } { "alist" "an array of key/value pairs" }
|
||||||
{ "pair/f" "a key/value pair" } { "i/f" integer } }
|
{ "pair/f" "a key/value pair" } { "i/f" integer } }
|
||||||
{ $description "Performs an in-order traversal of a " { $snippet "alist" } " and stops when the key is matched or the end of the " { $snippet "alist" } " has been reached. If there is no match, both outputs are " { $link f } "." }
|
{ $description "Iterates over " { $snippet "alist" } " and stops when the key is matched or the end of the " { $snippet "alist" } " has been reached. If there is no match, both outputs are " { $link f } "." }
|
||||||
{ $examples { $example "USING: prettyprint assocs kernel ;"
|
{ $notes "This word is used to implement " { $link at* } " and " { $link set-at } " on sequences, and should not be called direclty." }
|
||||||
|
{ $examples { $example "USING: prettyprint assocs.private kernel ;"
|
||||||
"3 { { 1 2 } { 3 4 } } search-alist [ . ] bi@"
|
"3 { { 1 2 } { 3 4 } } search-alist [ . ] bi@"
|
||||||
"{ 3 4 }\n1"
|
"{ 3 4 }\n1"
|
||||||
} { $example "USING: prettyprint assocs kernel ;"
|
} { $example "USING: prettyprint assocs.private kernel ;"
|
||||||
"6 { { 1 2 } { 3 4 } } search-alist [ . ] bi@"
|
"6 { { 1 2 } { 3 4 } } search-alist [ . ] bi@"
|
||||||
"f\nf"
|
"f\nf"
|
||||||
}
|
}
|
||||||
|
|
|
@ -129,4 +129,13 @@ unit-test
|
||||||
|
|
||||||
[ "x" ] [
|
[ "x" ] [
|
||||||
"a" H{ { "a" "x" } } at-default
|
"a" H{ { "a" "x" } } at-default
|
||||||
|
] unit-test
|
||||||
|
|
||||||
|
[ H{ { "b" [ 2 ] } { "d" [ 4 ] } } H{ { "a" [ 1 ] } { "c" [ 3 ] } } ] [
|
||||||
|
H{
|
||||||
|
{ "a" [ 1 ] }
|
||||||
|
{ "b" [ 2 ] }
|
||||||
|
{ "c" [ 3 ] }
|
||||||
|
{ "d" [ 4 ] }
|
||||||
|
} [ nip first even? ] assoc-partition
|
||||||
] unit-test
|
] unit-test
|
|
@ -7,22 +7,42 @@ IN: assocs
|
||||||
MIXIN: assoc
|
MIXIN: assoc
|
||||||
|
|
||||||
GENERIC: at* ( key assoc -- value/f ? )
|
GENERIC: at* ( key assoc -- value/f ? )
|
||||||
|
GENERIC: value-at* ( value assoc -- key/f ? )
|
||||||
GENERIC: set-at ( value key assoc -- )
|
GENERIC: set-at ( value key assoc -- )
|
||||||
GENERIC: new-assoc ( capacity exemplar -- newassoc )
|
GENERIC: new-assoc ( capacity exemplar -- newassoc )
|
||||||
GENERIC: delete-at ( key assoc -- )
|
GENERIC: delete-at ( key assoc -- )
|
||||||
GENERIC: clear-assoc ( assoc -- )
|
GENERIC: clear-assoc ( assoc -- )
|
||||||
GENERIC: assoc-size ( assoc -- n )
|
GENERIC: assoc-size ( assoc -- n )
|
||||||
GENERIC: assoc-like ( assoc exemplar -- newassoc )
|
GENERIC: assoc-like ( assoc exemplar -- newassoc )
|
||||||
|
GENERIC: assoc-clone-like ( assoc exemplar -- newassoc )
|
||||||
|
GENERIC: >alist ( assoc -- newassoc )
|
||||||
|
|
||||||
M: assoc assoc-like drop ;
|
M: assoc assoc-like drop ;
|
||||||
|
|
||||||
GENERIC: assoc-clone-like ( assoc exemplar -- newassoc )
|
<PRIVATE
|
||||||
|
|
||||||
GENERIC: >alist ( assoc -- newassoc )
|
|
||||||
|
|
||||||
: (assoc-each) ( assoc quot -- seq quot' )
|
: (assoc-each) ( assoc quot -- seq quot' )
|
||||||
[ >alist ] dip [ first2 ] prepose ; inline
|
[ >alist ] dip [ first2 ] prepose ; inline
|
||||||
|
|
||||||
|
: (assoc-stack) ( key i seq -- value )
|
||||||
|
over 0 < [
|
||||||
|
3drop f
|
||||||
|
] [
|
||||||
|
3dup nth-unsafe at*
|
||||||
|
[ [ 3drop ] dip ] [ drop [ 1- ] dip (assoc-stack) ] if
|
||||||
|
] if ; inline recursive
|
||||||
|
|
||||||
|
: search-alist ( key alist -- pair/f i/f )
|
||||||
|
[ first = ] with find swap ; inline
|
||||||
|
|
||||||
|
: substituter ( assoc -- quot )
|
||||||
|
[ dupd at* [ nip ] [ drop ] if ] curry ; inline
|
||||||
|
|
||||||
|
: with-assoc ( assoc quot: ( value key -- assoc ) -- quot: ( key value -- ) )
|
||||||
|
curry [ swap ] prepose ; inline
|
||||||
|
|
||||||
|
PRIVATE>
|
||||||
|
|
||||||
: assoc-find ( assoc quot -- key value ? )
|
: assoc-find ( assoc quot -- key value ? )
|
||||||
(assoc-each) find swap [ first2 t ] [ drop f f f ] if ; inline
|
(assoc-each) find swap [ first2 t ] [ drop f f f ] if ; inline
|
||||||
|
|
||||||
|
@ -40,18 +60,16 @@ GENERIC: >alist ( assoc -- newassoc )
|
||||||
: assoc-map ( assoc quot -- newassoc )
|
: assoc-map ( assoc quot -- newassoc )
|
||||||
over assoc-map-as ; inline
|
over assoc-map-as ; inline
|
||||||
|
|
||||||
: assoc-push-if ( key value quot accum -- )
|
|
||||||
[ 2keep ] dip [ [ 2array ] dip push ] 3curry when ; inline
|
|
||||||
|
|
||||||
: assoc-pusher ( quot -- quot' accum )
|
|
||||||
V{ } clone [ [ assoc-push-if ] 2curry ] keep ; inline
|
|
||||||
|
|
||||||
: assoc-filter-as ( assoc quot exemplar -- subassoc )
|
: assoc-filter-as ( assoc quot exemplar -- subassoc )
|
||||||
[ assoc-pusher [ assoc-each ] dip ] dip assoc-like ; inline
|
[ (assoc-each) filter ] dip assoc-like ; inline
|
||||||
|
|
||||||
: assoc-filter ( assoc quot -- subassoc )
|
: assoc-filter ( assoc quot -- subassoc )
|
||||||
over assoc-filter-as ; inline
|
over assoc-filter-as ; inline
|
||||||
|
|
||||||
|
: assoc-partition ( assoc quot -- true-assoc false-assoc )
|
||||||
|
[ (assoc-each) partition ] [ drop ] 2bi
|
||||||
|
tuck [ assoc-like ] 2bi@ ; inline
|
||||||
|
|
||||||
: assoc-contains? ( assoc quot -- ? )
|
: assoc-contains? ( assoc quot -- ? )
|
||||||
assoc-find 2nip ; inline
|
assoc-find 2nip ; inline
|
||||||
|
|
||||||
|
@ -65,8 +83,8 @@ GENERIC: >alist ( assoc -- newassoc )
|
||||||
2dup at* [ 2nip ] [ 2drop ] if ; inline
|
2dup at* [ 2nip ] [ 2drop ] if ; inline
|
||||||
|
|
||||||
M: assoc assoc-clone-like ( assoc exemplar -- newassoc )
|
M: assoc assoc-clone-like ( assoc exemplar -- newassoc )
|
||||||
over assoc-size swap new-assoc
|
[ dup assoc-size ] dip new-assoc
|
||||||
[ [ swapd set-at ] curry assoc-each ] keep ;
|
[ [ set-at ] with-assoc assoc-each ] keep ;
|
||||||
|
|
||||||
: keys ( assoc -- keys )
|
: keys ( assoc -- keys )
|
||||||
[ drop ] { } assoc>map ;
|
[ drop ] { } assoc>map ;
|
||||||
|
@ -78,38 +96,28 @@ M: assoc assoc-clone-like ( assoc exemplar -- newassoc )
|
||||||
[ at* ] 2keep delete-at ;
|
[ at* ] 2keep delete-at ;
|
||||||
|
|
||||||
: rename-at ( newkey key assoc -- )
|
: rename-at ( newkey key assoc -- )
|
||||||
[ delete-at* ] keep [ swapd set-at ] curry [ 2drop ] if ;
|
[ delete-at* ] keep [ set-at ] with-assoc [ 2drop ] if ;
|
||||||
|
|
||||||
: assoc-empty? ( assoc -- ? )
|
: assoc-empty? ( assoc -- ? )
|
||||||
assoc-size zero? ;
|
assoc-size 0 = ;
|
||||||
|
|
||||||
: (assoc-stack) ( key i seq -- value )
|
|
||||||
over 0 < [
|
|
||||||
3drop f
|
|
||||||
] [
|
|
||||||
3dup nth-unsafe at*
|
|
||||||
[ [ 3drop ] dip ] [ drop [ 1- ] dip (assoc-stack) ] if
|
|
||||||
] if ; inline recursive
|
|
||||||
|
|
||||||
: assoc-stack ( key seq -- value )
|
: assoc-stack ( key seq -- value )
|
||||||
[ length 1- ] keep (assoc-stack) ; flushable
|
[ length 1- ] keep (assoc-stack) ; flushable
|
||||||
|
|
||||||
: assoc-subset? ( assoc1 assoc2 -- ? )
|
: assoc-subset? ( assoc1 assoc2 -- ? )
|
||||||
[ swapd at* [ = ] [ 2drop f ] if ] curry assoc-all? ;
|
[ at* [ = ] [ 2drop f ] if ] with-assoc assoc-all? ;
|
||||||
|
|
||||||
: assoc= ( assoc1 assoc2 -- ? )
|
: assoc= ( assoc1 assoc2 -- ? )
|
||||||
[ assoc-subset? ] [ swap assoc-subset? ] 2bi and ;
|
[ assoc-subset? ] [ swap assoc-subset? ] 2bi and ;
|
||||||
|
|
||||||
: assoc-hashcode ( n assoc -- code )
|
: assoc-hashcode ( n assoc -- code )
|
||||||
[
|
>alist hashcode* ;
|
||||||
[ over ] dip hashcode* 2/ [ dupd hashcode* ] dip bitxor
|
|
||||||
] { } assoc>map hashcode* ;
|
|
||||||
|
|
||||||
: assoc-intersect ( assoc1 assoc2 -- intersection )
|
: assoc-intersect ( assoc1 assoc2 -- intersection )
|
||||||
swap [ nip key? ] curry assoc-filter ;
|
swap [ nip key? ] curry assoc-filter ;
|
||||||
|
|
||||||
: update ( assoc1 assoc2 -- )
|
: update ( assoc1 assoc2 -- )
|
||||||
swap [ swapd set-at ] curry assoc-each ;
|
swap [ set-at ] with-assoc assoc-each ;
|
||||||
|
|
||||||
: assoc-union ( assoc1 assoc2 -- union )
|
: assoc-union ( assoc1 assoc2 -- union )
|
||||||
[ [ [ assoc-size ] bi@ + ] [ drop ] 2bi new-assoc ] 2keep
|
[ [ [ assoc-size ] bi@ + ] [ drop ] 2bi new-assoc ] 2keep
|
||||||
|
@ -124,9 +132,6 @@ M: assoc assoc-clone-like ( assoc exemplar -- newassoc )
|
||||||
: remove-all ( assoc seq -- subseq )
|
: remove-all ( assoc seq -- subseq )
|
||||||
swap [ key? not ] curry filter ;
|
swap [ key? not ] curry filter ;
|
||||||
|
|
||||||
: substituter ( assoc -- quot )
|
|
||||||
[ dupd at* [ nip ] [ drop ] if ] curry ; inline
|
|
||||||
|
|
||||||
: substitute-here ( seq assoc -- )
|
: substitute-here ( seq assoc -- )
|
||||||
substituter change-each ;
|
substituter change-each ;
|
||||||
|
|
||||||
|
@ -155,8 +160,6 @@ M: assoc assoc-clone-like ( assoc exemplar -- newassoc )
|
||||||
: extract-keys ( seq assoc -- subassoc )
|
: extract-keys ( seq assoc -- subassoc )
|
||||||
[ [ dupd at ] curry ] keep map>assoc ;
|
[ [ dupd at ] curry ] keep map>assoc ;
|
||||||
|
|
||||||
GENERIC: value-at* ( value assoc -- key/f ? )
|
|
||||||
|
|
||||||
M: assoc value-at* swap [ = nip ] curry assoc-find nip ;
|
M: assoc value-at* swap [ = nip ] curry assoc-find nip ;
|
||||||
|
|
||||||
: value-at ( value assoc -- key/f ) value-at* drop ;
|
: value-at ( value assoc -- key/f ) value-at* drop ;
|
||||||
|
@ -172,9 +175,6 @@ M: assoc value-at* swap [ = nip ] curry assoc-find nip ;
|
||||||
: unzip ( assoc -- keys values )
|
: unzip ( assoc -- keys values )
|
||||||
dup assoc-empty? [ drop { } { } ] [ >alist flip first2 ] if ;
|
dup assoc-empty? [ drop { } { } ] [ >alist flip first2 ] if ;
|
||||||
|
|
||||||
: search-alist ( key alist -- pair/f i/f )
|
|
||||||
[ first = ] with find swap ; inline
|
|
||||||
|
|
||||||
M: sequence at*
|
M: sequence at*
|
||||||
search-alist [ second t ] [ f ] if ;
|
search-alist [ second t ] [ f ] if ;
|
||||||
|
|
||||||
|
|
|
@ -10,18 +10,6 @@ ARTICLE: "singletons" "Singleton classes"
|
||||||
{ $subsection singleton-class? }
|
{ $subsection singleton-class? }
|
||||||
{ $subsection singleton-class } ;
|
{ $subsection singleton-class } ;
|
||||||
|
|
||||||
HELP: SINGLETON:
|
|
||||||
{ $syntax "SINGLETON: class" }
|
|
||||||
{ $values
|
|
||||||
{ "class" "a new singleton to define" }
|
|
||||||
}
|
|
||||||
{ $description
|
|
||||||
"Defines a new singleton class. The class word itself is the sole instance of the singleton class."
|
|
||||||
}
|
|
||||||
{ $examples
|
|
||||||
{ $example "USING: classes.singleton kernel io ;" "IN: scratchpad" "SINGLETON: foo\nGENERIC: bar ( obj -- )\nM: foo bar drop \"a foo!\" print ;\nfoo bar" "a foo!" }
|
|
||||||
} ;
|
|
||||||
|
|
||||||
HELP: define-singleton-class
|
HELP: define-singleton-class
|
||||||
{ $values { "word" "a new word" } }
|
{ $values { "word" "a new word" } }
|
||||||
{ $description
|
{ $description
|
||||||
|
|
|
@ -172,7 +172,7 @@ $nl
|
||||||
$nl
|
$nl
|
||||||
"The second is to use ad-hoc slot polymorphism. If two classes define a slot with the same name, then code which uses " { $link "accessors" } " can operate on instances of both objects, assuming the values stored in that slot implement a common protocol. This allows code to be shared without creating contrieved relationships between classes."
|
"The second is to use ad-hoc slot polymorphism. If two classes define a slot with the same name, then code which uses " { $link "accessors" } " can operate on instances of both objects, assuming the values stored in that slot implement a common protocol. This allows code to be shared without creating contrieved relationships between classes."
|
||||||
{ $heading "Anti-pattern #3: subclassing to override a method definition" }
|
{ $heading "Anti-pattern #3: subclassing to override a method definition" }
|
||||||
"While method overriding is a very powerful tool, improper use can cause tight coupling of code and lead to difficulty in testing and refactoring. Subclassing should not be used as a means of ``monkey patching'' methods to fix bugs and add features. Only subclass from classes which were designed to be inherited from, and when writing classes of your own which are intended to be subclassed, clearly document that subclasses may and may not do. This includes construction policy; document whether subclasses should use " { $link new } ", " { $link boa } ", or a custom parametrized constructor."
|
"While method overriding is a very powerful tool, improper use can cause tight coupling of code and lead to difficulty in testing and refactoring. Subclassing should not be used as a means of “monkey patching” methods to fix bugs and add features. Only subclass from classes which were designed to be inherited from, and when writing classes of your own which are intended to be subclassed, clearly document that subclasses may and may not do. This includes construction policy; document whether subclasses should use " { $link new } ", " { $link boa } ", or a custom parametrized constructor."
|
||||||
{ $see-also "parametrized-constructors" } ;
|
{ $see-also "parametrized-constructors" } ;
|
||||||
|
|
||||||
ARTICLE: "tuple-subclassing" "Tuple subclassing"
|
ARTICLE: "tuple-subclassing" "Tuple subclassing"
|
||||||
|
@ -428,5 +428,5 @@ HELP: new
|
||||||
HELP: boa
|
HELP: boa
|
||||||
{ $values { "..." "slot values" } { "class" tuple-class } { "tuple" tuple } }
|
{ $values { "..." "slot values" } { "class" tuple-class } { "tuple" tuple } }
|
||||||
{ $description "Creates a new instance of " { $snippet "class" } " and fill in the slots from the stack, with the top-most stack element being stored in the right-most slot." }
|
{ $description "Creates a new instance of " { $snippet "class" } " and fill in the slots from the stack, with the top-most stack element being stored in the right-most slot." }
|
||||||
{ $notes "The name " { $snippet "boa" } " is shorthand for ``by order of arguments'', and ``BOA constructor'' is a pun on ``boa constrictor''." }
|
{ $notes "The name " { $snippet "boa" } " is shorthand for “by order of arguments”, and “BOA constructor” is a pun on “boa constrictor”." }
|
||||||
{ $errors "Throws an error if the slot values do not match class declarations on slots (see" { $link "tuple-declarations" } ")." } ;
|
{ $errors "Throws an error if the slot values do not match class declarations on slots (see" { $link "tuple-declarations" } ")." } ;
|
||||||
|
|
|
@ -1,6 +1,6 @@
|
||||||
USING: help.markup help.syntax kernel kernel.private
|
USING: help.markup help.syntax kernel kernel.private
|
||||||
continuations.private vectors arrays namespaces
|
continuations.private vectors arrays namespaces
|
||||||
assocs words quotations lexer sequences ;
|
assocs words quotations lexer sequences math ;
|
||||||
IN: continuations
|
IN: continuations
|
||||||
|
|
||||||
ARTICLE: "errors-restartable" "Restartable errors"
|
ARTICLE: "errors-restartable" "Restartable errors"
|
||||||
|
@ -26,7 +26,7 @@ ARTICLE: "errors-anti-examples" "Common error handling pitfalls"
|
||||||
$nl
|
$nl
|
||||||
"In most other cases, " { $link cleanup } " should be used instead to handle an error and rethrow it automatically."
|
"In most other cases, " { $link cleanup } " should be used instead to handle an error and rethrow it automatically."
|
||||||
{ $heading "Anti-pattern #3: Dropping and rethrowing" }
|
{ $heading "Anti-pattern #3: Dropping and rethrowing" }
|
||||||
"Do not use " { $link recover } " to handle an error by dropping it and throwing a new error. By losing the original error message, you signal to the user that something failed without leaving any indication of what actually went wrong. Either wrap the error in a new error containing additional information, or rethrow the original error. A more subtle form of this is using " { $link throw } " instead of " { $link rethrow } ". The " { $link throw } " word should only be used when throwing new errors, and never when rethrowing errors that have been caught."
|
"Do not use " { $link recover } " to handle an error by dropping it and throwing a new error. By losing the original error message, you signal to the user that something failed without leaving any indication of what actually went wrong. Either wrap the error in a new error containing additional information, or rethrow the original error. A more subtle form of this is using " { $link throw } " instead of " { $link rethrow } ". The " { $link throw } " word should only be used when throwing new errors, and never when rethrowing errors that have been caught."
|
||||||
{ $heading "Anti-pattern #4: Logging and rethrowing" }
|
{ $heading "Anti-pattern #4: Logging and rethrowing" }
|
||||||
"If you are going to rethrow an error, do not log a message. If you do so, the user will see two log messages for the same error, which will clutter logs without adding any useful information." ;
|
"If you are going to rethrow an error, do not log a message. If you do so, the user will see two log messages for the same error, which will clutter logs without adding any useful information." ;
|
||||||
|
|
||||||
|
@ -241,12 +241,13 @@ HELP: attempt-all
|
||||||
|
|
||||||
HELP: retry
|
HELP: retry
|
||||||
{ $values
|
{ $values
|
||||||
{ "quot" quotation } { "n" null }
|
{ "quot" quotation } { "n" integer }
|
||||||
}
|
}
|
||||||
{ $description "Tries the quotation up to " { $snippet "n" } " times until it returns true. Retries the quotation if an exception is thrown or if the quotation returns " { $link f } ". The quotation is expected to have side effects that may fail, such as generating a random name for a new file until successful." }
|
{ $description "Tries the quotation up to " { $snippet "n" } " times until it returns true. Retries the quotation if an exception is thrown or if the quotation returns " { $link f } ". The quotation is expected to have side effects that may fail, such as generating a random name for a new file until successful." }
|
||||||
{ $examples
|
{ $examples
|
||||||
|
"Try to get a 0 as a random number:"
|
||||||
{ $unchecked-example "USING: continuations math prettyprint ;"
|
{ $unchecked-example "USING: continuations math prettyprint ;"
|
||||||
"[ 5 random 0 = ] retry t"
|
"[ 5 random 0 = ] 5 retry t"
|
||||||
"t"
|
"t"
|
||||||
}
|
}
|
||||||
} ;
|
} ;
|
||||||
|
|
Some files were not shown because too many files have changed in this diff Show More
Loading…
Reference in New Issue