modules/html/html.man | 76 +++++++++++++++- modules/html/html.tcl | 55 +++++++++--- modules/html/html.test | 224 +++++++++++++++++++++++++++++++++++----------- modules/html/pkgIndex.tcl | 2 +- 4 files changed, 287 insertions(+), 70 deletions(-) diff --git a/modules/html/html.man b/modules/html/html.man index 705a8a2..f18cf4b 100644 --- a/modules/html/html.man +++ b/modules/html/html.man @@ -1,5 +1,6 @@ [comment {-*- tcl -*- doctools manpage}] -[manpage_begin html n 1.4] +[vset HTML_VERSION 1.4.4] +[manpage_begin html n [vset HTML_VERSION]] [see_also htmlparse] [see_also ncgi] [keywords checkbox] @@ -12,7 +13,7 @@ [titledesc {Procedures to generate HTML structures}] [category {CGI programming}] [require Tcl 8.2] -[require html [opt 1.4]] +[require html [opt [vset HTML_VERSION]]] [description] [para] @@ -62,7 +63,7 @@ the elements. [call [cmd ::html::checkValue] [arg name] [opt [arg value]]] -Generate the "name=[arg name] value=[arg value] for a [term checkbox] form +Generate the "name=[arg name] value=[arg value]" for a [term checkbox] form element. If the CGI variable [arg name] has the value [arg value], then SELECTED is added to the return value. [arg value] defaults to "1". @@ -245,6 +246,51 @@ value list that is used for the name= and value= parameters for the [term meta] tag. The [term meta] tag is included in the result of [cmd ::html::head]. +[call [cmd ::html::css] [arg href]] + +[emph {Side effect only}]. Call this before [cmd ::html::head] to +define a [term link] tag for a linked CSS document. The [arg href] +value is a HTTP URL to a CSS document. The [term link] tag is included +in the result of [cmd ::html::head]. + +[para] + +Multiple calls of this command are allowed, enabling the use of +multiple CSS document references. In other words, the arguments +of multiple calls are accumulated, and do not overwrite each other. + +[call [cmd ::html::css-clear]] + +[emph {Side effect only}]. Call this before [cmd ::html::head] to +clear all links to CSS documents. +[para] + +Multiple calls of this command are allowed, doing nothing after the +first of a sequence with no intervening [cmd ::html::css]. + +[call [cmd ::html::js] [arg href]] + +[emph {Side effect only}]. Call this before [cmd ::html::head] to +define a [term script] tag for a linked JavaScript document. The +[arg href] is a HTTP URL to a JavaScript document. The [term script] +tag is included in the result of [cmd ::html::head]. + +[para] + +Multiple calls of this command are allowed, enabling the use of +multiple JavaScript document references. In other words, the arguments +of multiple calls are accumulated, and do not overwrite each other. + + +[call [cmd ::html::js-clear]] + +[emph {Side effect only}]. Call this before [cmd ::html::head] to +clear all links to JavaScript documents. +[para] + +Multiple calls of this command are allowed, doing nothing after the +first of a sequence with no intervening [cmd ::html::js]. + [call [cmd ::html::minorList] [arg list] [opt [arg ordered]]] Generate an ordered or unordered list of links. The [arg list] is a @@ -306,7 +352,7 @@ is a Tcl-style label, value list. [call [cmd ::html::radioValue] [arg {name value}]] -Generate the "name=[arg name] value=[arg value] for a [term radio] form +Generate the "name=[arg name] value=[arg value]" for a [term radio] form element. If the CGI variable [arg name] has the value [arg value], then SELECTED is added to the return value. @@ -401,6 +447,28 @@ structure. Rather than evaluating the body, it returns the subst'ed [arg body]. Each iteration of the loop causes another string to be concatenated to the result value. +[call [cmd ::html::doctype] [arg id]] + +This procedure can be used to build the standard DOCTYPE +declaration string. It will return the standard declaration +string for the id, or throw an error if the id is not known. +The following id's are defined: + +[list_begin enumerated] +[enum] HTML32 +[enum] HTML40 +[enum] HTML40T +[enum] HTML40F +[enum] HTML401 +[enum] HTML401T +[enum] HTML401F +[enum] XHTML10S +[enum] XHTML10T +[enum] XHTML10F +[enum] XHTML11 +[enum] XHTMLB +[list_end] + [list_end] [vset CATEGORY html] diff --git a/modules/html/html.tcl b/modules/html/html.tcl index 77e517e..3c0c443 100644 --- a/modules/html/html.tcl +++ b/modules/html/html.tcl @@ -15,7 +15,7 @@ package require Tcl 8.2 package require ncgi -package provide html 1.4 +package provide html 1.4.4 namespace eval ::html { @@ -510,7 +510,7 @@ proc ::html::refresh {content {url {}}} { ::if {[string length $url]} { append html "; url=$url" } - append html "\">\n" + append html "\">" lappend page(meta) $html return "" } @@ -912,7 +912,7 @@ proc ::html::selectPlain {name param choices {current {}}} { # The html fragment proc ::html::textarea {name {param {}} {current {}}} { - ::set value [ncgi::value $name $current] + ::set value [quoteFormValue [ncgi::value $name $current]] return "<[string trimright \ "textarea name=\"$name\"\ [tagParam textarea $param]"]>$value\n" @@ -1405,7 +1405,7 @@ proc ::html::html_entities {s} { # The text with
in place of line-endings. proc ::html::nl2br {s} { - return [string map [list \n\r
\n
\r
] $s] + return [string map [list \n\r
\r\n
\n
\r
] $s] } # ::html::doctype @@ -1419,9 +1419,10 @@ proc ::html::nl2br {s} { proc ::html::doctype {arg} { variable doctypes - set code [string toupper $arg] - if {![info exists doctypes($code)]} { - return -code error "Unknown doctype \"$arg\"" + ::set code [string toupper $arg] + ::if {![info exists doctypes($code)]} { + return -code error -errorcode {HTML DOCTYPE BAD} \ + "Unknown doctype \"$arg\"" } return $doctypes($code) } @@ -1451,12 +1452,26 @@ namespace eval ::html { # href The location of the css file to include the filename and path # # Results: -# HTML for the section +# None. proc ::html::css {href} { variable page - set page(css) \ - "\n" + lappend page(css) "" + return +} + +# ::html::css-clear +# Drop all text/css references. +# +# Arguments: +# None. +# +# Results: +# None. + +proc ::html::css-clear {} { + variable page + catch { unset page(css) } return } @@ -1467,11 +1482,25 @@ proc ::html::css {href} { # href The location of the javascript file to include the filename and path # # Results: -# HTML for the section +# None. proc ::html::js {href} { variable page - set page(js) \ - "\n" + lappend page(js) "" + return +} + +# ::html::js-clear +# Drop all text/javascript references. +# +# Arguments: +# None. +# +# Results: +# None. + +proc ::html::js-clear {} { + variable page + catch { unset page(js) } return } diff --git a/modules/html/html.test b/modules/html/html.test index 7a03c54..6646fb6 100644 --- a/modules/html/html.test +++ b/modules/html/html.test @@ -17,8 +17,8 @@ source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] -testsNeedTcl 8.2 -testsNeedTcltest 1.0 +testsNeedTcl 8.4 +testsNeedTcltest 2.0 testing { useLocal html.tcl html @@ -26,45 +26,46 @@ testing { # ------------------------------------------------------------------------- -test html-1.1 {html::init} { +test html-1.1 {html::init} -body { html::init - list [array exists html::defaults] \ - [array size html::defaults] \ - [info exists html::page] -} {1 0 0} + list \ + [array exists html::defaults] \ + [array size html::defaults] \ + [info exists html::page] +} -result {1 0 0} -test html-1.2 {html::init} { +test html-1.2 {html::init} -body { html::init { font.face arial body.bgcolor white body.text black } lsort [array names html::defaults] -} {body.bgcolor body.text font.face} +} -result {body.bgcolor body.text font.face} -test html-1.3 {html::init} { - catch {html::init wrong num args} -} 1 +test html-1.3 {html::init, too many args} -body { + html::init wrong num args +} -returnCodes error -result {wrong # args: should be "html::init ?nvlist?"} -test html-1.4 {html::init} { - catch {html::init {wrong num args}} -} 1 +test html-1.4 {html::init, bad arg, odd-length list} -body { + html::init {wrong num args} +} -returnCodes error -result {list must have an even number of elements} -test html-2.1 {html::head} { - catch {html::head} -} 1 +test html-2.1 {html::head, not enough args} -body { + html::head +} -returnCodes error -result {wrong # args: should be "html::head title"} -test html-2.2 {html::head} { +test html-2.2 {html::head} -body { html::head "The Title" -} "\n\tThe Title\n\n" +} -result "\n\tThe Title\n\n" -test html-2.3 {html::head} { +test html-2.3 {html::head} -body { html::description "The Description" html::keywords key word html::author "Cathy Coder" html::meta metakey metavalue html::head "The Title" -} { +} -result { The Title @@ -73,24 +74,24 @@ test html-2.3 {html::head} { } -test html-3.1 {html::title} { - catch html::title -} 1 +test html-3.1 {html::title, not enough args} -body { + html::title +} -returnCodes error -result {wrong # args: should be "html::title title"} -test html-3.2 {html::title} { +test html-3.2 {html::title} -body { html::title "blah blah" -} "blah blah\n" +} -result "blah blah\n" -test html-4.1 {html::getTitle} { +test html-4.1 {html::getTitle} -body { html::init html::getTitle -} "" +} -result "" -test html-4.2 {html::getTitle} { +test html-4.2 {html::getTitle} -body { html::init html::title "blah blah" html::getTitle -} {blah blah} +} -result {blah blah} test html-5.1 {html::meta} { html::init @@ -453,6 +454,18 @@ test html-23.2 {html::textarea} { } { } +test html-23.3 {html::textarea, dangerous input} { + html::init { + textarea.cols 50 + textarea.rows 8 + } + ncgi::reset info=[ncgi::encode ""] + ncgi::parse + html::textarea info +} { +} + + test html-24.1 {html::submit} { catch {html::submit} } {1} @@ -516,7 +529,6 @@ test html-26.4 {html::refresh} { } { title - } test html-26.5 {html::refresh} { @@ -526,7 +538,6 @@ test html-26.5 {html::refresh} { } { title - } @@ -794,6 +805,7 @@ test html-32.1 {single argument} { set result [html::eval {set x [format 22]}] list $result $x } {{} 22} + test html-32.2 {multiple arguments} { set a {$b} set b xyzzy @@ -801,38 +813,146 @@ test html-32.2 {multiple arguments} { set result [html::eval {set x [eval format $a]}] list $result $x } {{} xyzzy} + test html-32.3 {single argument} { set x [list] set y 1 set result [html::eval lappend x a b c d {$y} e f g] list $result $x } {{} {a b c d 1 e f g}} -test html-32.4 {error: not enough arguments} {catch html::eval} 1 -test html-32.5 {error: not enough arguments} { - catch html::eval msg - set msg -} {wrong # args: should be "uplevel ?level? command ?arg ...?"} -test html-32.6 {error in eval'ed command} { - catch {html::eval {error "test error"}} -} 1 -test html-32.7 {error in eval'ed command} { - catch {html::eval {error "test error"}} msg - set msg -} {test error} +test html-32.4 {error: not enough arguments} -body { + html::eval +} -returnCodes error -result {wrong # args: should be "uplevel ?level? command ?arg ...?"} -test html-33.0 {html::font} { +test html-32.6 {error in eval'ed command} -body { + html::eval {error "test error"} +} -returnCodes error -result {test error} + +test html-33.0 {html::font} -body { html::font -} {} +} -result {} -test html-33.1 {html::font} { +test html-33.1 {html::font} -body { html::font size=18 -} {} +} -result {} - -test html-34.0 {html::nl2br} { +test html-34.0 {html::nl2br} -body { html::nl2br "a\n\rb\nc\rd" -} {a
b
c
d} +} -result {a
b
c
d} +test html-34.1 {html::nl2br, ticket 1742078} -body { + html::nl2br "a\r\nb" +} -result {a
b} +# ------------------------------------------------------------------------- + +test html-tkt3439702-35.0 {html::css, not enough arguments} -body { + html::css +} -returnCodes error -result {wrong # args: should be "html::css href"} + +test html-tkt3439702-35.1 {html::css, too many arguments} -body { + html::css REF X +} -returnCodes error -result {wrong # args: should be "html::css href"} + +test html-tkt3439702-35.2 {html::css, single ref} -setup { + html::css-clear +} -body { + html::css "http://test.css" + string trim [html::head T] +} -cleanup { + html::css-clear +} -result "\n\tT\n\t\n\t\n" + +test html-tkt3439702-35.3 {html::css, multiple ref} -setup { + html::css-clear +} -body { + html::css "http://test1.css" + html::css "http://test2.css" + string trim [html::head T] +} -cleanup { + html::css-clear +} -result { + T + + + +} + +# ------------------------------------------------------------------------- + +test html-tkt3439702-36.0 {html::js, not enough arguments} -body { + html::js +} -returnCodes error -result {wrong # args: should be "html::js href"} + +test html-tkt3439702-36.1 {html::js, too many arguments} -body { + html::js REF X +} -returnCodes error -result {wrong # args: should be "html::js href"} + +test html-tkt3439702-36.2 {html::js, single ref} -setup { + html::js-clear +} -body { + html::js "http://test.js" + string trim [html::head T] +} -cleanup { + html::js-clear +} -result { + T + + +} + +test html-tkt3439702-36.3 {html::js, multiple ref} -setup { + html::js-clear +} -body { + html::js "http://test1.js" + html::js "http://test2.js" + string trim [html::head T] +} -cleanup { + html::js-clear +} -result { + T + + + +} + +test html-tkt3439702-37.0 {html::js, html::css, mixed} -setup { + html::css-clear + html::js-clear +} -body { + html::css "http://test.css" + html::js "http://test.js" + string trim [html::head T] +} -cleanup { + html::js-clear + html::css-clear +} -result { + T + + + +} + +# ------------------------------------------------------------------------- +# TODO: html::css-clear, html::js-clear + + +test html-tktafe4366e2e-38.0 {html::doctype, not enough args} -body { + html::doctype +} -returnCodes error -result {wrong # args: should be "html::doctype arg"} + +test html-tktafe4366e2e-38.1 {html::doctype, too many args} -body { + html::doctype HTML401T X +} -returnCodes error -result {wrong # args: should be "html::doctype arg"} + +test html-tktafe4366e2e-38.2 {html::doctype, unknown type} -body { + html::doctype HTML401TXXX +} -returnCodes error -result {Unknown doctype "HTML401TXXX"} + +test html-tktafe4366e2e-38.3 {html::doctype} -body { + html::doctype HTML401T +} -result {} + +# ------------------------------------------------------------------------- testsuiteCleanup diff --git a/modules/html/pkgIndex.tcl b/modules/html/pkgIndex.tcl index 88a71b2..9d91097 100644 --- a/modules/html/pkgIndex.tcl +++ b/modules/html/pkgIndex.tcl @@ -1,2 +1,2 @@ if {![package vsatisfies [package provide Tcl] 8.2]} {return} -package ifneeded html 1.4 [list source [file join $dir html.tcl]] +package ifneeded html 1.4.4 [list source [file join $dir html.tcl]]