From abeb1a6a1e7d636379b0071d7a33a4395b6ec707 Mon Sep 17 00:00:00 2001
From: max <max@tclers.tk>
Date: Sun, 8 Jul 2012 10:55:49 +0000
Subject: Add fix and test for URLs that contain literal IPv6 addresses. [Bug
 3531209]

---
 ChangeLog             | 5 +++++
 library/http/http.tcl | 7 +++++--
 tests/http.test       | 7 +++++++
 3 files changed, 17 insertions(+), 2 deletions(-)

diff --git a/ChangeLog b/ChangeLog
index 72c588d..68e7f70 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,8 @@
+2012-07-08  Reinhard Max  <max@suse.de>
+
+	* library/http/http.tcl: Add fix and test for URLs that contain
+	* tests/http.test: 	 literal IPv6 addresses. [Bug 3531209]
+
 2012-07-05  Don Porter  <dgp@users.sourceforge.net>
 
 	* unix/tclUnixPipe.c:	[Bug 1189293] Make "<<" binary safe.
diff --git a/library/http/http.tcl b/library/http/http.tcl
index b5ce82b..2653c3e 100644
--- a/library/http/http.tcl
+++ b/library/http/http.tcl
@@ -419,7 +419,6 @@ proc http::geturl {url args} {
     # 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.  This is only
@@ -434,7 +433,10 @@ proc http::geturl {url args} {
 		    [^@/\#?]+		# <userinfo part of authority>
 		) @
 	    )?
-	    ( [^/:\#?]+ )		# <host part of authority>
+	    (				# <host part of authority>
+		[^/:\#?]+ |		# host name or IPv4 address
+		\[ [^/\#?]+ \]		# IPv6 address in square brackets
+	    )
 	    (?: : (\d+) )?		# <port part of authority>
 	)?
 	( / [^\#]*)?			# <path> (including query)
@@ -448,6 +450,7 @@ proc http::geturl {url args} {
 	return -code error "Unsupported URL: $url"
     }
     # Phase two: validate
+    set host [string trim $host {[]}]; # strip square brackets from IPv6 address
     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.
diff --git a/tests/http.test b/tests/http.test
index 37d4a05..fe44b47 100644
--- a/tests/http.test
+++ b/tests/http.test
@@ -135,6 +135,7 @@ 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 ipv6url http://\[::1\]:$port/
 test http-3.4 {http::geturl} -body {
     set token [http::geturl $url]
     http::data $token
@@ -390,6 +391,12 @@ Connection close
 Content-Type {text/plain;charset=utf-8}
 Accept-Encoding .*
 Content-Length 5}
+test http-3.29 "http::geturl $ipv6url" -body {
+    set token [http::geturl $ipv6url -validate 1]
+    http::code $token
+} -cleanup {
+    http::cleanup $token
+} -result "HTTP/1.0 200 OK"
 
 test http-4.1 {http::Event} -body {
     set token [http::geturl $url -keepalive 0]
-- 
cgit v0.12