Merge branch 'master' of git://factorcode.org/git/factor

db4
Daniel Ehrenberg 2009-02-01 23:53:38 -06:00
commit 1360e5d1e0
28 changed files with 268 additions and 249 deletions

View File

@ -1,5 +1,4 @@
IN: help.html.tests IN: help.html.tests
USING: html.streams classes.predicate help.topics help.markup USING: help.html tools.test help.topics kernel ;
io.streams.string accessors prettyprint kernel tools.test ;
[ ] [ [ [ \ predicate-instance? def>> . ] with-html-writer ] with-string-writer drop ] unit-test [ ] [ "xml" >link help>html drop ] unit-test

View File

@ -1,11 +1,11 @@
! 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.encodings.utf8 io.encodings.ascii io.encodings.binary USING: io.encodings.utf8 io.encodings.ascii io.encodings.binary
io.files io.files.temp io.directories html.streams help kernel io.files io.files.temp io.directories html.streams help kernel
assocs sequences make words accessors arrays help.topics vocabs assocs sequences make words accessors arrays help.topics vocabs
tools.vocabs tools.vocabs.browser namespaces prettyprint io tools.vocabs tools.vocabs.browser namespaces prettyprint io
vocabs.loader serialize fry memoize unicode.case math.order vocabs.loader serialize fry memoize unicode.case math.order
sorting debugger html.elements html ; sorting debugger html xml.literals xml.writer ;
IN: help.html IN: help.html
: escape-char ( ch -- ) : escape-char ( ch -- )
@ -51,17 +51,21 @@ M: f topic>filename* drop \ f topic>filename* ;
] "" make ] "" make
] [ 2drop f ] if ; ] [ 2drop f ] if ;
M: topic browser-link-href topic>filename ; M: topic url-of topic>filename ;
: help-stylesheet ( -- ) : help-stylesheet ( -- string )
"resource:basis/help/html/stylesheet.css" ascii file-contents write ; "resource:basis/help/html/stylesheet.css" ascii file-contents
[XML <style><-></style> XML] ;
: help>html ( topic -- ) : help>html ( topic -- xml )
dup topic>filename utf8 [ [ article-title ]
dup article-title [ drop help-stylesheet ]
[ <style> help-stylesheet </style> ] [ [ help ] with-html-writer ]
[ [ help ] with-html-writer ] simple-page tri simple-page ;
] with-file-writer ;
: generate-help-file ( topic -- )
dup .
dup topic>filename utf8 [ help>html write-xml ] with-file-writer ;
: all-vocabs-really ( -- seq ) : all-vocabs-really ( -- seq )
#! Hack. #! Hack.
@ -87,7 +91,7 @@ M: topic browser-link-href topic>filename ;
all-vocabs-really [ dup vocab-name ] { } map>assoc "vocabs.idx" serialize-index ; all-vocabs-really [ dup vocab-name ] { } map>assoc "vocabs.idx" serialize-index ;
: generate-help-files ( -- ) : generate-help-files ( -- )
all-topics [ '[ _ help>html ] try ] each ; all-topics [ '[ _ generate-help-file ] try ] each ;
: generate-help ( -- ) : generate-help ( -- )
"docs" temp-file "docs" temp-file

View File

@ -1,4 +1,4 @@
! Copyright (C) 2008 Your name. ! Copyright (C) 2008 Slava Pestov
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: help.markup help.syntax io.streams.string kernel strings USING: help.markup help.syntax io.streams.string kernel strings
urls lcs inspector present io ; urls lcs inspector present io ;
@ -100,6 +100,6 @@ $nl
{ $subsection farkup } { $subsection farkup }
"Creating custom components:" "Creating custom components:"
{ $subsection render* } { $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" ABOUT: "html.components"

View File

@ -1,7 +1,8 @@
IN: html.components.tests IN: html.components.tests
USING: tools.test kernel io.streams.string USING: tools.test kernel io.streams.string
io.streams.null accessors inspector html.streams 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 [ ] [ begin-form ] unit-test
@ -31,6 +32,11 @@ TUPLE: color red green blue ;
] with-string-writer ] with-string-writer
] unit-test ] unit-test
[ "<input value=\"&lt;jimmy>\" name=\"red\" type=\"hidden\"/>" ] [
[
"red" hidden render
] with-string-writer
] unit-test
[ "<input value=\"&lt;jimmy>\" name=\"red\" type=\"hidden\"/>" ] [ [ "<input value=\"&lt;jimmy>\" name=\"red\" type=\"hidden\"/>" ] [
[ [
"red" hidden render "red" hidden render
@ -163,9 +169,7 @@ 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 ; "object" value [ describe ] with-html-writer xml>string
"\"" split "'" join ! replace " with ' for now
[ "object" value [ describe ] with-html-writer ] with-string-writer
= =
] unit-test ] unit-test
@ -185,3 +189,9 @@ M: link-test link-href drop "http://www.apple.com/foo&bar" ;
} }
} }
] [ values ] unit-test ] [ values ] unit-test
[ ] [ "error" "blah" <validation-error> "error" set-value ] unit-test
[ ] [
"error" hidden render
] unit-test

