* library/http/http.tcl (http::geturl): only do geturl url rfc

	3986 validity checking if $::http::strict is true (default true
	for 8.5).  [Bug 1560506]

2 files changed, 12 insertions, 4 deletions

diff --git a/ChangeLog b/ChangeLog
index f9e4859..3c1bb71 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -5,6 +5,10 @@
 
 2006-10-05  Jeff Hobbs  <jeffh@ActiveState.com>
 
+	* library/http/http.tcl (http::geturl): only do geturl url rfc
+	3986 validity checking if $::http::strict is true (default true
+	for 8.5).  [Bug 1560506]
+
 	* generic/tcl.h: note limitation on changing Tcl_UniChar size
 	* generic/tclEncoding.c (UtfToUnicodeProc, UnicodeToUtfProc): 
 	* tests/encoding.test (encoding-16.1): fix alignment issues in
diff --git a/library/http/http.tcl b/library/http/http.tcl
index 1e5818a..a685c8c 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.58 2006/09/16 00:19:41 hobbs Exp $
+# RCS: @(#) $Id: http.tcl,v 1.59 2006/10/06 05:57:21 hobbs Exp $
 
 # Rough version history:
 # 1.0	Old http_get interface.
@@ -64,6 +64,9 @@ namespace eval http {
     # This can be changed, but iso8859-1 is the RFC standard.
     variable defaultCharset "iso8859-1"
 
+    # Force RFC 3986 strictness in geturl url verification?
+    variable strict 1
+
     namespace export geturl config reset wait formatQuery register unregister
     # Useful, but not exported: data size status code
 }
@@ -223,6 +226,7 @@ proc http::geturl { url args } {
     variable http
     variable urlTypes
     variable defaultCharset
+    variable strict
 
     # Initialize the state variable, an array. We'll return the name of this
     # array as the token for the transaction.
@@ -330,6 +334,7 @@ proc http::geturl { url args } {
     #
     # 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 done if $::http::strict is true (default 0 for compat).
 
     set URLmatcher {(?x)		# this is _expanded_ syntax
 	^
@@ -375,7 +380,7 @@ proc http::geturl { url args } {
 	    (?: [-\w.~!$&'()*+,;=:] | %[0-9a-f][0-9a-f] )+
 	    $
 	}
-	if {![regexp -- $validityRE $user]} {
+	if {$strict && ![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]} {
@@ -395,7 +400,7 @@ proc http::geturl { url args } {
 	    (?: \? (?: [-\w.~!$&'()*+,;=:@/?] | %[0-9a-f][0-9a-f] )* )?
 	    $
 	}
-	if {![regexp -- $validityRE $srvurl]} {
+	if {$strict && ![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]} {
@@ -409,7 +414,6 @@ proc http::geturl { url args } {
     }
     if {[string length $proto] == 0} {
 	set proto http
-	set url ${proto}:$url
     }
     if {![info exists urlTypes($proto)]} {
 	unset $token