From 6379f60ed8aca0d3ce1aa00314d5249bf6da6f86 Mon Sep 17 00:00:00 2001
From: "jan.nijtmans" <nijtmans@users.sourceforge.net>
Date: Tue, 9 Apr 2013 11:04:49 +0000
Subject: Allow URLs that don't have a path, but a query, e.g.
 http://example.com?foo=bar and bump http to 2.5.8.

---
 ChangeLog                 |  6 ++++++
 library/http/http.tcl     | 10 ++++++++--
 library/http/pkgIndex.tcl |  2 +-
 tests/http.test           | 14 ++++++++++++++
 4 files changed, 29 insertions(+), 3 deletions(-)

diff --git a/ChangeLog b/ChangeLog
index 0f06e8d..2d39e97 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,9 @@
+2013-04-09  Reinhard Max  <max@suse.de>
+
+	* library/http/http.tcl (http::geturl): Allow URLs that don't have
+	a path, but a query query, e.g. http://example.com?foo=bar .
+	* Bump the http package to 2.5.8.
+
 2013-04-08  Don Porter  <dgp@users.sourceforge.net>
 
 	* generic/regc_color.c:	[Bug 3610026] Stop crash when the number of
diff --git a/library/http/http.tcl b/library/http/http.tcl
index ceef043..6299523 100644
--- a/library/http/http.tcl
+++ b/library/http/http.tcl
@@ -22,7 +22,7 @@
 package require Tcl 8.4
 # Keep this in sync with pkgIndex.tcl and with the install directories
 # in Makefiles
-package provide http 2.5.7
+package provide http 2.5.8
 
 namespace eval http {
     variable http
@@ -346,7 +346,7 @@ proc http::geturl { url args } {
 	    ( [^/:\#?]+ )		# <host part of authority>
 	    (?: : (\d+) )?		# <port part of authority>
 	)?
-	( / [^\#?]* (?: \? [^\#?]* )?)?	# <path> (including query)
+	( [/\?] [^\#]*)?		# <path> (including query)
 	(?: \# (.*) )?			# <fragment>
 	$
     }
@@ -389,6 +389,12 @@ proc http::geturl { url args } {
 	}
     }
     if {$srvurl ne ""} {
+	# RFC 3986 allows empty paths (not even a /), but servers
+	# return 400 if the path in the HTTP request doesn't start
+	# with / , so add it here if needed.
+	if {[string index $srvurl 0] ne "/"} {
+	    set srvurl /$srvurl
+	}
 	# Check for validity according to RFC 3986, Appendix A
 	set validityRE {(?xi)
 	    ^
diff --git a/library/http/pkgIndex.tcl b/library/http/pkgIndex.tcl
index c5d2928..9bbec0a 100644
--- a/library/http/pkgIndex.tcl
+++ b/library/http/pkgIndex.tcl
@@ -9,4 +9,4 @@
 # full path name of this file's directory.
 
 if {![package vsatisfies [package provide Tcl] 8.4]} {return}
-package ifneeded http 2.5.7 [list tclPkgSetup $dir http 2.5.7 {{http.tcl source {::http::config ::http::formatQuery ::http::geturl ::http::reset ::http::wait ::http::register ::http::unregister ::http::mapReply}}}]
+package ifneeded http 2.5.8 [list tclPkgSetup $dir http 2.5.8 {{http.tcl source {::http::config ::http::formatQuery ::http::geturl ::http::reset ::http::wait ::http::register ::http::unregister ::http::mapReply}}}]
diff --git a/tests/http.test b/tests/http.test
index 54fa369..7e40b82 100644
--- a/tests/http.test
+++ b/tests/http.test
@@ -135,6 +135,7 @@ set binurl //[info hostname]:$port/binary
 set posturl //[info hostname]:$port/post
 set badposturl //[info hostname]:$port/droppost
 set badcharurl //%user@[info hostname]:$port/a/^b/c
+set authorityurl //[info hostname]:$port
 
 test http-3.4 {http::geturl} {
     set token [http::geturl $url]
@@ -340,6 +341,19 @@ test http-3.25 {http::geturl parse failures} -body {
     set token [http::geturl $badcharurl]
     http::cleanup $token
 } -returnCodes ok -result {}
+test http-3.30 {http::geturl query without path} -body {
+    set token [http::geturl $authorityurl?var=val]
+    http::ncode $token
+} -cleanup {
+    catch { http::cleanup $token }
+} -result 200
+test http-3.31 {http::geturl fragment without path} -body {
+    set token [http::geturl "$authorityurl#fragment42"]
+    http::ncode $token
+} -cleanup {
+    catch { http::cleanup $token }
+} -result 200
+
 
 test http-4.1 {http::Event} {
     set token [http::geturl $url]
-- 
cgit v0.12