From 14f3572945fca6c99e0103cd0f4021c76d33509b Mon Sep 17 00:00:00 2001
From: dkf <donal.k.fellows@manchester.ac.uk>
Date: Fri, 18 Nov 2005 15:20:45 +0000
Subject: Backport of improved URL parsing. [Bug 1358369]

---
 ChangeLog             |   5 +
 library/http/http.tcl | 296 +++++++++++++++++++++++++++++++++-----------------
 tests/http.test       | 129 ++++++++++------------
 3 files changed, 260 insertions(+), 170 deletions(-)

diff --git a/ChangeLog b/ChangeLog
index ee32ad7..14df576 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,8 @@
+2005-11-18  Donal K. Fellows  <donal.k.fellows@manchester.ac.uk>
+
+	* library/http/http.tcl (http::geturl): Improved syntactic validation
+	of URLs, and better error messages in some cases. [Bug 1358369]
+
 2005-11-16  Don Porter  <dgp@users.sourceforge.net>
 
 	* README:		Bump version number to 8.4.12
diff --git a/library/http/http.tcl b/library/http/http.tcl
index 08a0888..6c7e636 100644
--- a/library/http/http.tcl
+++ b/library/http/http.tcl
@@ -1,30 +1,29 @@
 # http.tcl --
 #
-#	Client-side HTTP for GET, POST, and HEAD commands.
-#	These routines can be used in untrusted code that uses 
-#	the Safesock security policy.  These procedures use a 
-#	callback interface to avoid using vwait, which is not 
+#	Client-side HTTP for GET, POST, and HEAD commands. These routines can
+#	be used in untrusted code that uses the Safesock security policy. These
+#	procedures use a callback interface to avoid using vwait, which is not
 #	defined in the safe base.
 #
-# See the file "license.terms" for information on usage and
-# redistribution of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+# See the file "license.terms" for information on usage and redistribution of
+# this file, and for a DISCLAIMER OF ALL WARRANTIES.
 #
-# RCS: @(#) $Id: http.tcl,v 1.43.2.8 2005/11/15 22:58:13 dgp Exp $
+# RCS: @(#) $Id: http.tcl,v 1.43.2.9 2005/11/18 15:20:47 dkf Exp $
 
 # Rough version history:
-# 1.0	Old http_get interface
-# 2.0	http:: namespace and http::geturl
-# 2.1	Added callbacks to handle arriving data, and timeouts
-# 2.2	Added ability to fetch into a channel
-# 2.3	Added SSL support, and ability to post from a channel
-#	This version also cleans up error cases and eliminates the
-#	"ioerror" status in favor of raising an error
-# 2.4	Added -binary option to http::geturl and charset element
-#	to the state array.
+# 1.0	Old http_get interface.
+# 2.0	http:: namespace and http::geturl.
+# 2.1	Added callbacks to handle arriving data, and timeouts.
+# 2.2	Added ability to fetch into a channel.
+# 2.3	Added SSL support, and ability to post from a channel. This version
+#	also cleans up error cases and eliminates the "ioerror" status in
+#	favor of raising an error
+# 2.4	Added -binary option to http::geturl and charset element to the state
+#	array.
 
 package require Tcl 8.4