View File

@ -15,19 +15,12 @@ GENERIC: render* ( value name renderer -- xml )
prepare-value prepare-value
[ [
dup validation-error? dup validation-error?
[ [ message>> ] [ value>> ] bi ] [ [ message>> render-error ] [ value>> ] bi ]
[ f swap ] [ f swap ]
if if
] 2dip ] 2dip
render* write-xml render*
[ render-error ] when* ; swap 2array write-xml ;
<PRIVATE
: render-input ( value name type -- xml )
[XML <input value=<-> name=<-> type=<->/> XML] ;
PRIVATE>
SINGLETON: label SINGLETON: label
@ -37,7 +30,7 @@ M: label render*
SINGLETON: hidden SINGLETON: hidden
M: hidden render* M: hidden render*
drop "hidden" render-input ; drop [XML <input value=<-> name=<-> type="hidden"/> XML] ;
: render-field ( value name size type -- xml ) : render-field ( value name size type -- xml )
[XML <input value=<-> name=<-> size=<-> type=<->/> XML] ; [XML <input value=<-> name=<-> size=<-> type=<->/> XML] ;
@ -163,9 +156,7 @@ M: farkup render*
SINGLETON: inspector SINGLETON: inspector
M: inspector render* M: inspector render*
2drop [ 2drop [ describe ] with-html-writer ;
[ describe ] with-html-writer
] with-string-writer <unescaped> ;
! Diff component ! Diff component
SINGLETON: comparison SINGLETON: comparison

View File

@ -20,10 +20,6 @@ $nl
$nl $nl
"Writing unescaped HTML to " { $vocab-link "html.streams" } ":" "Writing unescaped HTML to " { $vocab-link "html.streams" } ":"
{ $subsection write-html } { $subsection write-html }
{ $subsection print-html } { $subsection print-html } ;
"Writing some common HTML patterns:"
{ $subsection xhtml-preamble }
{ $subsection simple-page }
{ $subsection render-error } ;
ABOUT: "html.elements" ABOUT: "html.elements"

View File

@ -6,6 +6,14 @@ xml.data xml.literals urls math math.parser combinators
present fry io.streams.string xml.writer html ; present fry io.streams.string xml.writer html ;
IN: html.elements 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" ; : elements-vocab ( -- vocab-name ) "html.elements" ;

View File

