From bcc122b2173cb539c383aef7fa7ea0e3731503a3 Mon Sep 17 00:00:00 2001
From: hobbs <hobbs>
Date: Fri, 6 Oct 2006 05:56:47 +0000
Subject: * library/http/http.tcl (http::geturl): only do geturl url rfc
3986 validity checking if $::http::strict is true (default false
for 8.5). [Bug 1560506]
---
ChangeLog | 4 ++++
library/http/http.tcl | 12 ++++++++----
2 files changed, 12 insertions(+), 4 deletions(-)
diff --git a/ChangeLog b/ChangeLog
index 5331add..efb0ed6 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,5 +1,9 @@
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 false
+ 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 1a79ceb..c412f6e 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.43.2.12 2006/09/15 19:53:33 hobbs Exp $
+# RCS: @(#) $Id: http.tcl,v 1.43.2.13 2006/10/06 05:56:48 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? Not for 8.4.x
+ variable strict 0
+
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
--
cgit v0.12