-# keep this in sync with pkgIndex.tcl
-# and with the install directories in Makefiles
+# Keep this in sync with pkgIndex.tcl and with the install directories
+# in Makefiles
 package provide http 2.5.2
 
 namespace eval http {
@@ -39,12 +38,11 @@ namespace eval http {
     set http(-useragent) "Tcl http client package [package provide http]"
 
     proc init {} {
-	# Set up the map for quoting chars
-	# RFC3986 Section 2.3 say percent encode all except:
-	# "... percent-encoded octets in the ranges of ALPHA
-	# (%41-%5A and %61-%7A), DIGIT (%30-%39), hyphen (%2D),
-	# period (%2E), underscore (%5F), or tilde (%7E) should
-	# not be created by URI producers ..."
+	# Set up the map for quoting chars. RFC3986 Section 2.3 say percent
+	# encode all except: "... percent-encoded octets in the ranges of ALPHA
+	# (%41-%5A and %61-%7A), DIGIT (%30-%39), hyphen (%2D), period (%2E),
+	# underscore (%5F), or tilde (%7E) should not be created by URI
+	# producers ..."
 	for {set i 0} {$i <= 256} {incr i} {
 	    set c [format %c $i]
 	    if {![string match {[-._~a-zA-Z0-9]} $c]} {
@@ -152,9 +150,9 @@ proc http::config {args} {
 # Arguments:
 #	token	    Connection token.
 #	errormsg    (optional) If set, forces status to error.
-#       skipCB      (optional) If set, don't call the -command callback.  This
+#       skipCB      (optional) If set, don't call the -command callback. This
 #                   is useful when geturl wants to throw an exception instead
-#                   of calling the callback.  That way, the same error isn't
+#                   of calling the callback. That way, the same error isn't
 #                   reported to two places.
 #
 # Side Effects:
@@ -218,17 +216,16 @@ proc http::reset { token {why reset} } {
 #       args		Option value pairs. Valid options include:
 #				-blocksize, -validate, -headers, -timeout
 # Results:
-#	Returns a token for this connection.
-#	This token is the name of an array that the caller should
-#	unset to garbage collect the state.
+#	Returns a token for this connection. This token is the name of an array
+#	that the caller should unset to garbage collect the state.
 
 proc http::geturl { url args } {
     variable http
     variable urlTypes
     variable defaultCharset
 
-    # Initialize the state variable, an array.  We'll return the
-    # name of this array as the token for the transaction.
+    # Initialize the state variable, an array. We'll return the name of this
+    # array as the token for the transaction.
 
     if {![info exists http(uid)]} {
 	set http(uid) 0
@@ -301,17 +298,118 @@ proc http::geturl { url args } {
     }
 
     # Validate URL, determine the server host and port, and check proxy case
-    # Recognize user:pass@host URLs also, although we do not do anything
-    # with that info yet.
+    # Recognize user:pass@host URLs also, although we do not do anything with
+    # that info yet.
+
+    # URLs have basically four parts.
+    # First, before the colon, is the protocol scheme (e.g. http)
+    # Second, for HTTP-like protocols, is the authority
+    #	The authority is preceded by // and lasts up to (but not including)
+    #	the following / and it identifies up to four parts, of which only one,
+    #	the host, is required (if an authority is present at all). All other
+    #	parts of the authority (user name, password, port number) are optional.
+    # Third is the resource name, which is split into two parts at a ?
+    #	The first part (from the single "/" up to "?") is the path, and the
+    #	second part (from that "?" up to "#") is the query. *HOWEVER*, we do
+    #	not need to separate them; we send the whole lot to the server.
+    # Fourth is the fragment identifier, which is everything after the first
+    #	"#" in the URL. The fragment identifier MUST NOT be sent to the server
+    #	and indeed, we don't bother to validate it (it could be an error to
+    #	pass it in here, but it's cheap to strip).
+    #
+    # An example of a URL that has all the parts:
+    #   http://jschmoe:xyzzy@www.bogus.net:8000/foo/bar.tml?q=foo#changes
+    # The "http" is the protocol, the user is "jschmoe", the password is
+    # "xyzzy", the host is "www.bogus.net", the port is "8000", the path is
+    # "/foo/bar.tml", the query is "q=foo", and the fragment is "changes".
+    #
+    # Note that the RE actually combines the user and password parts, as
+    # recommended in RFC 3986. Indeed, that RFC states that putting passwords
+    # in URLs is a Really Bad Idea, something with which I would agree utterly.
+    # Also note that we do not currently support IPv6 addresses.
+    #
+    # From a validation perspective, we need to ensure that the parts of the
+    # URL that are going to the server are correctly encoded.
+
+    set URLmatcher {(?x)		# this is _expanded_ syntax
+	^
+	(?: (\w+) : ) ?			# <protocol scheme>
+	(?: //
+	    (?:
+		(
+		    [^@/\#?]+		# <userinfo part of authority>
+		) @
+	    )?
+	    ( [^/:\#?]+ )		# <host part of authority>
+	    (?: : (\d+) )?		# <port part of authority>
+	)?
+	( / [^\#?]* (?: \? [^\#?]* )?)?	# <path> (including query)
+	(?: \# (.*) )?			# <fragment>
+	$
+    }
 
-    set exp {^(([^:]*)://)?([^@]+@)?([^/:]+)(:([0-9]+))?(/.*)?$}
-    if {![regexp -nocase $exp $url x prefix proto user host y port srvurl]} {
+    # Phase one: parse
+    if {![regexp -- $URLmatcher $url -> proto user host port srvurl]} {
 	unset $token
 	return -code error "Unsupported URL: $url"
     }
+    # Phase two: validate
+    if {$host eq ""} {
+	# Caller has to provide a host name; we do not have a "default host"
+	# that would enable us to handle relative URLs.
+	unset $token
+	return -code error "Missing host part: $url"
+	# Note that we don't check the hostname for validity here; if it's
+	# invalid, we'll simply fail to resolve it later on.
+    }
+    if {$port ne "" && $port>65535} {
+	unset $token
+	return -code error "Invalid port number: $port"
+    }
+    # The user identification and resource identification parts of the URL can
+    # have encoded characters in them; take care!
+    if {$user ne ""} {
+	# Check for validity according to RFC 3986, Appendix A
+	set validityRE {(?xi)
+	    ^
+	    (?: [-\w.~!$&'()*+,;=:] | %[0-9a-f][0-9a-f] )+
+	    $
+	}
+	if {![regexp -- $validityRE $user]} {
+	    unset $token
+	    # Provide a better error message in this error case
+	    if {[regexp {(?i)%(?![0-9a-f][0-9a-f]).?.?} $user bad]} {
+		return -code error \
+			"Illegal encoding character usage \"$bad\" in URL user"
+	    }
+	    return -code error "Illegal characters in URL user"
+	}
+    }
+    if {$srvurl ne ""} {
+	# Check for validity according to RFC 3986, Appendix A
+	set validityRE {(?xi)
+	    ^
+	    # Path part (already must start with / character)
+	    (?:	      [-\w.~!$&'()*+,;=:@/]  | %[0-9a-f][0-9a-f] )*
+	    # Query part (optional, permits ? characters)
+	    (?: \? (?: [-\w.~!$&'()*+,;=:@/?] | %[0-9a-f][0-9a-f] )* )?
+	    $
+	}
+	if {![regexp -- $validityRE $srvurl]} {
+	    unset $token
+	    # Provide a better error message in this error case
+	    if {[regexp {(?i)%(?![0-9a-f][0-9a-f])..} $srvurl bad]} {
+		return -code error \
+			"Illegal encoding character usage \"$bad\" in URL path"
+	    }
+	    return -code error "Illegal characters in URL path"
+	}
+    } else {
+	set srvurl /
+    }
     if {[string length $proto] == 0} {
 	set proto http
-	set url ${proto}://$url
+	set url ${proto}:$url
     }
     if {![info exists urlTypes($proto)]} {
 	unset $token
@@ -323,20 +421,27 @@ proc http::geturl { url args } {
     if {[string length $port] == 0} {
 	set port $defport
     }
-    if {[string length $srvurl] == 0} {
-	set srvurl /
-    }
-    if {[string length $proto] == 0} {
-	set url http://$url
-    }
-    set state(url) $url
     if {![catch {$http(-proxyfilter) $host} proxy]} {
 	set phost [lindex $proxy 0]
 	set pport [lindex $proxy 1]
     }
 
-    # If a timeout is specified we set up the after event
-    # and arrange for an asynchronous socket connection.
+    # OK, now reassemble into a full URL
+    set url ${proto}://
+    if {$user ne ""} {
+	append url $user
+	append url @
+    }
+    append url $host
+    if {$port != $defport} {
+	append url : $port
+    }
+    append url $srvurl
+    # Don't append the fragment!
+    set state(url) $url
+
+    # If a timeout is specified we set up the after event and arrange for an
+    # asynchronous socket connection.
 
     if {$state(-timeout) > 0} {
 	set state(after) [after $state(-timeout) \
@@ -346,8 +451,8 @@ proc http::geturl { url args } {
 	set async ""
     }
 
-    # If we are using the proxy, we must pass in the full URL that
-    # includes the server name.
+    # If we are using the proxy, we must pass in the full URL that includes
+    # the server name.
 
     if {[info exists phost] && [string length $phost]} {
 	set srvurl $url
@@ -355,11 +460,11 @@ proc http::geturl { url args } {
     } else {
 	set conStat [catch {eval $defcmd $async {$host $port}} s]
     }
-    if {$conStat} {
 
-	# something went wrong while trying to establish the connection
-	# Clean up after events and such, but DON'T call the command callback
-	# (if available) because we're going to throw an exception from here
+    if {$conStat} {
+	# Something went wrong while trying to establish the connection. Clean
+	# up after events and such, but DON'T call the command callback (if
+	# available) because we're going to throw an exception from here
 	# instead.
 	Finish $token "" 1
 	cleanup $token
@@ -367,16 +472,16 @@ proc http::geturl { url args } {
     }
     set state(sock) $s
 
-    # Wait for the connection to complete
+    # Wait for the connection to complete.
 
     if {$state(-timeout) > 0} {
 	fileevent $s writable [list http::Connect $token]
 	http::wait $token
 
 	if {$state(status) eq "error"} {
-	    # something went wrong while trying to establish the connection
+	    # Something went wrong while trying to establish the connection.
 	    # Clean up after events and such, but DON'T call the command
-	    # callback (if available) because we're going to throw an 
+	    # callback (if available) because we're going to throw an
 	    # exception from here instead.
 	    set err [lindex $state(error) 0]
 	    cleanup $token
@@ -392,8 +497,8 @@ proc http::geturl { url args } {
 
     fconfigure $s -translation {auto crlf} -buffersize $state(-blocksize)
 
-    # The following is disallowed in safe interpreters, but the socket
-    # is already in non-blocking mode in that case.
+    # The following is disallowed in safe interpreters, but the socket is
+    # already in non-blocking mode in that case.
 
     catch {fconfigure $s -blocking off}
     set how GET
@@ -403,7 +508,7 @@ proc http::geturl { url args } {
 	    set how POST
 	    set contDone 0
 	} else {
-	    # there's no query data
+	    # There's no query data.
 	    unset state(-query)
 	    set isQuery 0
 	}
@@ -421,8 +526,8 @@ proc http::geturl { url args } {
 	puts $s "$how $srvurl HTTP/1.0"
 	puts $s "Accept: $http(-accept)"
 	if {$port == $defport} {
-	    # Don't add port in this case, to handle broken servers.
-	    # [Bug #504508]
+	    # Don't add port in this case, to handle broken servers. [Bug
+	    # 504508]
 	    puts $s "Host: $host"
 	} else {
 	    puts $s "Host: $host:$port"
@@ -440,8 +545,8 @@ proc http::geturl { url args } {
 	    }
 	}
 	if {$isQueryChannel && $state(querylength) == 0} {
-	    # Try to determine size of data in channel
-	    # If we cannot seek, the surrounding catch will trap us
+	    # Try to determine size of data in channel. If we cannot seek, the
+	    # surrounding catch will trap us
 
 	    set start [tell $state(-querychannel)]
 	    seek $state(-querychannel) 0 end
@@ -450,22 +555,21 @@ proc http::geturl { url args } {
 	    seek $state(-querychannel) $start
 	}
 
-	# Flush the request header and set up the fileevent that will
-	# either push the POST data or read the response.
+	# Flush the request header and set up the fileevent that will either
+	# push the POST data or read the response.
 	#
 	# fileevent note:
 	#
-	# It is possible to have both the read and write fileevents active
-	# at this point.  The only scenario it seems to affect is a server
-	# that closes the connection without reading the POST data.
-	# (e.g., early versions TclHttpd in various error cases).
-	# Depending on the platform, the client may or may not be able to
-	# get the response from the server because of the error it will
-	# get trying to write the post data.  Having both fileevents active
-	# changes the timing and the behavior, but no two platforms
-	# (among Solaris, Linux, and NT)  behave the same, and none 
-	# behave all that well in any case.  Servers should always read thier
-	# POST data if they expect the client to read their response.
+	# It is possible to have both the read and write fileevents active at
+	# this point. The only scenario it seems to affect is a server that
+	# closes the connection without reading the POST data. (e.g., early
+	# versions TclHttpd in various error cases). Depending on the platform,
+	# the client may or may not be able to get the response from the server
+	# because of the error it will get trying to write the post data.
+	# Having both fileevents active changes the timing and the behavior,
+	# but no two platforms (among Solaris, Linux, and NT) behave the same,
+	# and none behave all that well in any case. Servers should always read
+	# their POST data if they expect the client to read their response.
 
 	if {$isQuery || $isQueryChannel} {
 	    puts $s "Content-Type: $state(-type)"
@@ -482,9 +586,8 @@ proc http::geturl { url args } {
 	}
 
 	if {! [info exists state(-command)]} {
-
-	    # geturl does EVERYTHING asynchronously, so if the user
-	    # calls it synchronously, we just do a wait here.
+	    # geturl does EVERYTHING asynchronously, so if the user calls it
+	    # synchronously, we just do a wait here.
 
 	    wait $token
 	    if {$state(status) eq "error"} {
@@ -494,8 +597,8 @@ proc http::geturl { url args } {
 	    }
 	}
     } err]} {
-	# The socket probably was never connected,
-	# or the connection dropped later.
+	# The socket probably was never connected, or the connection dropped
+	# later.
 
 	# Clean up after events and such, but DON'T call the command callback
 	# (if available) because we're going to throw an exception from here
@@ -622,8 +725,8 @@ proc http::Write {token} {
 	# Catch I/O errors on dead sockets
 
 	if {[info exists state(-query)]} {
-	    # Chop up large query strings so queryprogress callback
-	    # can give smooth feedback
+	    # Chop up large query strings so queryprogress callback can give
+	    # smooth feedback.
 
 	    puts -nonewline $s \
 		    [string range $state(-query) $state(queryoffset) \
@@ -644,8 +747,8 @@ proc http::Write {token} {
 	    }
 	}
     } err]} {
-	# Do not call Finish here, but instead let the read half of
-	# the socket process whatever server reply there is to get.
+	# Do not call Finish here, but instead let the read half of the socket
+	# process whatever server reply there is to get.
 
 	set state(posterror) $err
 	set done 1
@@ -656,7 +759,7 @@ proc http::Write {token} {
 	fileevent $s readable [list http::Event $token]
     }
 
-    # Callback to the client after we've completely handled everything
+    # Callback to the client after we've completely handled everything.
 
     if {[string length $state(-queryprogress)]} {
 	eval $state(-queryprogress) [list $token $state(querylength)\
@@ -698,10 +801,10 @@ proc http::Event {token} {
 		    fconfigure $state(-channel) -translation binary
 		}
 	    } else {
-		# If we are getting text, set the incoming channel's
-		# encoding correctly.  iso8859-1 is the RFC default, but
-		# this could be any IANA charset.  However, we only know
-		# how to convert what we have encodings for.
+		# If we are getting text, set the incoming channel's encoding
+		# correctly. iso8859-1 is the RFC default, but this could be
+		# any IANA charset. However, we only know how to convert what
+		# we have encodings for.
 		set idx [lsearch -exact $encodings \
 			[string tolower $state(charset)]]
 		if {$idx >= 0} {
@@ -855,16 +958,15 @@ proc http::wait {token} {
 
 # http::formatQuery --
 #
-#	See documentaion for details.
-#	Call http::formatQuery with an even number of arguments, where 
-#	the first is a name, the second is a value, the third is another 
-#	name, and so on.
+#	See documentaion for details. Call http::formatQuery with an even
+#	number of arguments, where the first is a name, the second is a value,
+#	the third is another name, and so on.
 #
 # Arguments:
 #	args	A list of name-value pairs.
 #
 # Results:
-#        TODO
+#	TODO
 
 proc http::formatQuery {args} {
     set result ""
@@ -894,9 +996,9 @@ proc http::mapReply {string} {
     variable http
     variable formMap
 
-    # The spec says: "non-alphanumeric characters are replaced by '%HH'"
-    # Use a pre-computed map and [string map] to do the conversion
-    # (much faster than [regsub]/[subst]). [Bug 1020491]
+    # The spec says: "non-alphanumeric characters are replaced by '%HH'". Use
+    # a pre-computed map and [string map] to do the conversion (much faster
+    # than [regsub]/[subst]). [Bug 1020491]
 
     if {$http(-urlencoding) ne ""} {
 	set string [encoding convertto $http(-urlencoding) $string]
@@ -913,7 +1015,7 @@ proc http::mapReply {string} {
 }
 
 # http::ProxyRequired --
-#	Default proxy filter. 
+#	Default proxy filter.
 #
 # Arguments:
 #	host	The destination host
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
-- 
cgit v0.12