@ -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. ! See http://factorcode.org/license.txt for BSD license.
USING: io kernel xml.data xml.writer io.streams.string USING: kernel xml.data xml.writer xml.literals urls.encoding ;
xml.literals io.styles ;
IN: html IN: html
SYMBOL: html : simple-page ( title head body -- xml )
: write-html ( str -- )
H{ { html t } } format ;
: print-html ( str -- )
write-html "\n" write-html ;
: xhtml-preamble ( -- )
"<?xml version=\"1.0\"?>" write-html
"<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.1//EN\" \"http://www.w3.org/TR/xhtml11/DTD/xhtml11.dtd\">" write-html ;
: simple-page ( title head-quot body-quot -- )
[ with-string-writer <unescaped> ] bi@
<XML <XML
<?xml version="1.0"?> <?xml version="1.0"?>
<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.1//EN" "http://www.w3.org/TR/xhtml11/DTD/xhtml11.dtd"> <!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.1//EN" "http://www.w3.org/TR/xhtml11/DTD/xhtml11.dtd">
@ -28,7 +15,10 @@ SYMBOL: html
</head> </head>
<body><-></body> <body><-></body>
</html> </html>
XML> write-xml ; inline XML> ; inline
: render-error ( message -- ) : render-error ( message -- xml )
[XML <span class="error"><-></span> XML] write-xml ; [XML <span class="error"><-></span> XML] ;
: simple-link ( xml url -- xml' )
url-encode swap [XML <a href=<->><-></a> XML] ;

View File

@ -1,33 +1,33 @@
IN: html.streams IN: html.streams
USING: help.markup help.syntax kernel strings io io.styles USING: help.markup help.syntax kernel strings io io.styles
quotations ; quotations xml.data ;
HELP: browser-link-href HELP: url-of
{ $values { "presented" object } { "href" string } } { $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-stream } " instances." } ; { $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 HELP: html-writer
{ $class-description "A formatted output stream which emits HTML markup." } ; { $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: <html-stream> HELP: <html-writer>
{ $values { "stream" "an output stream" } { "html-stream" html-stream } } { $values { "html-writer" html-writer } }
{ $description "Creates a new formatted output stream which emits HTML markup on " { $snippet "stream" } "." } ; { $description "Creates a new formatted output stream which accumulates HTML markup in its " { $snippet "data" } " slot." } ;
HELP: with-html-writer HELP: with-html-writer
{ $values { "quot" quotation } } { $values { "quot" quotation } { "xml" xml-chunk } }
{ $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 } "." } { $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 { $examples
{ $example { $example
"USING: io io.styles html.streams ;" "USING: io io.styles html.streams xml.writer ;"
"[ \"Hello\" { { font-style bold } } format nl ] with-html-writer" "[ \"Hello\" { { font-style bold } } format nl ] with-html-writer write-xml"
"<span style='font-style: normal; font-weight: bold; '>Hello</span><br/>" "<span style=\"font-style: normal; font-weight: bold; \">Hello</span><br/>"
} }
} ; } ;
ARTICLE: "html.streams" "HTML streams" 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." "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-stream } { $subsection html-writer }
{ $subsection <html-stream> } { $subsection <html-writer> }
{ $subsection with-html-writer } ; { $subsection with-html-writer } ;
ABOUT: "html.streams" ABOUT: "html.streams"

View File

@ -1,17 +1,14 @@
USING: html.streams html.streams.private accessors io USING: html.streams html.streams.private accessors io
io.streams.string io.styles kernel namespaces tools.test 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 IN: html.streams.tests
: make-html-string : make-html-string ( quot -- string )
[ with-html-writer ] with-string-writer ; inline [ with-html-writer write-xml ] with-string-writer ; inline
[ [ ] make-html-string ] must-infer [ [ ] make-html-string ] must-infer
[ ] [
512 <sbuf> <html-stream> drop
] unit-test
[ "" ] [ [ "" ] [
[ "" write ] make-html-string [ "" write ] make-html-string
] unit-test ] unit-test
@ -24,22 +21,17 @@ IN: html.streams.tests
[ "<" write ] make-html-string [ "<" write ] make-html-string
] unit-test ] unit-test
[ "<" ] [
[ "<" H{ } output-stream get format-html-span ] make-html-string
] unit-test
TUPLE: funky town ; TUPLE: funky town ;
M: funky browser-link-href M: funky url-of "http://www.funky-town.com/" swap town>> append ;
"http://www.funky-town.com/" swap town>> append ;
[ "<a href='http://www.funky-town.com/austin'>&lt;</a>" ] [ [ "<a href=\"http://www.funky-town.com/austin\">&lt;</a>" ] [
[ [
"<" "austin" funky boa write-object "<" "austin" funky boa write-object
] make-html-string ] make-html-string
] unit-test ] unit-test
[ "<span style='font-family: monospace; '>car</span>" ] [ "<span style=\"font-family: monospace; \">car</span>" ]
[ [
[ [
"car" "car"
@ -48,7 +40,7 @@ M: funky browser-link-href
] make-html-string ] make-html-string
] unit-test ] unit-test
[ "<span style='color: #ff00ff; '>car</span>" ] [ "<span style=\"color: #ff00ff; \">car</span>" ]
[ [
[ [
"car" "car"
@ -57,7 +49,7 @@ M: funky browser-link-href
] make-html-string ] make-html-string
] unit-test ] unit-test
[ "<div style='background-color: #ff00ff; white-space: pre; font-family: monospace; '>cdr</div>" ] [ "<div style=\"background-color: #ff00ff; white-space: pre; font-family: monospace;\">cdr</div>" ]
[ [
[ [
H{ { page-color T{ rgba f 1 0 1 1 } } } H{ { page-color T{ rgba f 1 0 1 1 } } }
@ -65,10 +57,10 @@ M: funky browser-link-href
] make-html-string ] make-html-string
] unit-test ] unit-test
[ [ "<div style=\"white-space: pre; font-family: monospace;\"></div>" ] [
"<div style='white-space: pre; font-family: monospace; '></div>"
] [
[ H{ } [ ] with-nesting nl ] make-html-string [ H{ } [ ] with-nesting nl ] make-html-string
] unit-test ] 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

