path: root/dev-tcltk/tcllib/files/tcllib-1.16-XSS-vuln.patch

 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</textarea>\n"
@@ -1405,7 +1405,7 @@ proc ::html::html_entities {s} {
 #	The text with <br> in place of line-endings.
 
 proc ::html::nl2br {s} {
-    return [string map [list \n\r <br> \n <br> \r <br>] $s]
+    return [string map [list \n\r <br> \r\n <br> \n <br> \r <br>] $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) \
-	"<link rel=\"stylesheet\" type=\"text/css\" href=\"[quoteFormValue $href]\">\n"
+    lappend page(css) "<link rel=\"stylesheet\" type=\"text/css\" href=\"[quoteFormValue $href]\">"
+    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) \
-	"<script language=\"javascript\" type=\"text/javascript\" src=\"[quoteFormValue $href]\"></script>\n"
+    lappend page(js) "<script language=\"javascript\" type=\"text/javascript\" src=\"[quoteFormValue $href]\"></script>"
+    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"
-} "<html><head>\n\t<title>The Title</title>\n</head>\n"
+} -result "<html><head>\n\t<title>The Title</title>\n</head>\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"
-} {<html><head>
+} -result {<html><head>
 	<title>The Title</title>
 	<!-- Cathy Coder -->
 	<meta name="description" content="The Description">
@@ -73,24 +74,24 @@ test html-2.3 {html::head} {
 </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"
-} "<title>blah blah</title>\n"
+} -result "<title>blah blah</title>\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} {
 } {<textarea name="info" cols="50" rows="8">The textarea value.</textarea>
 }
 
+test html-23.3 {html::textarea, dangerous input} {
+    html::init {
+	textarea.cols 50
+	textarea.rows 8
+    }
+    ncgi::reset info=[ncgi::encode "</textarea><script>alert(1)</script>"]
+    ncgi::parse
+    html::textarea info
+} {<textarea name="info" cols="50" rows="8">&lt;/textarea&gt;&lt;script&gt;alert(1)&lt;/script&gt;</textarea>
+}
+
+
 test html-24.1 {html::submit} {
     catch {html::submit}
 } {1}
@@ -516,7 +529,6 @@ test html-26.4 {html::refresh} {
 } {<html><head>
 	<title>title</title>
 	<meta http-equiv="Refresh" content="4">
-
 </head>
 }
 test html-26.5 {html::refresh} {
@@ -526,7 +538,6 @@ test html-26.5 {html::refresh} {
 } {<html><head>
 	<title>title</title>
 	<meta http-equiv="Refresh" content="9; url=http://www.scriptics.com">
-
 </head>
 }
 
@@ -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
-} {<font size=18>}
+} -result {<font size=18>}
 
-
-test html-34.0 {html::nl2br} {
+test html-34.0 {html::nl2br} -body {
     html::nl2br "a\n\rb\nc\rd"
-} {a<br>b<br>c<br>d}
+} -result {a<br>b<br>c<br>d}
 
+test html-34.1 {html::nl2br, ticket 1742078} -body {
+    html::nl2br "a\r\nb"
+} -result {a<br>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 "<html><head>\n\t<title>T</title>\n\t<meta http-equiv=\"Refresh\" content=\"9; url=http://www.scriptics.com\">\n\t<link rel=\"stylesheet\" type=\"text/css\" href=\"http://test.css\">\n</head>"
+
+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 {<html><head>
+	<title>T</title>
+	<meta http-equiv="Refresh" content="9; url=http://www.scriptics.com">
+	<link rel="stylesheet" type="text/css" href="http://test1.css">
+	<link rel="stylesheet" type="text/css" href="http://test2.css">
+</head>}
+
+# -------------------------------------------------------------------------
+
+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 {<html><head>
+	<title>T</title>
+	<meta http-equiv="Refresh" content="9; url=http://www.scriptics.com">
+	<script language="javascript" type="text/javascript" src="http://test.js"></script>
+</head>}
+
+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 {<html><head>
+	<title>T</title>
+	<meta http-equiv="Refresh" content="9; url=http://www.scriptics.com">
+	<script language="javascript" type="text/javascript" src="http://test1.js"></script>
+	<script language="javascript" type="text/javascript" src="http://test2.js"></script>
+</head>}
+
+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 {<html><head>
+	<title>T</title>
+	<meta http-equiv="Refresh" content="9; url=http://www.scriptics.com">
+	<link rel="stylesheet" type="text/css" href="http://test.css">
+	<script language="javascript" type="text/javascript" src="http://test.js"></script>
+</head>}
+
+# -------------------------------------------------------------------------
+# 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 {<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01 Transitional//EN" "http://www.w3.org/TR/html4/loose.dtd">}
+
+# -------------------------------------------------------------------------
 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]]