diff --git a/extra/html/components/components-tests.factor b/extra/html/components/components-tests.factor new file mode 100644 index 0000000000..6ecd2b0fa6 --- /dev/null +++ b/extra/html/components/components-tests.factor @@ -0,0 +1,145 @@ +IN: html.components.tests +USING: html.components tools.test kernel io.streams.string +io.streams.null accessors ; + +[ ] [ blank-values ] unit-test + +[ ] [ 3 "hi" set-value ] unit-test + +[ 3 ] [ "hi" value ] unit-test + +TUPLE: color red green blue ; + +[ ] [ 1 2 3 color boa from-tuple ] unit-test + +[ 1 ] [ "red" value ] unit-test + +[ ] [ "jimmy" "red" set-value ] unit-test + +[ "123.5" ] [ 123.5 object>string ] unit-test + +[ "jimmy" ] [ + [ + "red" label render + ] with-string-writer +] unit-test + +[ ] [ "" "red" set-value ] unit-test + +[ "<jimmy>" ] [ + [ + "red" label render + ] with-string-writer +] unit-test + +[ "" ] [ + [ + "red" hidden render + ] with-string-writer +] unit-test + +[ ] [ "'jimmy'" "red" set-value ] unit-test + +[ "" ] [ + [ + "red" 5 >>size render + ] with-string-writer +] unit-test + +[ "" ] [ + [ + "red" 5 >>size render + ] with-string-writer +] unit-test + +[ ] [ + [ + "green" ; + +! Choice +TUPLE: choice size choices multiple ; + +: ( -- choice ) + choice new ; + +: render-option ( text selected? -- ) + ; + +: render-options ( options selected -- ) + '[ dup , member? render-option ] each ; + +M: choice render* + ; + +! Checkboxes +TUPLE: checkbox label ; + +: ( -- checkbox ) + checkbox new ; + +M: checkbox render* + + label>> escape-string write + ; + +! Link components +GENERIC: link-title ( obj -- string ) +GENERIC: link-href ( obj -- url ) + +SINGLETON: link + +M: link render* + 2drop + + link-title object>string escape-string write + ; + +! HTML component +SINGLETON: html + +M: html render* 2drop write ; diff --git a/extra/html/elements/elements-tests.factor b/extra/html/elements/elements-tests.factor index aa6a017540..1178deab38 100644 --- a/extra/html/elements/elements-tests.factor +++ b/extra/html/elements/elements-tests.factor @@ -1,8 +1,5 @@ IN: html.elements.tests -USING: tools.test html html.elements io.streams.string ; - -: make-html-string - [ with-html-stream ] with-string-writer ; +USING: tools.test html.elements io.streams.string ; [ "" ] -[ [ ] make-html-string ] unit-test +[ [ ] with-string-writer ] unit-test diff --git a/extra/html/elements/elements.factor b/extra/html/elements/elements.factor index 49782fa305..e5377cedf8 100644 --- a/extra/html/elements/elements.factor +++ b/extra/html/elements/elements.factor @@ -57,6 +57,8 @@ SYMBOL: html : print-html ( str -- ) write-html "\n" write-html ; +<< + : html-word ( name def effect -- ) #! Define 'word creating' word to allow #! dynamically creating words. @@ -137,30 +139,46 @@ SYMBOL: html dup "=" prepend swap [ write-attr ] curry attribute-effect html-word ; +! Define some closed HTML tags [ - ! Define some closed HTML tags - [ - "h1" "h2" "h3" "h4" "h5" "h6" "h7" "h8" "h9" - "ol" "li" "form" "a" "p" "html" "head" "body" "title" - "b" "i" "ul" "table" "tbody" "tr" "td" "th" "pre" "textarea" - "script" "div" "span" "select" "option" "style" "input" - ] [ define-closed-html-word ] each + "h1" "h2" "h3" "h4" "h5" "h6" "h7" "h8" "h9" + "ol" "li" "form" "a" "p" "html" "head" "body" "title" + "b" "i" "ul" "table" "tbody" "tr" "td" "th" "pre" "textarea" + "script" "div" "span" "select" "option" "style" "input" +] [ define-closed-html-word ] each - ! Define some open HTML tags - [ - "input" - "br" - "link" - "img" - ] [ define-open-html-word ] each +! Define some open HTML tags +[ + "input" + "br" + "link" + "img" +] [ define-open-html-word ] each - ! Define some attributes - [ - "method" "action" "type" "value" "name" - "size" "href" "class" "border" "rows" "cols" - "id" "onclick" "style" "valign" "accesskey" - "src" "language" "colspan" "onchange" "rel" - "width" "selected" "onsubmit" "xmlns" "lang" "xml:lang" - "media" "title" "multiple" - ] [ define-attribute-word ] each -] with-compilation-unit +! Define some attributes +[ + "method" "action" "type" "value" "name" + "size" "href" "class" "border" "rows" "cols" + "id" "onclick" "style" "valign" "accesskey" + "src" "language" "colspan" "onchange" "rel" + "width" "selected" "onsubmit" "xmlns" "lang" "xml:lang" + "media" "title" "multiple" +] [ define-attribute-word ] each + +>> + +: xhtml-preamble ( -- ) + "" write-html + "" write-html ; + +: simple-page ( title quot -- ) + #! Call the quotation, with all output going to the + #! body of an html page with the given title. + xhtml-preamble + + swap write + call + ; + +: render-error ( message -- ) + escape-string write ; diff --git a/extra/html/authors.txt b/extra/html/streams/authors.txt similarity index 100% rename from extra/html/authors.txt rename to extra/html/streams/authors.txt diff --git a/extra/html/html-tests.factor b/extra/html/streams/streams-tests.factor similarity index 89% rename from extra/html/html-tests.factor rename to extra/html/streams/streams-tests.factor index 9f1ce6b689..2084c7db18 100644 --- a/extra/html/html-tests.factor +++ b/extra/html/streams/streams-tests.factor @@ -1,6 +1,7 @@ -USING: html http io io.streams.string io.styles kernel -namespaces tools.test xml.writer sbufs sequences html.private ; -IN: html.tests +USING: html.streams html.streams.private +io io.streams.string io.styles kernel +namespaces tools.test xml.writer sbufs sequences ; +IN: html.streams.tests : make-html-string [ with-html-stream ] with-string-writer ; inline diff --git a/extra/html/html.factor b/extra/html/streams/streams.factor similarity index 71% rename from extra/html/html.factor rename to extra/html/streams/streams.factor index 71862b0d01..b35f383bdc 100755 --- a/extra/html/html.factor +++ b/extra/html/streams/streams.factor @@ -4,7 +4,7 @@ USING: generic assocs help http io io.styles io.files continuations io.streams.string kernel math math.order math.parser namespaces quotations assocs sequences strings words html.elements xml.entities sbufs continuations destructors ; -IN: html +IN: html.streams GENERIC: browser-link-href ( presented -- href ) @@ -192,76 +192,5 @@ M: html-stream make-cell-stream ( style stream -- stream' ) M: html-stream stream-nl ( stream -- ) dup test-last-div? [ drop ] [ [
] with-output-stream* ] if ; -! Utilities : with-html-stream ( quot -- ) output-stream get swap with-output-stream* ; inline - -: xhtml-preamble - "" write-html - "" write-html ; - -: html-document ( body-quot head-quot -- ) - #! head-quot is called to produce output to go - #! in the html head portion of the document. - #! body-quot is called to produce output to go - #! in the html body portion of the document. - xhtml-preamble - - call - call - ; - -: default-css ( -- ) - ; - -: simple-html-document ( title quot -- ) - swap [ - write - default-css - ] html-document ; - -: vertical-layout ( list -- ) - #! Given a list of HTML components, arrange them vertically. - - [ ] each -
call
; - -: horizontal-layout ( list -- ) - #! Given a list of HTML components, arrange them horizontally. - - [ ] each -
call
; - -: button ( label -- ) - #! Output an HTML submit button with the given label. - ; - -: paragraph ( str -- ) - #! Output the string as an html paragraph -

write

; - -: simple-page ( title quot -- ) - #! Call the quotation, with all output going to the - #! body of an html page with the given title. - - swap write - call - ; - -: styled-page ( title stylesheet-quot quot -- ) - #! Call the quotation, with all output going to the - #! body of an html page with the given title. stylesheet-quot - #! is called to generate the required stylesheet. - - - rot write - swap call - - call - ; - -: render-error ( message -- ) - escape-string write ; diff --git a/extra/html/summary.txt b/extra/html/streams/summary.txt similarity index 100% rename from extra/html/summary.txt rename to extra/html/streams/summary.txt diff --git a/extra/html/tags.txt b/extra/html/streams/tags.txt similarity index 100% rename from extra/html/tags.txt rename to extra/html/streams/tags.txt diff --git a/extra/html/stylesheet.css b/extra/html/stylesheet.css deleted file mode 100644 index a1afce7c9f..0000000000 --- a/extra/html/stylesheet.css +++ /dev/null @@ -1,4 +0,0 @@ -a:link { text-decoration: none; color: black; } -a:visited { text-decoration: none; color: black; } -a:active { text-decoration: none; color: black; } -a:hover { text-decoration: underline; color: black; } diff --git a/extra/validators/validators.factor b/extra/validators/validators.factor index 23bda8cb6c..9d6c4bed90 100644 --- a/extra/validators/validators.factor +++ b/extra/validators/validators.factor @@ -56,6 +56,7 @@ IN: validators : v-email ( str -- str ) #! From http://www.regular-expressions.info/email.html + 60 v-max-length "e-mail" R' [A-Z0-9._%+-]+@[A-Z0-9.-]+\.[A-Z]{2,4}'i v-regexp ;