summaryrefslogtreecommitdiffstats
path: root/library/http/http.tcl
diff options
context:
space:
mode:
authorhobbs <hobbs>2006-10-06 05:56:47 (GMT)
committerhobbs <hobbs>2006-10-06 05:56:47 (GMT)
commit68b8be49f5771f747c9b416de6b11f386fdbb8fa (patch)
treeaec791cea1553d2bdfd29bff41cdbb7b32825444 /library/http/http.tcl
parentc85fa02a0669f2ecbfb370f2a8babb29a2e007ac (diff)
downloadtcl-68b8be49f5771f747c9b416de6b11f386fdbb8fa.zip
tcl-68b8be49f5771f747c9b416de6b11f386fdbb8fa.tar.gz
tcl-68b8be49f5771f747c9b416de6b11f386fdbb8fa.tar.bz2
* 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]
Diffstat (limited to 'library/http/http.tcl')
-rw-r--r--library/http/http.tcl12
1 files changed, 8 insertions, 4 deletions
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