View File

@ -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. ! See http://factorcode.org/license.txt for BSD license.
USING: combinators generic assocs io io.styles USING: accessors kernel assocs io io.styles math math.order math.parser
io.files continuations io.streams.string kernel math math.order sequences strings make words combinators macros xml.literals html fry
math.parser namespaces make quotations assocs sequences strings destructors ;
words html.elements xml.entities sbufs continuations destructors
accessors arrays urls.encoding html ;
IN: html.streams 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 ;
<PRIVATE
! stream-nl after with-nesting or tabular-output is ! stream-nl after with-nesting or tabular-output is
! ignored, so that HTML stream output looks like ! ignored, so that HTML stream output looks like
@ -25,37 +25,28 @@ TUPLE: html-stream stream last-div ;
: a-div ( stream -- stream ) : a-div ( stream -- stream )
t >>last-div ; inline t >>last-div ; inline
: <html-stream> ( stream -- html-stream ) : new-html-writer ( class -- html-writer )
f html-stream boa ; new V{ } clone >>data ; inline
<PRIVATE TUPLE: html-sub-stream < html-writer style parent ;
TUPLE: html-sub-stream < html-stream style parent ;
: new-html-sub-stream ( style stream class -- stream ) : new-html-sub-stream ( style stream class -- stream )
new new-html-writer
512 <sbuf> >>stream
swap >>parent swap >>parent
swap >>style ; inline swap >>style ; inline
: end-sub-stream ( substream -- string style stream ) : end-sub-stream ( substream -- string style stream )
[ stream>> >string ] [ style>> ] [ parent>> ] tri ; [ data>> ] [ style>> ] [ parent>> ] tri ;
: object-link-tag ( style quot -- ) : object-link-tag ( xml style -- xml )
presented pick at [ presented swap at [ url-of [ simple-link ] when* ] when* ;
browser-link-href [
<a url-encode =href a> call </a>
] [ call ] if*
] [ call ] if* ; inline
: href-link-tag ( style quot -- ) : href-link-tag ( xml style -- xml )
href pick at [ href swap at [ simple-link ] when* ;
<a url-encode =href a> call </a>
] [ call ] if* ; inline
: hex-color, ( color -- ) : hex-color, ( color -- )
[ red>> ] [ green>> ] [ blue>> ] tri [ 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 -- ) : fg-css, ( color -- )
"color: #" % hex-color, "; " % ; "color: #" % hex-color, "; " % ;
@ -76,32 +67,29 @@ TUPLE: html-sub-stream < html-stream style parent ;
: font-css, ( font -- ) : font-css, ( font -- )
"font-family: " % % "; " % ; "font-family: " % % "; " % ;
: apply-style ( style key quot -- style gadget ) MACRO: make-css ( pairs -- str )
[ over at ] dip when* ; inline [ '[ _ swap at [ _ execute ] when* ] ] { } assoc>map
'[ [ _ cleave ] "" make ] ;
: make-css ( style quot -- str )
"" make nip ; inline
: span-css-style ( style -- str ) : span-css-style ( style -- str )
[ {
foreground [ fg-css, ] apply-style { foreground fg-css, }
background [ bg-css, ] apply-style { background bg-css, }
font [ font-css, ] apply-style { font font-css, }
font-style [ style-css, ] apply-style { font-style style-css, }
font-size [ size-css, ] apply-style { font-size size-css, }
] make-css ; } make-css ;
: span-tag ( style quot -- ) : span-tag ( xml style -- xml )
over span-css-style [ span-css-style
call [ swap [XML <span style=<->><-></span> XML] ] unless-empty ; inline
] [
<span =style span> call </span> : emit-html ( quot stream -- )
] if-empty ; inline dip data>> push ; inline
: format-html-span ( string style stream -- ) : format-html-span ( string style stream -- )
stream>> [ [ [ span-tag ] [ href-link-tag ] [ object-link-tag ] tri ]
[ [ [ drop write ] span-tag ] href-link-tag ] object-link-tag emit-html ;
] with-output-stream* ;
TUPLE: html-span-stream < html-sub-stream ; TUPLE: html-span-stream < html-sub-stream ;
@ -113,28 +101,26 @@ M: html-span-stream dispose
: padding-css, ( padding -- ) "padding: " % # "px; " % ; : padding-css, ( padding -- ) "padding: " % # "px; " % ;
: pre-css, ( margin -- ) CONSTANT: pre-css "white-space: pre; font-family: monospace;"
[ "white-space: pre; font-family: monospace; " % ] unless ;
: div-css-style ( style -- str ) : div-css-style ( style -- str )
[ [
page-color [ bg-css, ] apply-style {
border-color [ border-css, ] apply-style { page-color bg-css, }
border-width [ padding-css, ] apply-style { border-color border-css, }
wrap-margin over at pre-css, { border-width padding-css, }
] make-css ; } make-css
: div-tag ( style quot -- )
swap div-css-style [
call
] [ ] [
<div =style div> call </div> wrap-margin swap at
] if-empty ; inline [ pre-css append ] unless
] bi ;
: div-tag ( xml style -- xml' )
div-css-style
[ swap [XML <div style=<->><-></div> XML] ] unless-empty ;
: format-html-div ( string style stream -- ) : format-html-div ( string style stream -- )
stream>> [ [ [ div-tag ] [ object-link-tag ] bi ] emit-html ;
[ [ write ] div-tag ] object-link-tag
] with-output-stream* ;
TUPLE: html-block-stream < html-sub-stream ; 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; " % ; "padding: " % first2 max 2 /i # "px; " % ;
: table-style ( style -- str ) : table-style ( style -- str )
[ {
table-border [ border-css, ] apply-style { table-border border-css, }
table-gap [ border-spacing-css, ] apply-style { table-gap border-spacing-css, }
] make-css ; } make-css
" border-collapse: collapse;" append ;
: table-attrs ( style -- )
table-style " border-collapse: collapse;" append =style ;
: do-escaping ( string style -- string )
html swap at [ escape-string ] unless ;
PRIVATE> PRIVATE>
! Stream protocol ! Stream protocol
M: html-stream stream-flush M: html-writer stream-flush drop ;
stream>> stream-flush ;
M: html-stream stream-write1 M: html-writer stream-write1
[ 1string ] dip stream-write ; not-a-div [ 1string ] emit-html ;
M: html-stream stream-write M: html-writer stream-write
not-a-div [ escape-string ] dip stream>> stream-write ; not-a-div [ ] emit-html ;
M: html-stream stream-format M: html-writer stream-format
[ html over at [ [ escape-string ] dip ] unless ] dip
format-html-span ; format-html-span ;
M: html-stream stream-nl M: html-writer stream-nl
dup last-div? [ drop ] [ [ <br/> ] with-output-stream* ] if ; dup last-div? [ drop ] [ [ [XML <br/> XML] ] emit-html ] if ;
M: html-stream make-span-stream M: html-writer make-span-stream
html-span-stream new-html-sub-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 ; 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 ; html-sub-stream new-html-sub-stream ;
M: html-stream stream-write-table M: html-writer stream-write-table
a-div stream>> [ a-div [
<table dup table-attrs table> swap [ table-style swap [
<tr> [ [ data>> [XML <td valign="top" style=<->><-></td> XML] ] with map
<td "top" =valign swap table-style =style td> [XML <tr><-></tr> XML]
stream>> >string write ] with map
</td> [XML <table><-></table> XML]
] with each </tr> ] emit-html ;
] with each </table>
] with-output-stream* ;
M: html-stream dispose stream>> dispose ; M: html-writer dispose drop ;
: with-html-writer ( quot -- ) : <html-writer> ( -- html-writer )
output-stream get <html-stream> swap with-output-stream* ; inline html-writer new-html-writer ;
: with-html-writer ( quot -- xml )
<html-writer> [ swap with-output-stream* ] keep data>> ; inline

View File

@ -1,12 +1,10 @@
! Copyright (C) 2005 Alex Chapman ! 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. ! See http://factorcode.org/license.txt for BSD license.
USING: continuations sequences kernel namespaces debugger USING: continuations sequences kernel namespaces debugger
combinators math quotations generic strings splitting combinators math quotations generic strings splitting accessors
accessors assocs fry vocabs.parser assocs fry vocabs.parser parser lexer io io.files
parser lexer io io.files io.streams.string io.encodings.utf8 io.streams.string io.encodings.utf8 html.templates ;
html
html.templates ;
IN: html.templates.fhtml IN: html.templates.fhtml
! We use a custom lexer so that %> ends a token even if not ! We use a custom lexer so that %> ends a token even if not
@ -34,13 +32,13 @@ DEFER: <% delimiter
[ [
over line-text>> over line-text>>
[ column>> ] 2dip subseq parsed [ column>> ] 2dip subseq parsed
\ write-html parsed \ write parsed
] 2keep 2 + >>column drop ; ] 2keep 2 + >>column drop ;
: still-looking ( accum lexer -- accum ) : still-looking ( accum lexer -- accum )
[ [
[ line-text>> ] [ column>> ] bi tail [ line-text>> ] [ column>> ] bi tail
parsed \ print-html parsed parsed \ print parsed
] keep next-line ; ] keep next-line ;
: parse-%> ( accum lexer -- accum ) : parse-%> ( accum lexer -- accum )

View File

@ -67,7 +67,7 @@ SYMBOL: nested-template?
SYMBOL: next-template SYMBOL: next-template
: call-next-template ( -- ) : call-next-template ( -- )
next-template get write-html ; next-template get write ;
M: f call-template* drop call-next-template ; M: f call-template* drop call-next-template ;

View File

@ -298,7 +298,7 @@ test-db [
[ "Goodbye" ] [ "http://localhost/quit" add-port http-get nip ] unit-test [ "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 xml xml.utilities validators
furnace furnace.conversations ; furnace furnace.conversations ;
@ -308,7 +308,7 @@ SYMBOL: a
<dispatcher> <dispatcher>
<action> <action>
[ a get-global "a" set-value ] >>init [ a get-global "a" set-value ] >>init
[ [ <html> "a" <field> render </html> ] "text/html" <content> ] >>display [ [ "<html>" write "a" <field> render "</html>" write ] "text/html" <content> ] >>display
[ { { "a" [ v-integer ] } } validate-params ] >>validate [ { { "a" [ v-integer ] } } validate-params ] >>validate
[ "a" value a set-global URL" " <redirect> ] >>submit [ "a" value a set-global URL" " <redirect> ] >>submit
<conversations> <conversations>
@ -322,7 +322,8 @@ SYMBOL: a
3 a set-global 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" ] [ [ "3" ] [
"http://localhost/" add-port http-get "http://localhost/" add-port http-get

View File

@ -4,7 +4,6 @@ assocs arrays classes words urls ;
IN: http.server.dispatchers.tests IN: http.server.dispatchers.tests
\ find-responder must-infer \ find-responder must-infer
\ http-error. must-infer
TUPLE: mock-responder path ; TUPLE: mock-responder path ;

View File

@ -2,3 +2,5 @@ USING: http http.server math sequences continuations tools.test ;
IN: http.server.tests IN: http.server.tests
[ t ] [ [ \ + first ] [ <500> ] recover response? ] unit-test [ t ] [ [ \ + first ] [ <500> ] recover response? ] unit-test
\ make-http-error must-infer

View File

@ -24,8 +24,9 @@ http.parsers
http.server.responses http.server.responses
http.server.remapping http.server.remapping
html.templates html.templates
html.streams
html html
html.streams ; xml.writer ;
IN: http.server IN: http.server
: check-absolute ( url -- url ) : check-absolute ( url -- url )
@ -173,15 +174,14 @@ main-responder global [ <404> <trivial-responder> or ] change-at
: call-responder ( path responder -- response ) : call-responder ( path responder -- response )
[ add-responder-nesting ] [ call-responder* ] 2bi ; [ add-responder-nesting ] [ call-responder* ] 2bi ;
: http-error. ( error -- ) : make-http-error ( error -- xml )
! TODO: get rid of rot [ "Internal server error" f ] dip
"Internal server error" [ ] rot '[ [ print-error nl :c ] with-html-writer
[ _ print-error nl :c ] with-html-writer simple-page ;
] simple-page ;
: <500> ( error -- response ) : <500> ( error -- response )
500 "Internal server error" <trivial-response> 500 "Internal server error" <trivial-response>
swap development? get [ '[ _ http-error. ] >>body ] [ drop ] if ; swap development? get [ make-http-error >>body ] [ drop ] if ;
: do-response ( response -- ) : do-response ( response -- )
[ request get swap write-full-response ] [ request get swap write-full-response ]
@ -190,7 +190,8 @@ main-responder global [ <404> <trivial-responder> or ] change-at
[ [
utf8 [ utf8 [
development? get development? get
[ http-error. ] [ drop "Response error" write ] if [ make-http-error ] [ drop "Response error" ] if
write-xml
] with-encoded-output ] with-encoded-output
] bi ] bi
] recover ; ] recover ;

View File

@ -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

View File

@ -56,19 +56,22 @@ TUPLE: file-responder root hook special allow-listings ;
\ serve-file NOTICE add-input-logging \ serve-file NOTICE add-input-logging
: file. ( name -- xml ) : file>html ( name -- xml )
dup link-info directory? [ "/" append ] when dup link-info directory? [ "/" append ] when
dup [XML <li><a href=<->><-></a></li> XML] ; dup [XML <li><a href=<->><-></a></li> XML] ;
: directory. ( path -- ) : directory>html ( path -- xml )
dup file-name [ ] [ [ file-name ]
[ file-name ] [ directory-files [ file. ] map ] bi [ drop f ]
[XML <h1><-></h1> <ul><-></ul> XML] write-xml [
] simple-page ; [ file-name ] [ [ [ file>html ] map ] with-directory-files ] bi
[XML <h1><-></h1> <ul><-></ul> XML]
] tri
simple-page ;
: list-directory ( directory -- response ) : list-directory ( directory -- response )
file-responder get allow-listings>> [ file-responder get allow-listings>> [
'[ _ directory. ] "text/html" <content> directory>html "text/html" <content>
] [ ] [
drop <403> drop <403>
] if ; ] if ;

View File

@ -6,7 +6,7 @@ ARTICLE: "math.libm" "C standard library math functions"
$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 "USE: math.functions" "2 acos ." "C{ 0.0 1.316957896924817 }" } { $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:" "Trigonometric functions:"
{ $subsection fcos } { $subsection fcos }
{ $subsection fsin } { $subsection fsin }

View File

@ -1,6 +1,6 @@
! 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: xml xml.utilities tools.test xml.data ; USING: xml xml.utilities tools.test xml.data sequences ;
IN: xml.utilities.tests IN: xml.utilities.tests
[ "bar" ] [ "<foo>bar</foo>" string>xml children>string ] unit-test [ "bar" ] [ "<foo>bar</foo>" string>xml children>string ] unit-test
@ -12,3 +12,11 @@ IN: xml.utilities.tests
XML-NS: foo http://blah.com XML-NS: foo http://blah.com
[ T{ name { main "bling" } { url "http://blah.com" } } ] [ "bling" foo ] unit-test [ T{ name { main "bling" } { url "http://blah.com" } } ] [ "bling" foo ] unit-test
[ "blah" ] [ "<foo attr='blah'/>" string>xml-chunk "foo" deep-tag-named "attr" attr ] unit-test
[ { "blah" } ] [ "<foo attr='blah'/>" string>xml-chunk "foo" deep-tags-named [ "attr" attr ] map ] unit-test
[ "blah" ] [ "<foo attr='blah'/>" string>xml "foo" deep-tag-named "attr" attr ] unit-test
[ { "blah" } ] [ "<foo attr='blah'/>" string>xml "foo" deep-tags-named [ "attr" attr ] map ] unit-test

View File

@ -8,8 +8,10 @@ IN: xml.utilities
: children>string ( tag -- string ) : children>string ( tag -- string )
children>> { children>> {
{ [ dup empty? ] [ drop "" ] } { [ 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 ] [ concat ]
} cond ; } cond ;
@ -22,20 +24,24 @@ IN: xml.utilities
: tag-named? ( name elem -- ? ) : tag-named? ( name elem -- ? )
dup tag? [ names-match? ] [ 2drop f ] if ; 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 ) : 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-named ( tag name/string -- tags-seq )
tags@ swap [ tag-named? ] with filter ; assure-name '[ _ swap tag-named? ] filter { } like ;
<PRIVATE
: prepare-deep ( xml name/string -- tag name/string )
[ dup xml? [ body>> ] 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 -- ? ) : tag-with-attr? ( elem attr-value attr-name -- ? )
rot dup tag? [ swap attr = ] [ 3drop f ] if ; rot dup tag? [ swap attr = ] [ 3drop f ] if ;
@ -44,13 +50,13 @@ IN: xml.utilities
assure-name '[ _ _ tag-with-attr? ] find nip ; assure-name '[ _ _ tag-with-attr? ] find nip ;
: tags-with-attr ( tag attr-value attr-name -- tags-seq ) : 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 ) : deep-tag-with-attr ( tag attr-value attr-name -- matching-tag )
assure-name '[ _ _ tag-with-attr? ] deep-find ; assure-name '[ _ _ tag-with-attr? ] deep-find ;
: deep-tags-with-attr ( tag attr-value attr-name -- tags-seq ) : 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 ) : get-id ( tag id -- elem )
"id" deep-tag-with-attr ; "id" deep-tag-with-attr ;

