diff --git a/basis/help/html/html-tests.factor b/basis/help/html/html-tests.factor index 475b2114b3..61414cdfa2 100644 --- a/basis/help/html/html-tests.factor +++ b/basis/help/html/html-tests.factor @@ -1,5 +1,4 @@ IN: help.html.tests -USING: html.streams classes.predicate help.topics help.markup -io.streams.string accessors prettyprint kernel tools.test ; +USING: help.html tools.test help.topics kernel ; -[ ] [ [ [ \ predicate-instance? def>> . ] with-html-writer ] with-string-writer drop ] unit-test +[ ] [ "xml" >link help>html drop ] unit-test diff --git a/basis/help/html/html.factor b/basis/help/html/html.factor index 820261dd32..26fc4e2637 100644 --- a/basis/help/html/html.factor +++ b/basis/help/html/html.factor @@ -1,11 +1,11 @@ -! Copyright (C) 2008 Slava Pestov. +! Copyright (C) 2008, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: io.encodings.utf8 io.encodings.ascii io.encodings.binary io.files io.files.temp io.directories html.streams help kernel assocs sequences make words accessors arrays help.topics vocabs tools.vocabs tools.vocabs.browser namespaces prettyprint io vocabs.loader serialize fry memoize unicode.case math.order -sorting debugger html.elements html ; +sorting debugger html xml.literals xml.writer ; IN: help.html : escape-char ( ch -- ) @@ -51,17 +51,21 @@ M: f topic>filename* drop \ f topic>filename* ; ] "" make ] [ 2drop f ] if ; -M: topic browser-link-href topic>filename ; +M: topic url-of topic>filename ; -: help-stylesheet ( -- ) - "resource:basis/help/html/stylesheet.css" ascii file-contents write ; +: help-stylesheet ( -- string ) + "resource:basis/help/html/stylesheet.css" ascii file-contents + [XML XML] ; -: help>html ( topic -- ) - dup topic>filename utf8 [ - dup article-title - [ ] - [ [ help ] with-html-writer ] simple-page - ] with-file-writer ; +: help>html ( topic -- xml ) + [ article-title ] + [ drop help-stylesheet ] + [ [ help ] with-html-writer ] + tri simple-page ; + +: generate-help-file ( topic -- ) + dup . + dup topic>filename utf8 [ help>html write-xml ] with-file-writer ; : all-vocabs-really ( -- seq ) #! Hack. @@ -87,7 +91,7 @@ M: topic browser-link-href topic>filename ; all-vocabs-really [ dup vocab-name ] { } map>assoc "vocabs.idx" serialize-index ; : generate-help-files ( -- ) - all-topics [ '[ _ help>html ] try ] each ; + all-topics [ '[ _ generate-help-file ] try ] each ; : generate-help ( -- ) "docs" temp-file diff --git a/basis/html/components/components-docs.factor b/basis/html/components/components-docs.factor index 39c17a4708..ce4bddde6a 100644 --- a/basis/html/components/components-docs.factor +++ b/basis/html/components/components-docs.factor @@ -1,4 +1,4 @@ -! Copyright (C) 2008 Your name. +! Copyright (C) 2008 Slava Pestov ! See http://factorcode.org/license.txt for BSD license. USING: help.markup help.syntax io.streams.string kernel strings urls lcs inspector present io ; @@ -100,6 +100,6 @@ $nl { $subsection farkup } "Creating custom components:" { $subsection render* } -"Custom components can emit HTML using the " { $vocab-link "html.elements" } " vocabulary." ; +"Custom components can emit HTML using the " { $vocab-link "xml.literals" } " vocabulary." ; ABOUT: "html.components" diff --git a/basis/html/components/components-tests.factor b/basis/html/components/components-tests.factor index 09bb5860ad..410c3ce223 100644 --- a/basis/html/components/components-tests.factor +++ b/basis/html/components/components-tests.factor @@ -1,7 +1,8 @@ IN: html.components.tests USING: tools.test kernel io.streams.string io.streams.null accessors inspector html.streams -html.elements html.components html.forms namespaces ; +html.components html.forms namespaces +xml.writer ; [ ] [ begin-form ] unit-test @@ -31,6 +32,11 @@ TUPLE: color red green blue ; ] with-string-writer ] unit-test +[ "\" name=\"red\" type=\"hidden\"/>" ] [ + [ + "red" hidden render + ] with-string-writer +] unit-test [ "\" name=\"red\" type=\"hidden\"/>" ] [ [ "red" hidden render @@ -163,9 +169,7 @@ M: link-test link-href drop "http://www.apple.com/foo&bar" ; [ t ] [ [ "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 xml>string = ] unit-test @@ -185,3 +189,9 @@ M: link-test link-href drop "http://www.apple.com/foo&bar" ; } } ] [ values ] unit-test + +[ ] [ "error" "blah" "error" set-value ] unit-test + +[ ] [ + "error" hidden render +] unit-test diff --git a/basis/html/components/components.factor b/basis/html/components/components.factor index be197d10e6..f811343df2 100644 --- a/basis/html/components/components.factor +++ b/basis/html/components/components.factor @@ -15,19 +15,12 @@ GENERIC: render* ( value name renderer -- xml ) prepare-value [ dup validation-error? - [ [ message>> ] [ value>> ] bi ] + [ [ message>> render-error ] [ value>> ] bi ] [ f swap ] if ] 2dip - render* write-xml - [ render-error ] when* ; - - name=<-> type=<->/> XML] ; - -PRIVATE> + render* + swap 2array write-xml ; SINGLETON: label @@ -37,7 +30,7 @@ M: label render* SINGLETON: hidden M: hidden render* - drop "hidden" render-input ; + drop [XML name=<-> type="hidden"/> XML] ; : render-field ( value name size type -- xml ) [XML name=<-> size=<-> type=<->/> XML] ; @@ -163,9 +156,7 @@ M: farkup render* SINGLETON: inspector M: inspector render* - 2drop [ - [ describe ] with-html-writer - ] with-string-writer ; + 2drop [ describe ] with-html-writer ; ! Diff component SINGLETON: comparison diff --git a/basis/html/elements/elements-docs.factor b/basis/html/elements/elements-docs.factor index 05b202e08e..7f60eca93f 100644 --- a/basis/html/elements/elements-docs.factor +++ b/basis/html/elements/elements-docs.factor @@ -20,10 +20,6 @@ $nl $nl "Writing unescaped HTML to " { $vocab-link "html.streams" } ":" { $subsection write-html } -{ $subsection print-html } -"Writing some common HTML patterns:" -{ $subsection xhtml-preamble } -{ $subsection simple-page } -{ $subsection render-error } ; +{ $subsection print-html } ; ABOUT: "html.elements" diff --git a/basis/html/elements/elements.factor b/basis/html/elements/elements.factor index b0e46984d7..e23d929d6d 100644 --- a/basis/html/elements/elements.factor +++ b/basis/html/elements/elements.factor @@ -6,6 +6,14 @@ xml.data xml.literals urls math math.parser combinators present fry io.streams.string xml.writer html ; IN: html.elements +SYMBOL: html + +: write-html ( str -- ) + H{ { html t } } format ; + +: print-html ( str -- ) + write-html "\n" write-html ; + << : elements-vocab ( -- vocab-name ) "html.elements" ; diff --git a/basis/html/html.factor b/basis/html/html.factor index 5469941972..5e86add10e 100644 --- a/basis/html/html.factor +++ b/basis/html/html.factor @@ -1,23 +1,10 @@ -! Copyright (C) 2004, 2009 Chris Double, Daniel Ehrenberg. +! Copyright (C) 2004, 2009 Chris Double, Daniel Ehrenberg, +! Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: io kernel xml.data xml.writer io.streams.string -xml.literals io.styles ; +USING: kernel xml.data xml.writer xml.literals urls.encoding ; IN: html -SYMBOL: html - -: write-html ( str -- ) - H{ { html t } } format ; - -: print-html ( str -- ) - write-html "\n" write-html ; - -: xhtml-preamble ( -- ) - "" write-html - "" write-html ; - -: simple-page ( title head-quot body-quot -- ) - [ with-string-writer ] bi@ +: simple-page ( title head body -- xml ) @@ -28,7 +15,10 @@ SYMBOL: html <-> - XML> write-xml ; inline + XML> ; inline -: render-error ( message -- ) - [XML <-> XML] write-xml ; +: render-error ( message -- xml ) + [XML <-> XML] ; + +: simple-link ( xml url -- xml' ) + url-encode swap [XML ><-> XML] ; \ No newline at end of file diff --git a/basis/html/streams/streams-docs.factor b/basis/html/streams/streams-docs.factor index f05eeb30fc..c85ab739b8 100644 --- a/basis/html/streams/streams-docs.factor +++ b/basis/html/streams/streams-docs.factor @@ -1,33 +1,33 @@ IN: html.streams USING: help.markup help.syntax kernel strings io io.styles -quotations ; +quotations xml.data ; -HELP: browser-link-href -{ $values { "presented" object } { "href" string } } -{ $contract "Outputs a link to a page displaying a presentation of the given object. This word is called when " { $link write-object } " is called on " { $link html-stream } " instances." } ; +HELP: url-of +{ $values { "object" object } { "url" string } } +{ $contract "Outputs a link to a page displaying a presentation of the given object. This word is called when " { $link write-object } " is called on " { $link html-writer } " instances." } ; -HELP: html-stream -{ $class-description "A formatted output stream which emits HTML markup." } ; +HELP: html-writer +{ $class-description "A formatted output stream which accumulates HTML markup as " { $vocab-link "xml.data" } " types. The " { $slot "data" } " slot contains a sequence with all markup so far." } ; -HELP: -{ $values { "stream" "an output stream" } { "html-stream" html-stream } } -{ $description "Creates a new formatted output stream which emits HTML markup on " { $snippet "stream" } "." } ; +HELP: +{ $values { "html-writer" html-writer } } +{ $description "Creates a new formatted output stream which accumulates HTML markup in its " { $snippet "data" } " slot." } ; HELP: with-html-writer -{ $values { "quot" quotation } } -{ $description "Calls the quotation in a new dynamic scope with " { $link output-stream } " rebound to an " { $link html-stream } " wrapping the current " { $link output-stream } "." } +{ $values { "quot" quotation } { "xml" xml-chunk } } +{ $description "Calls the quotation in a new dynamic scope with " { $link output-stream } " rebound to an " { $link html-writer } ". When the quotation returns, outputs the accumulated HTML markup." } { $examples { $example - "USING: io io.styles html.streams ;" - "[ \"Hello\" { { font-style bold } } format nl ] with-html-writer" - "Hello
" + "USING: io io.styles html.streams xml.writer ;" + "[ \"Hello\" { { font-style bold } } format nl ] with-html-writer write-xml" + "Hello
" } } ; ARTICLE: "html.streams" "HTML streams" -"The " { $vocab-link "html.streams" } " vocabulary provides a stream which implements " { $link "styles" } " by writing HTML markup to the wrapped stream." -{ $subsection html-stream } -{ $subsection } +"The " { $vocab-link "html.streams" } " vocabulary provides a stream which implements " { $link "io.styles" } " by constructing HTML markup in the form of " { $vocab-link "xml.data" } " types." +{ $subsection html-writer } +{ $subsection } { $subsection with-html-writer } ; ABOUT: "html.streams" diff --git a/basis/html/streams/streams-tests.factor b/basis/html/streams/streams-tests.factor index 94229b3aea..18ab17218f 100644 --- a/basis/html/streams/streams-tests.factor +++ b/basis/html/streams/streams-tests.factor @@ -1,17 +1,14 @@ USING: html.streams html.streams.private accessors io io.streams.string io.styles kernel namespaces tools.test -xml.writer sbufs sequences inspector colors ; +xml.writer sbufs sequences inspector colors xml.writer +classes.predicate prettyprint ; IN: html.streams.tests -: make-html-string - [ with-html-writer ] with-string-writer ; inline +: make-html-string ( quot -- string ) + [ with-html-writer write-xml ] with-string-writer ; inline [ [ ] make-html-string ] must-infer -[ ] [ - 512 drop -] unit-test - [ "" ] [ [ "" write ] make-html-string ] unit-test @@ -24,22 +21,17 @@ IN: html.streams.tests [ "<" write ] make-html-string ] unit-test -[ "<" ] [ - [ "<" H{ } output-stream get format-html-span ] make-html-string -] unit-test - TUPLE: funky town ; -M: funky browser-link-href - "http://www.funky-town.com/" swap town>> append ; +M: funky url-of "http://www.funky-town.com/" swap town>> append ; -[ "<" ] [ +[ "<" ] [ [ "<" "austin" funky boa write-object ] make-html-string ] unit-test -[ "car" ] +[ "car" ] [ [ "car" @@ -48,7 +40,7 @@ M: funky browser-link-href ] make-html-string ] unit-test -[ "car" ] +[ "car" ] [ [ "car" @@ -57,7 +49,7 @@ M: funky browser-link-href ] make-html-string ] unit-test -[ "
cdr
" ] +[ "
cdr
" ] [ [ H{ { page-color T{ rgba f 1 0 1 1 } } } @@ -65,10 +57,10 @@ M: funky browser-link-href ] make-html-string ] unit-test -[ - "
" -] [ +[ "
" ] [ [ H{ } [ ] with-nesting nl ] make-html-string ] unit-test -[ ] [ [ { 1 2 3 } describe ] with-html-writer ] unit-test +[ ] [ [ { 1 2 3 } describe ] with-html-writer drop ] unit-test + +[ ] [ [ \ predicate-instance? def>> . ] with-html-writer drop ] unit-test diff --git a/basis/html/streams/streams.factor b/basis/html/streams/streams.factor index 51eb37b83d..0a4b8eddd4 100644 --- a/basis/html/streams/streams.factor +++ b/basis/html/streams/streams.factor @@ -1,17 +1,17 @@ -! Copyright (C) 2004, 2008 Slava Pestov. +! Copyright (C) 2004, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: combinators generic assocs io io.styles -io.files continuations io.streams.string kernel math math.order -math.parser namespaces make quotations assocs sequences strings -words html.elements xml.entities sbufs continuations destructors -accessors arrays urls.encoding html ; +USING: accessors kernel assocs io io.styles math math.order math.parser +sequences strings make words combinators macros xml.literals html fry +destructors ; IN: html.streams -GENERIC: browser-link-href ( presented -- href ) +GENERIC: url-of ( object -- url ) -M: object browser-link-href drop f ; +M: object url-of drop f ; -TUPLE: html-stream stream last-div ; +TUPLE: html-writer data last-div ; + +>last-div ; inline -: ( stream -- html-stream ) - f html-stream boa ; +: new-html-writer ( class -- html-writer ) + new V{ } clone >>data ; inline - >>stream + new-html-writer swap >>parent swap >>style ; inline : end-sub-stream ( substream -- string style stream ) - [ stream>> >string ] [ style>> ] [ parent>> ] tri ; + [ data>> ] [ style>> ] [ parent>> ] tri ; -: object-link-tag ( style quot -- ) - presented pick at [ - browser-link-href [ - call - ] [ call ] if* - ] [ call ] if* ; inline +: object-link-tag ( xml style -- xml ) + presented swap at [ url-of [ simple-link ] when* ] when* ; -: href-link-tag ( style quot -- ) - href pick at [ - call - ] [ call ] if* ; inline +: href-link-tag ( xml style -- xml ) + href swap at [ simple-link ] when* ; : hex-color, ( color -- ) [ red>> ] [ green>> ] [ blue>> ] tri - [ 255 * >fixnum >hex 2 CHAR: 0 pad-head % ] tri@ ; + [ 255 * >integer >hex 2 CHAR: 0 pad-head % ] tri@ ; : fg-css, ( color -- ) "color: #" % hex-color, "; " % ; @@ -76,32 +67,29 @@ TUPLE: html-sub-stream < html-stream style parent ; : font-css, ( font -- ) "font-family: " % % "; " % ; -: apply-style ( style key quot -- style gadget ) - [ over at ] dip when* ; inline - -: make-css ( style quot -- str ) - "" make nip ; inline +MACRO: make-css ( pairs -- str ) + [ '[ _ swap at [ _ execute ] when* ] ] { } assoc>map + '[ [ _ cleave ] "" make ] ; : span-css-style ( style -- str ) - [ - foreground [ fg-css, ] apply-style - background [ bg-css, ] apply-style - font [ font-css, ] apply-style - font-style [ style-css, ] apply-style - font-size [ size-css, ] apply-style - ] make-css ; + { + { foreground fg-css, } + { background bg-css, } + { font font-css, } + { font-style style-css, } + { font-size size-css, } + } make-css ; -: span-tag ( style quot -- ) - over span-css-style [ - call - ] [ - call - ] if-empty ; inline +: span-tag ( xml style -- xml ) + span-css-style + [ swap [XML ><-> XML] ] unless-empty ; inline + +: emit-html ( quot stream -- ) + dip data>> push ; inline : format-html-span ( string style stream -- ) - stream>> [ - [ [ [ drop write ] span-tag ] href-link-tag ] object-link-tag - ] with-output-stream* ; + [ [ span-tag ] [ href-link-tag ] [ object-link-tag ] tri ] + emit-html ; TUPLE: html-span-stream < html-sub-stream ; @@ -113,28 +101,26 @@ M: html-span-stream dispose : padding-css, ( padding -- ) "padding: " % # "px; " % ; -: pre-css, ( margin -- ) - [ "white-space: pre; font-family: monospace; " % ] unless ; +CONSTANT: pre-css "white-space: pre; font-family: monospace;" : div-css-style ( style -- str ) [ - page-color [ bg-css, ] apply-style - border-color [ border-css, ] apply-style - border-width [ padding-css, ] apply-style - wrap-margin over at pre-css, - ] make-css ; - -: div-tag ( style quot -- ) - swap div-css-style [ - call + { + { page-color bg-css, } + { border-color border-css, } + { border-width padding-css, } + } make-css ] [ -
call
- ] if-empty ; inline + wrap-margin swap at + [ pre-css append ] unless + ] bi ; + +: div-tag ( xml style -- xml' ) + div-css-style + [ swap [XML
><->
XML] ] unless-empty ; : format-html-div ( string style stream -- ) - stream>> [ - [ [ write ] div-tag ] object-link-tag - ] with-output-stream* ; + [ [ div-tag ] [ object-link-tag ] bi ] emit-html ; TUPLE: html-block-stream < html-sub-stream ; @@ -145,57 +131,51 @@ M: html-block-stream dispose ( quot style stream -- ) "padding: " % first2 max 2 /i # "px; " % ; : table-style ( style -- str ) - [ - table-border [ border-css, ] apply-style - table-gap [ border-spacing-css, ] apply-style - ] make-css ; - -: table-attrs ( style -- ) - table-style " border-collapse: collapse;" append =style ; - -: do-escaping ( string style -- string ) - html swap at [ escape-string ] unless ; + { + { table-border border-css, } + { table-gap border-spacing-css, } + } make-css + " border-collapse: collapse;" append ; PRIVATE> ! Stream protocol -M: html-stream stream-flush - stream>> stream-flush ; +M: html-writer stream-flush drop ; -M: html-stream stream-write1 - [ 1string ] dip stream-write ; +M: html-writer stream-write1 + not-a-div [ 1string ] emit-html ; -M: html-stream stream-write - not-a-div [ escape-string ] dip stream>> stream-write ; +M: html-writer stream-write + not-a-div [ ] emit-html ; -M: html-stream stream-format - [ html over at [ [ escape-string ] dip ] unless ] dip +M: html-writer stream-format format-html-span ; -M: html-stream stream-nl - dup last-div? [ drop ] [ [
] with-output-stream* ] if ; +M: html-writer stream-nl + dup last-div? [ drop ] [ [ [XML
XML] ] emit-html ] if ; -M: html-stream make-span-stream +M: html-writer make-span-stream html-span-stream new-html-sub-stream ; -M: html-stream make-block-stream +M: html-writer make-block-stream html-block-stream new-html-sub-stream ; -M: html-stream make-cell-stream +M: html-writer make-cell-stream html-sub-stream new-html-sub-stream ; -M: html-stream stream-write-table - a-div stream>> [ - swap [ - [ - - ] with each - ] with each
- stream>> >string write -
- ] with-output-stream* ; +M: html-writer stream-write-table + a-div [ + table-style swap [ + [ data>> [XML ><-> XML] ] with map + [XML <-> XML] + ] with map + [XML <->
XML] + ] emit-html ; -M: html-stream dispose stream>> dispose ; +M: html-writer dispose drop ; -: with-html-writer ( quot -- ) - output-stream get swap with-output-stream* ; inline +: ( -- html-writer ) + html-writer new-html-writer ; + +: with-html-writer ( quot -- xml ) + [ swap with-output-stream* ] keep data>> ; inline diff --git a/basis/html/templates/fhtml/fhtml.factor b/basis/html/templates/fhtml/fhtml.factor index 23bb469627..c419c4a197 100644 --- a/basis/html/templates/fhtml/fhtml.factor +++ b/basis/html/templates/fhtml/fhtml.factor @@ -1,12 +1,10 @@ ! Copyright (C) 2005 Alex Chapman -! Copyright (C) 2006, 2008 Slava Pestov +! Copyright (C) 2006, 2009 Slava Pestov ! See http://factorcode.org/license.txt for BSD license. USING: continuations sequences kernel namespaces debugger -combinators math quotations generic strings splitting -accessors assocs fry vocabs.parser -parser lexer io io.files io.streams.string io.encodings.utf8 -html -html.templates ; +combinators math quotations generic strings splitting accessors +assocs fry vocabs.parser parser lexer io io.files +io.streams.string io.encodings.utf8 html.templates ; IN: html.templates.fhtml ! We use a custom lexer so that %> ends a token even if not @@ -34,13 +32,13 @@ DEFER: <% delimiter [ over line-text>> [ column>> ] 2dip subseq parsed - \ write-html parsed + \ write parsed ] 2keep 2 + >>column drop ; : still-looking ( accum lexer -- accum ) [ [ line-text>> ] [ column>> ] bi tail - parsed \ print-html parsed + parsed \ print parsed ] keep next-line ; : parse-%> ( accum lexer -- accum ) diff --git a/basis/html/templates/templates.factor b/basis/html/templates/templates.factor index 6951f09efe..efaf8d6a62 100644 --- a/basis/html/templates/templates.factor +++ b/basis/html/templates/templates.factor @@ -67,7 +67,7 @@ SYMBOL: nested-template? SYMBOL: next-template : call-next-template ( -- ) - next-template get write-html ; + next-template get write ; M: f call-template* drop call-next-template ; diff --git a/basis/http/http-tests.factor b/basis/http/http-tests.factor index 6103fb622f..f593980467 100644 --- a/basis/http/http-tests.factor +++ b/basis/http/http-tests.factor @@ -298,7 +298,7 @@ test-db [ [ "Goodbye" ] [ "http://localhost/quit" add-port http-get nip ] unit-test -USING: html.components html.elements html.forms +USING: html.components html.forms xml xml.utilities validators furnace furnace.conversations ; @@ -308,7 +308,7 @@ SYMBOL: a [ a get-global "a" set-value ] >>init - [ [ "a" render ] "text/html" ] >>display + [ [ "" write "a" render "" write ] "text/html" ] >>display [ { { "a" [ v-integer ] } } validate-params ] >>validate [ "a" value a set-global URL" " ] >>submit @@ -322,7 +322,8 @@ SYMBOL: a 3 a set-global -: test-a string>xml "input" tag-named "value" attr ; +: test-a ( xml -- value ) + string>xml body>> "input" deep-tag-named "value" attr ; [ "3" ] [ "http://localhost/" add-port http-get diff --git a/basis/http/server/dispatchers/dispatchers-tests.factor b/basis/http/server/dispatchers/dispatchers-tests.factor index 5b5b30adde..2c8db27259 100644 --- a/basis/http/server/dispatchers/dispatchers-tests.factor +++ b/basis/http/server/dispatchers/dispatchers-tests.factor @@ -4,7 +4,6 @@ assocs arrays classes words urls ; IN: http.server.dispatchers.tests \ find-responder must-infer -\ http-error. must-infer TUPLE: mock-responder path ; diff --git a/basis/http/server/server-tests.factor b/basis/http/server/server-tests.factor index c29912b8c7..fdba9a63ef 100644 --- a/basis/http/server/server-tests.factor +++ b/basis/http/server/server-tests.factor @@ -2,3 +2,5 @@ USING: http http.server math sequences continuations tools.test ; IN: http.server.tests [ t ] [ [ \ + first ] [ <500> ] recover response? ] unit-test + +\ make-http-error must-infer diff --git a/basis/http/server/server.factor b/basis/http/server/server.factor index 90a8ddb51a..97c14a6457 100755 --- a/basis/http/server/server.factor +++ b/basis/http/server/server.factor @@ -24,8 +24,9 @@ http.parsers http.server.responses http.server.remapping html.templates +html.streams html -html.streams ; +xml.writer ; IN: http.server : check-absolute ( url -- url ) @@ -173,15 +174,14 @@ main-responder global [ <404> or ] change-at : call-responder ( path responder -- response ) [ add-responder-nesting ] [ call-responder* ] 2bi ; -: http-error. ( error -- ) - ! TODO: get rid of rot - "Internal server error" [ ] rot '[ - [ _ print-error nl :c ] with-html-writer - ] simple-page ; +: make-http-error ( error -- xml ) + [ "Internal server error" f ] dip + [ print-error nl :c ] with-html-writer + simple-page ; : <500> ( error -- response ) 500 "Internal server error" - swap development? get [ '[ _ http-error. ] >>body ] [ drop ] if ; + swap development? get [ make-http-error >>body ] [ drop ] if ; : do-response ( response -- ) [ request get swap write-full-response ] @@ -190,7 +190,8 @@ main-responder global [ <404> or ] change-at [ utf8 [ development? get - [ http-error. ] [ drop "Response error" write ] if + [ make-http-error ] [ drop "Response error" ] if + write-xml ] with-encoded-output ] bi ] recover ; diff --git a/basis/http/server/static/static-tests.factor b/basis/http/server/static/static-tests.factor new file mode 100644 index 0000000000..d54be03698 --- /dev/null +++ b/basis/http/server/static/static-tests.factor @@ -0,0 +1,4 @@ +IN: http.server.static.tests +USING: http.server.static tools.test xml.writer ; + +[ ] [ "resource:basis" directory>html write-xml ] unit-test \ No newline at end of file diff --git a/basis/http/server/static/static.factor b/basis/http/server/static/static.factor index 67ce0237a4..2df8838061 100644 --- a/basis/http/server/static/static.factor +++ b/basis/http/server/static/static.factor @@ -56,19 +56,22 @@ TUPLE: file-responder root hook special allow-listings ; \ serve-file NOTICE add-input-logging -: file. ( name -- xml ) +: file>html ( name -- xml ) dup link-info directory? [ "/" append ] when dup [XML
  • ><->
    • XML] ; -: directory. ( path -- ) - dup file-name [ ] [ - [ file-name ] [ directory-files [ file. ] map ] bi - [XML

    <->

      <->
    XML] write-xml - ] simple-page ; +: directory>html ( path -- xml ) + [ file-name ] + [ drop f ] + [ + [ file-name ] [ [ [ file>html ] map ] with-directory-files ] bi + [XML

    <->

      <->
    XML] + ] tri + simple-page ; : list-directory ( directory -- response ) file-responder get allow-listings>> [ - '[ _ directory. ] "text/html" + directory>html "text/html" ] [ drop <403> ] if ; diff --git a/basis/math/libm/libm-docs.factor b/basis/math/libm/libm-docs.factor index 72c114487b..bf4c608d77 100644 --- a/basis/math/libm/libm-docs.factor +++ b/basis/math/libm/libm-docs.factor @@ -6,7 +6,7 @@ ARTICLE: "math.libm" "C standard library math functions" $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:" { $example "USE: math.functions" "2 acos ." "C{ 0.0 1.316957896924817 }" } -{ $example "USE: math.libm" "2 facos ." "0.0/0.0" } +{ $unchecked-example "USE: math.libm" "2 facos ." "0.0/0.0" } "Trigonometric functions:" { $subsection fcos } { $subsection fsin } diff --git a/basis/xml/utilities/utilities-tests.factor b/basis/xml/utilities/utilities-tests.factor index 7b0989611c..673bf47f6e 100644 --- a/basis/xml/utilities/utilities-tests.factor +++ b/basis/xml/utilities/utilities-tests.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2005, 2009 Daniel Ehrenberg ! See http://factorcode.org/license.txt for BSD license. -USING: xml xml.utilities tools.test xml.data ; +USING: xml xml.utilities tools.test xml.data sequences ; IN: xml.utilities.tests [ "bar" ] [ "bar" string>xml children>string ] unit-test @@ -12,3 +12,11 @@ IN: xml.utilities.tests XML-NS: foo http://blah.com [ T{ name { main "bling" } { url "http://blah.com" } } ] [ "bling" foo ] unit-test + +[ "blah" ] [ "" string>xml-chunk "foo" deep-tag-named "attr" attr ] unit-test + +[ { "blah" } ] [ "" string>xml-chunk "foo" deep-tags-named [ "attr" attr ] map ] unit-test + +[ "blah" ] [ "" string>xml "foo" deep-tag-named "attr" attr ] unit-test + +[ { "blah" } ] [ "" string>xml "foo" deep-tags-named [ "attr" attr ] map ] unit-test \ No newline at end of file diff --git a/basis/xml/utilities/utilities.factor b/basis/xml/utilities/utilities.factor index d286072be6..1249da8c36 100755 --- a/basis/xml/utilities/utilities.factor +++ b/basis/xml/utilities/utilities.factor @@ -8,8 +8,10 @@ IN: xml.utilities : children>string ( tag -- string ) children>> { { [ dup empty? ] [ drop "" ] } - { [ dup [ string? not ] any? ] - [ "XML tag unexpectedly contains non-text children" throw ] } + { + [ dup [ string? not ] any? ] + [ "XML tag unexpectedly contains non-text children" throw ] + } [ concat ] } cond ; @@ -22,20 +24,24 @@ IN: xml.utilities : tag-named? ( name elem -- ? ) dup tag? [ names-match? ] [ 2drop f ] if ; -: tags@ ( tag name -- children name ) - [ { } like ] dip assure-name ; - -: deep-tag-named ( tag name/string -- matching-tag ) - assure-name '[ _ swap tag-named? ] deep-find ; - -: deep-tags-named ( tag name/string -- tags-seq ) - tags@ '[ _ swap tag-named? ] deep-filter ; - : tag-named ( tag name/string -- matching-tag ) - assure-name swap [ tag-named? ] with find nip ; + assure-name '[ _ swap tag-named? ] find nip ; : tags-named ( tag name/string -- tags-seq ) - tags@ swap [ tag-named? ] with filter ; + assure-name '[ _ swap tag-named? ] filter { } like ; + +> ] when ] [ assure-name ] bi* ; + +PRIVATE> + +: deep-tag-named ( tag name/string -- matching-tag ) + prepare-deep '[ _ swap tag-named? ] deep-find ; + +: deep-tags-named ( tag name/string -- tags-seq ) + prepare-deep '[ _ swap tag-named? ] deep-filter { } like ; : tag-with-attr? ( elem attr-value attr-name -- ? ) rot dup tag? [ swap attr = ] [ 3drop f ] if ; @@ -44,13 +50,13 @@ IN: xml.utilities assure-name '[ _ _ tag-with-attr? ] find nip ; : tags-with-attr ( tag attr-value attr-name -- tags-seq ) - tags@ '[ _ _ tag-with-attr? ] filter children>> ; + assure-name '[ _ _ tag-with-attr? ] filter children>> ; : deep-tag-with-attr ( tag attr-value attr-name -- matching-tag ) assure-name '[ _ _ tag-with-attr? ] deep-find ; : deep-tags-with-attr ( tag attr-value attr-name -- tags-seq ) - tags@ '[ _ _ tag-with-attr? ] deep-filter ; + assure-name '[ _ _ tag-with-attr? ] deep-filter ; : get-id ( tag id -- elem ) "id" deep-tag-with-attr ; diff --git a/extra/lint/lint.factor b/extra/lint/lint.factor index 60e3332ee4..849cc540a3 100755 --- a/extra/lint/lint.factor +++ b/extra/lint/lint.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2007, 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. USING: accessors alien alien.accessors arrays assocs -combinators.short-circuit fry hashtables html io +combinators.short-circuit fry hashtables io kernel math namespaces prettyprint quotations sequences sequences.deep sets slots.private vectors vocabs words kernel.private ; @@ -54,7 +54,7 @@ SYMBOL: def-hash-keys [ drop f ] [ "cdecl" ] [ first ] [ second ] [ third ] [ fourth ] - [ ">" write-html ] [ "/>" write-html ] + [ ">" write ] [ "/>" write ] } ; ! ! Add definitions diff --git a/extra/msxml-to-csv/msxml-to-csv-tests.factor b/extra/msxml-to-csv/msxml-to-csv-tests.factor new file mode 100644 index 0000000000..57c2c775b0 --- /dev/null +++ b/extra/msxml-to-csv/msxml-to-csv-tests.factor @@ -0,0 +1,10 @@ +IN: msxml-to-csv.tests +USING: msxml-to-csv tools.test csv io.encodings.utf8 +io.files.temp kernel ; + +[ t ] [ + "test.csv" temp-file + "resource:extra/msxml-to-csv/test.xml" msxml>csv + "test.csv" temp-file utf8 file>csv + "resource:extra/msxml-to-csv/test.csv" utf8 file>csv = +] unit-test \ No newline at end of file diff --git a/extra/msxml-to-csv/msxml-to-csv.factor b/extra/msxml-to-csv/msxml-to-csv.factor index 839fcaaf54..855275efcc 100644 --- a/extra/msxml-to-csv/msxml-to-csv.factor +++ b/extra/msxml-to-csv/msxml-to-csv.factor @@ -3,7 +3,6 @@ io.encodings.ascii kernel ; IN: msxml-to-csv : (msxml>csv) ( xml -- table ) - "Worksheet" tag-named "Table" tag-named "Row" tags-named [ "Cell" tags-named [ diff --git a/extra/msxml-to-csv/test.csv b/extra/msxml-to-csv/test.csv new file mode 100644 index 0000000000..51880af275 --- /dev/null +++ b/extra/msxml-to-csv/test.csv @@ -0,0 +1,2 @@ +A,B +C,D \ No newline at end of file diff --git a/extra/msxml-to-csv/test.xml b/extra/msxml-to-csv/test.xml new file mode 100644 index 0000000000..cd97905e13 --- /dev/null +++ b/extra/msxml-to-csv/test.xml @@ -0,0 +1 @@ +ABCD
     diff --git a/extra/svg/svg-tests.factor b/extra/svg/svg-tests.factor index 2e1f88b29b..3a28310d71 100644 --- a/extra/svg/svg-tests.factor +++ b/extra/svg/svg-tests.factor @@ -1,6 +1,6 @@ ! (c)2009 Joe Groff, see BSD license -USING: arrays literals math math.affine-transforms math.functions multiline -svg tools.test ; +USING: accessors arrays literals math math.affine-transforms +math.functions multiline sequences svg tools.test xml xml.utilities ; IN: svg.tests { 1.0 2.25 } { -3.0 4.0 } { 5.5 0.000001 } 1array [ @@ -94,3 +94,18 @@ IN: svg.tests A 5 6 7 1 0 8 9 "> svg-path>array ] unit-test + +STRING: test-svg-string + + + +; + +: test-svg-path + test-svg-string string>xml body>> children-tags first ; + +[ { T{ moveto f { -1.0 -1.0 } f } T{ lineto f { 2.0 2.0 } t } } ] +[ test-svg-path tag-d ] unit-test + +[ T{ affine-transform f { 1.0 0.0 } { 0.0 1.0 } { 1.0 2.0 } } ] +[ test-svg-path tag-transform ] unit-test