Backport of improved URL parsing. [Bug 1358369]

author: dkf <donal.k.fellows@manchester.ac.uk> 2005-11-18 15:20:45 (GMT)
committer: dkf <donal.k.fellows@manchester.ac.uk> 2005-11-18 15:20:45 (GMT)
commit: 14f3572945fca6c99e0103cd0f4021c76d33509b (patch)
tree: 6132aa665684ea43dddd5da06a2ec644662542bb /tests/http.test
parent: bf9ba7ca8af34836442083790985ace7603a1141 (diff)
download: tcl-14f3572945fca6c99e0103cd0f4021c76d33509b.zip
tcl-14f3572945fca6c99e0103cd0f4021c76d33509b.tar.gz
tcl-14f3572945fca6c99e0103cd0f4021c76d33509b.tar.bz2
1 files changed, 56 insertions, 73 deletions
diff --git a/tests/http.test b/tests/http.test
index b0020e7..773b7b3 100644
--- a/tests/http.test
+++ b/tests/http.test
@@ -12,7 +12,7 @@
 # of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 #
 #
-# RCS: @(#) $Id: http.test,v 1.33.2.3 2005/10/05 05:01:37 hobbs Exp $
+# RCS: @(#) $Id: http.test,v 1.33.2.4 2005/11/18 15:20:47 dkf Exp $
 
 if {[lsearch [namespace children] ::tcltest] == -1} {
     package require tcltest 2
@@ -82,19 +82,15 @@ if {[info commands testthread] == "testthread" && [file exists $httpdFile]} {
     }
 }
 
-
 test http-1.1 {http::config} {
     http::config
 } [list -accept */* -proxyfilter http::ProxyRequired -proxyhost {} -proxyport {} -urlencoding utf-8 -useragent "Tcl http client package $version"]
-
 test http-1.2 {http::config} {
     http::config -proxyfilter
 } http::ProxyRequired
-
 test http-1.3 {http::config} {
     catch {http::config -junk}
 } 1
-
 test http-1.4 {http::config} {
     set savedconf [http::config]
     http::config -proxyhost nowhere.come -proxyport 8080 \
@@ -104,11 +100,9 @@ test http-1.4 {http::config} {
     eval http::config $savedconf
     set x
 } {-accept */* -proxyfilter myFilter -proxyhost nowhere.come -proxyport 8080 -urlencoding iso8859-1 -useragent {Tcl Test Suite}}
-
 test http-1.5 {http::config} {
     list [catch {http::config -proxyhost {} -junk 8080} msg] $msg
 } {1 {Unknown option -junk, must be: -accept, -proxyfilter, -proxyhost, -proxyport, -urlencoding, -useragent}}