View File

@ -1,7 +1,7 @@
! Copyright (C) 2007, 2008 Doug Coleman. ! Copyright (C) 2007, 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: accessors alien alien.accessors arrays assocs 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 kernel math namespaces prettyprint quotations sequences
sequences.deep sets slots.private vectors vocabs words sequences.deep sets slots.private vectors vocabs words
kernel.private ; kernel.private ;
@ -54,7 +54,7 @@ SYMBOL: def-hash-keys
[ drop f ] [ drop f ]
[ "cdecl" ] [ "cdecl" ]
[ first ] [ second ] [ third ] [ fourth ] [ first ] [ second ] [ third ] [ fourth ]
[ ">" write-html ] [ "/>" write-html ] [ ">" write ] [ "/>" write ]
} ; } ;
! ! Add definitions ! ! Add definitions

View File

@ -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

View File

@ -3,7 +3,6 @@ io.encodings.ascii kernel ;
IN: msxml-to-csv IN: msxml-to-csv
: (msxml>csv) ( xml -- table ) : (msxml>csv) ( xml -- table )
"Worksheet" tag-named
"Table" tag-named "Table" tag-named
"Row" tags-named [ "Row" tags-named [
"Cell" tags-named [ "Cell" tags-named [

View File

@ -0,0 +1,2 @@
A,B
C,D
1 A B
2 C D

View File

@ -0,0 +1 @@
<Worksheet><Table><Row><Cell><Data>A</Data></Cell><Cell><Data>B</Data></Cell></Row><Row><Cell><Data>C</Data></Cell><Cell><Data>D</Data></Cell></Row></Table></Worksheet>

View File

@ -1,6 +1,6 @@
! (c)2009 Joe Groff, see BSD license ! (c)2009 Joe Groff, see BSD license
USING: arrays literals math math.affine-transforms math.functions multiline USING: accessors arrays literals math math.affine-transforms
svg tools.test ; math.functions multiline sequences svg tools.test xml xml.utilities ;
IN: svg.tests IN: svg.tests
{ 1.0 2.25 } { -3.0 4.0 } { 5.5 0.000001 } <affine-transform> 1array [ { 1.0 2.25 } { -3.0 4.0 } { 5.5 0.000001 } <affine-transform> 1array [
@ -94,3 +94,18 @@ IN: svg.tests
A 5 6 7 1 0 8 9 A 5 6 7 1 0 8 9
"> svg-path>array "> svg-path>array
] unit-test ] unit-test
STRING: test-svg-string
<svg xmlns="http://www.w3.org/2000/svg">
<path transform="translate(1 2)" d="M -1 -1 l 2 2" />
</svg>
;
: 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