From 4d8ccb4db88d7ce2ba04cdf1425f5373177a132f Mon Sep 17 00:00:00 2001
From: dkf <donal.k.fellows@manchester.ac.uk>
Date: Fri, 18 Nov 2005 14:51:02 +0000
Subject: Fix silly errors in REs, in variables, and in tests that were working
 with invalid URLs.

---
 library/http/http.tcl | 16 ++++++++--------
 tests/http.test       | 22 +++++++++++-----------
 2 files changed, 19 insertions(+), 19 deletions(-)

diff --git a/library/http/http.tcl b/library/http/http.tcl
index c8dbe9b..f43dd1b 100644
--- a/library/http/http.tcl
+++ b/library/http/http.tcl
@@ -8,7 +8,7 @@
 # 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.54 2005/11/18 13:57:53 dkf Exp $
+# RCS: @(#) $Id: http.tcl,v 1.55 2005/11/18 14:51:02 dkf Exp $
 
 # Rough version history:
 # 1.0	Old http_get interface.
@@ -333,7 +333,7 @@ proc http::geturl { url args } {
 
     set URLmatcher {(?x)		# this is _expanded_ syntax
 	^
-	(?: (\w+) : )			# <protocol scheme>
+	(?: (\w+) : ) ?			# <protocol scheme>
 	(?: //
 	    (?:
 		(
@@ -343,7 +343,7 @@ proc http::geturl { url args } {
 	    ( [^/:\#?]+ )		# <host part of authority>
 	    (?: : (\d+) )?		# <port part of authority>
 	)?
-	( / [^\#?]* (?: \? [^\#?]* ) )?	# <path> (including query)
+	( / [^\#?]* (?: \? [^\#?]* )?)?	# <path> (including query)
 	(?: \# (.*) )?			# <fragment>
 	$
     }
@@ -372,13 +372,13 @@ proc http::geturl { url args } {
 	# Check for validity according to RFC 3986, Appendix A
 	set validityRE {(?xi)
 	    ^
-	    (?: [\w-.~!$&'()*+,;=:] | %[0-9a-f][0-9a-f] )+
+	    (?: [-\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]).?.?} $path bad]} {
+	    if {[regexp {(?i)%(?![0-9a-f][0-9a-f]).?.?} $user bad]} {
 		return -code error \
 			"Illegal encoding character usage \"$bad\" in URL user"
 	    }
@@ -390,15 +390,15 @@ proc http::geturl { url args } {
 	set validityRE {(?xi)
 	    ^
 	    # Path part (already must start with / character)
-	    (?:	      [\w-.~!$&'()*+,;=:@/]  | %[0-9a-f][0-9a-f] )*
+	    (?:	      [-\w.~!$&'()*+,;=:@/]  | %[0-9a-f][0-9a-f] )*
 	    # Query part (optional, permits ? characters)
-	    (?: ? (?: [\w-.~!$&'()*+,;=:@/?] | %[0-9a-f][0-9a-f] )* )?
+	    (?: \? (?: [-\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])..} $path bad]} {
+	    if {[regexp {(?i)%(?![0-9a-f][0-9a-f])..} $srvurl bad]} {
 		return -code error \
 			"Illegal encoding character usage \"$bad\" in URL path"
 	    }
diff --git a/tests/http.test b/tests/http.test
index fda00b9..b7d618c 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.40 2005/11/18 13:57:53 dkf Exp $
+# RCS: @(#) $Id: http.test,v 1.41 2005/11/18 14:51:02 dkf Exp $
 
 if {[lsearch [namespace children] ::tcltest] == -1} {
     package require tcltest 2
@@ -122,8 +122,8 @@ 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
@@ -132,11 +132,11 @@ test http-3.3 {http::geturl} {
 <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 +155,7 @@ 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
@@ -381,7 +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} {
@@ -453,7 +453,7 @@ 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]
@@ -488,7 +488,7 @@ 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} {
-- 
cgit v0.12