-
 test http-1.6 {http::config} {
     set enc [list [http::config -urlencoding]]
     http::config -urlencoding iso8859-1
@@ -117,7 +111,6 @@ test http-1.6 {http::config} {
     set enc
 } {utf-8 iso8859-1}
 
-
 test http-2.1 {http::reset} {
     catch {http::reset http#1}
 } 0
@@ -125,14 +118,12 @@ test http-2.1 {http::reset} {
 test http-3.1 {http::geturl} {
     list [catch {http::geturl -bogus flag} msg] $msg
 } {1 {Unknown option flag, can be: -binary, -blocksize, -channel, -command, -handler, -headers, -progress, -query, -queryblocksize, -querychannel, -queryprogress, -validate, -timeout, -type}}
-
 test http-3.2 {http::geturl} {
     catch {http::geturl http:junk} err
     set err
 } {Unsupported URL: http:junk}
-
-set url [info hostname]:$port
-set badurl [info hostname]:6666
+set url //[info hostname]:$port
+set badurl //[info hostname]:6666
 test http-3.3 {http::geturl} {
     set token [http::geturl $url]
     http::data $token
@@ -140,14 +131,12 @@ test http-3.3 {http::geturl} {
 <h1>Hello, World!</h1>
 <h2>GET /</h2>
 </body></html>"
-
 set tail /a/b/c
-set url [info hostname]:$port/a/b/c
+set url //[info hostname]:$port/a/b/c
 set fullurl http://user:pass@[info hostname]:$port/a/b/c
-set binurl [info hostname]:$port/binary
-set posturl [info hostname]:$port/post
-set badposturl [info hostname]:$port/droppost
-
+set binurl //[info hostname]:$port/binary
+set posturl //[info hostname]:$port/post
+set badposturl //[info hostname]:$port/droppost
 test http-3.4 {http::geturl} {
     set token [http::geturl $url]
     http::data $token
@@ -155,7 +144,6 @@ test http-3.4 {http::geturl} {
 <h1>Hello, World!</h1>
 <h2>GET $tail</h2>
 </body></html>"
-
 proc selfproxy {host} {
     global port
     return [list [info hostname] $port]
@@ -167,9 +155,8 @@ test http-3.5 {http::geturl} {
     http::data $token
 } "<html><head><title>HTTP/1.0 TEST</title></head><body>
 <h1>Hello, World!</h1>
-<h2>GET http://$url</h2>
+<h2>GET http:$url</h2>
 </body></html>"
-
 test http-3.6 {http::geturl} {
     http::config -proxyfilter bogus
     set token [http::geturl $url]
@@ -179,7 +166,6 @@ test http-3.6 {http::geturl} {
 <h1>Hello, World!</h1>
 <h2>GET $tail</h2>
 </body></html>"
-
 test http-3.7 {http::geturl} {
     set token [http::geturl $url -headers {Pragma no-cache}]
     http::data $token
@@ -187,7 +173,6 @@ test http-3.7 {http::geturl} {
 <h1>Hello, World!</h1>
 <h2>GET $tail</h2>
 </body></html>"
-
 test http-3.8 {http::geturl} {
     set token [http::geturl $url -query Name=Value&Foo=Bar -timeout 2000]
     http::data $token
@@ -200,12 +185,10 @@ test http-3.8 {http::geturl} {
 <dt>Foo<dd>Bar
 </dl>
 </body></html>"
-
 test http-3.9 {http::geturl} {
     set token [http::geturl $url -validate 1]
     http::code $token
 } "HTTP/1.0 200 OK"
-
 test http-3.10 {http::geturl queryprogress} {
     set query foo=bar
     set sep ""
@@ -227,7 +210,6 @@ test http-3.10 {http::geturl queryprogress} {
     http::wait $t
     list [http::status $t] [string length $query] $postProgress [http::data $t]
 } {ok 122879 {16384 32768 49152 65536 81920 98304 114688 122879} {Got 122879 bytes}}
-
 test http-3.11 {http::geturl querychannel with -command} {
     set query foo=bar
     set sep ""
@@ -263,14 +245,11 @@ test http-3.11 {http::geturl querychannel with -command} {
     removeFile outdata
     set testRes
 } {ok 122879 {Got 122880 bytes} ok {PostStart {Got 122880 bytes}}}
-
-# On Linux platforms when the client and server are on the same
-# host, the client is unable to read the server's response one
-# it hits the write error.  The status is "eof"
-
-# On Windows, the http::wait procedure gets a
-# "connection reset by peer" error while reading the reply
-
+# On Linux platforms when the client and server are on the same host, the
+# client is unable to read the server's response one it hits the write error.
+# The status is "eof".
+# On Windows, the http::wait procedure gets a "connection reset by peer" error
+# while reading the reply.
 test http-3.12 {http::geturl querychannel with aborted request} {nonPortable} {
     set query foo=bar
     set sep ""
@@ -308,21 +287,49 @@ test http-3.12 {http::geturl querychannel with aborted request} {nonPortable} {
     removeFile outdata
     list [http::status $t] [http::code $t]
 } {ok {HTTP/1.0 200 Data follows}}
-
 test http-3.13 {http::geturl socket leak test} {
     set chanCount [llength [file channels]]
     for {set i 0} {$i < 3} {incr i} {
-	catch {http::geturl $badurl -timeout 5000} 
+	catch {http::geturl $badurl -timeout 5000}
     }
 
     # No extra channels should be taken
     expr {[llength [file channels]] == $chanCount}
 } 1
-
 test http-3.14 "http::geturl $fullurl" {
     set token [http::geturl $fullurl -validate 1]
     http::code $token
 } "HTTP/1.0 200 OK"
+test http-3.15 {http::geturl parse failures} -body {
+    http::geturl "{invalid}:url"
+} -returnCodes error -result {Unsupported URL: {invalid}:url}
+test http-3.16 {http::geturl parse failures} -body {
+    http::geturl http:relative/url
+} -returnCodes error -result {Unsupported URL: http:relative/url}
+test http-3.17 {http::geturl parse failures} -body {
+    http::geturl /absolute/url
+} -returnCodes error -result {Missing host part: /absolute/url}
+test http-3.18 {http::geturl parse failures} -body {
+    http::geturl http://somewhere:123456789/
+} -returnCodes error -result {Invalid port number: 123456789}
+test http-3.19 {http::geturl parse failures} -body {
+    http::geturl http://{user}@somewhere
+} -returnCodes error -result {Illegal characters in URL user}
+test http-3.20 {http::geturl parse failures} -body {
+    http::geturl http://%user@somewhere
+} -returnCodes error -result {Illegal encoding character usage "%us" in URL user}
+test http-3.21 {http::geturl parse failures} -body {
+    http::geturl http://somewhere/{path}
+} -returnCodes error -result {Illegal characters in URL path}
+test http-3.22 {http::geturl parse failures} -body {
+    http::geturl http://somewhere/%path
+} -returnCodes error -result {Illegal encoding character usage "%pa" in URL path}
+test http-3.23 {http::geturl parse failures} -body {
+    http::geturl http://somewhere/path?{query}
+} -returnCodes error -result {Illegal characters in URL path}
+test http-3.24 {http::geturl parse failures} -body {
+    http::geturl http://somewhere/path?%query
+} -returnCodes error -result {Illegal encoding character usage "%qu" in URL path}
 
 test http-4.1 {http::Event} {
     set token [http::geturl $url]
@@ -330,19 +337,16 @@ test http-4.1 {http::Event} {
     array set meta $data(meta)
     expr ($data(totalsize) == $meta(Content-Length))
 } 1
-
 test http-4.2 {http::Event} {
     set token [http::geturl $url]
     upvar #0 $token data
     array set meta $data(meta)
     string compare $data(type) [string trim $meta(Content-Type)]
 } 0
-
 test http-4.3 {http::Event} {
     set token [http::geturl $url]
     http::code $token
 } {HTTP/1.0 200 Data follows}
-
 test http-4.4 {http::Event} {
     set testfile [makeFile "" testfile]
     set out [open $testfile w]
@@ -357,7 +361,6 @@ test http-4.4 {http::Event} {
 <h1>Hello, World!</h1>
 <h2>GET $tail</h2>
 </body></html>"
-
 test http-4.5 {http::Event} {
     set testfile [makeFile "" testfile]
     set out [open $testfile w]
@@ -367,7 +370,6 @@ test http-4.5 {http::Event} {
     removeFile $testfile
     expr $data(currentsize) == $data(totalsize)
 } 1
-
 test http-4.6 {http::Event} {
     set testfile [makeFile "" testfile]
     set out [open $testfile w]
@@ -379,8 +381,7 @@ test http-4.6 {http::Event} {
     close $in
     removeFile $testfile
     set x
-} "$bindata$binurl"
-
+} "$bindata[string trimleft $binurl /]"
 proc myProgress {token total current} {
     global progress httpLog
     if {[info exists httpLog] && $httpLog} {
@@ -391,7 +392,7 @@ proc myProgress {token total current} {
 if 0 {
     # This test hangs on Windows95 because the client never gets EOF
     set httpLog 1
-    test http-4.6 {http::Event} {
+    test http-4.6.1 {http::Event} knownBug {
 	set token [http::geturl $url -blocksize 50 -progress myProgress]
 	set progress
     } {111 111}
@@ -412,38 +413,29 @@ test http-4.10 {http::Event} {
     set token [http::geturl $url -progress myProgress]
     http::size $token
 } {111}
-
 # Timeout cases
-
-#	Short timeout to working server  (the test server)
-#	This lets us try a reset during the connection
-
+#	Short timeout to working server (the test server). This lets us try a
+#	reset during the connection.
 test http-4.11 {http::Event} {
     set token [http::geturl $url -timeout 1 -command {#}]
     http::reset $token
     http::status $token
 } {reset}
-
-#	Longer timeout with reset
-
+#	Longer timeout with reset.
 test http-4.12 {http::Event} {
     set token [http::geturl $url/?timeout=10 -command {#}]
     http::reset $token
     http::status $token
 } {reset}
-
-#	Medium timeout to working server that waits even longer
-#	The timeout hits while waiting for a reply
-
+#	Medium timeout to working server that waits even longer. The timeout
+#	hits while waiting for a reply.
 test http-4.13 {http::Event} {
     set token [http::geturl $url?timeout=30 -timeout 10 -command {#}]
     http::wait $token
     http::status $token
 } {timeout}
-
-#	Longer timeout to good host, bad port, gets an error
-#	after the connection "completes" but the socket is bad
-
+#	Longer timeout to good host, bad port, gets an error after the
+#	connection "completes" but the socket is bad.
 test http-4.14 {http::Event} {
     set code [catch {
 	set token [http::geturl $badurl/?timeout=10 -timeout 10000 -command {#}]
@@ -456,14 +448,12 @@ test http-4.14 {http::Event} {
     # error code varies among platforms.
     list $code [regexp {(connect failed|couldn't open socket)} $err]
 } {1 1}
-
 # Bogus host
-
 test http-4.15 {http::Event} {
     # This test may fail if you use a proxy server.  That is to be
     # expected and is not a problem with Tcl.
     set code [catch {
-	set token [http::geturl not_a_host.tcl.tk -timeout 1000 -command {#}]
+	set token [http::geturl //not_a_host.tcl.tk -timeout 1000 -command {#}]
 	http::wait $token
 	http::status $token
     } err]
@@ -474,17 +464,13 @@ test http-4.15 {http::Event} {
 test http-5.1 {http::formatQuery} {
     http::formatQuery name1 value1 name2 "value two"
 } {name1=value1&name2=value+two}
-
-# test http-5.2 obsoleted by 5.4 and 5.4 with http 2.5
-
+# test http-5.2 obsoleted by 5.4 and 5.5 with http 2.5
 test http-5.3 {http::formatQuery} {
     http::formatQuery lines "line1\nline2\nline3"
 } {lines=line1%0d%0aline2%0d%0aline3}
-
 test http-5.4 {http::formatQuery} {
     http::formatQuery name1 ~bwelch name2 \xa1\xa2\xa2
 } {name1=~bwelch&name2=%c2%a1%c2%a2%c2%a2}
-
 test http-5.5 {http::formatQuery} {
     set enc [http::config -urlencoding]
     http::config -urlencoding iso8859-1
@@ -502,19 +488,17 @@ test http-6.1 {http::ProxyRequired} {
     set data(body)
 } "<html><head><title>HTTP/1.0 TEST</title></head><body>
 <h1>Hello, World!</h1>
-<h2>GET http://$url</h2>
+<h2>GET http:$url</h2>
 </body></html>"
 
 test http-7.1 {http::mapReply} {
     http::mapReply "abc\$\[\]\"\\()\}\{"
 } {abc%24%5b%5d%22%5c%28%29%7d%7b}
-
 test http-7.2 {http::mapReply} {
     # RFC 2718 specifies that we pass urlencoding on utf-8 chars by default,
     # so make sure this gets converted to utf-8 then urlencoded.
     http::mapReply "\u2208"
 } {%e2%88%88}
-
 test http-7.3 {http::formatQuery} {
     set enc [http::config -urlencoding]
     # this would be reverting to http <=2.4 behavior
@@ -523,7 +507,6 @@ test http-7.3 {http::formatQuery} {
     http::config -urlencoding $enc
     set res
 } [list 1 "can't read \"formMap(\u2208)\": no such element in array"]
-
 test http-7.4 {http::formatQuery} {
     set enc [http::config -urlencoding]
     # this would be reverting to http <=2.4 behavior w/o errors
author	dkf <donal.k.fellows@manchester.ac.uk>	2005-11-18 15:20:45 (GMT)
committer	dkf <donal.k.fellows@manchester.ac.uk>	2005-11-18 15:20:45 (GMT)
commit	14f3572945fca6c99e0103cd0f4021c76d33509b (patch)
tree	6132aa665684ea43dddd5da06a2ec644662542bb /tests/http.test
parent	bf9ba7ca8af34836442083790985ace7603a1141 (diff)
download	tcl-14f3572945fca6c99e0103cd0f4021c76d33509b.zip tcl-14f3572945fca6c99e0103cd0f4021c76d33509b.tar.gz tcl-14f3572945fca6c99e0103cd0f4021c76d33509b.tar.bz2