summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
-rw-r--r--ChangeLog6
-rw-r--r--library/http/http.tcl44
-rw-r--r--library/http/pkgIndex.tcl4
3 files changed, 28 insertions, 26 deletions
diff --git a/ChangeLog b/ChangeLog
index 96ab508..e4796c3 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,9 @@
+2005-01-06 Donal K. Fellows <donal.k.fellows@man.ac.uk>
+
+ * library/http/http.tcl (http::mapReply): Significant performance
+ enhancement by using [string map] instead of [regsub]/[subst], and
+ update version requirement to Tcl8.4. [Bug 1020491]
+
2005-01-05 Donal K. Fellows <donal.k.fellows@man.ac.uk>
* unix/tclUnixInit.c (localeTable): Add encoding mappings for some
diff --git a/library/http/http.tcl b/library/http/http.tcl
index ae2b1d4..3afa0e6 100644
--- a/library/http/http.tcl
+++ b/library/http/http.tcl
@@ -9,7 +9,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.4 2004/05/25 22:50:47 hobbs Exp $
+# RCS: @(#) $Id: http.tcl,v 1.43.2.5 2005/01/06 11:34:20 dkf Exp $
# Rough version history:
# 1.0 Old http_get interface
@@ -22,10 +22,10 @@
# 2.4 Added -binary option to http::geturl and charset element
# to the state array.
-package require Tcl 8.2
+package require Tcl 8.4
# keep this in sync with pkgIndex.tcl
# and with the install directories in Makefiles
-package provide http 2.5.0
+package provide http 2.5.1
namespace eval http {
variable http
@@ -39,16 +39,17 @@ namespace eval http {
set http(-useragent) "Tcl http client package [package provide http]"
proc init {} {
- variable formMap
- variable alphanumeric a-zA-Z0-9
+ # Set up the map for quoting chars
+ # The spec says: "non-alphanumeric characters are replaced by '%HH'"
for {set i 0} {$i <= 256} {incr i} {
set c [format %c $i]
- if {![string match \[$alphanumeric\] $c]} {
- set formMap($c) %[format %.2x $i]
+ if {![string match {[a-zA-Z0-9]} $c]} {
+ set map($c) %[format %.2x $i]
}
}
# These are handled specially
- array set formMap { " " + \n %0d%0a }
+ array set map { " " + \n %0d%0a }
+ variable formMap [array get map]
}
init
@@ -368,7 +369,7 @@ proc http::geturl { url args } {
fileevent $s writable [list http::Connect $token]
http::wait $token
- if {[string equal $state(status) "error"]} {
+ if {$state(status) eq "error"} {
# something went wrong while trying to establish the connection
# Clean up after events and such, but DON'T call the command
# callback (if available) because we're going to throw an
@@ -376,7 +377,7 @@ proc http::geturl { url args } {
set err [lindex $state(error) 0]
cleanup $token
return -code error $err
- } elseif {![string equal $state(status) "connect"]} {
+ } elseif {$state(status) ne "connect"} {
# Likely to be connection timeout
return $token
}
@@ -426,7 +427,7 @@ proc http::geturl { url args } {
foreach {key value} $state(-headers) {
set value [string map [list \n "" \r ""] $value]
set key [string trim $key]
- if {[string equal $key "Content-Length"]} {
+ if {$key eq "Content-Length"} {
set contDone 1
set state(querylength) $value
}
@@ -482,7 +483,7 @@ proc http::geturl { url args } {
# calls it synchronously, we just do a wait here.
wait $token
- if {[string equal $state(status) "error"]} {
+ if {$state(status) eq "error"} {
# Something went wrong, so throw the exception, and the
# enclosing catch will do cleanup.
return -code error [lindex $state(error) 0]
@@ -498,7 +499,7 @@ proc http::geturl { url args } {
# if state(status) is error, it means someone's already called Finish
# to do the above-described clean up.
- if {[string equal $state(status) "error"]} {
+ if {$state(status) eq "error"} {
Finish $token $err 1
}
cleanup $token
@@ -678,7 +679,7 @@ proc http::Event {token} {
Eof $token
return
}
- if {[string equal $state(state) "header"]} {
+ if {$state(state) eq "header"} {
if {[catch {gets $s line} n]} {
Finish $token $n
} elseif {$n == 0} {
@@ -816,7 +817,7 @@ proc http::CopyDone {token count {error {}}} {
proc http::Eof {token} {
variable $token
upvar 0 $token state
- if {[string equal $state(state) "header"]} {
+ if {$state(state) eq "header"} {
# Premature eof
set state(status) eof
} else {
@@ -866,7 +867,7 @@ proc http::formatQuery {args} {
set sep ""
foreach i $args {
append result $sep [mapReply $i]
- if {[string equal $sep "="]} {
+ if {$sep eq "="} {
set sep &
} else {
set sep =
@@ -888,20 +889,15 @@ proc http::formatQuery {args} {
proc http::mapReply {string} {
variable http
variable formMap
- variable alphanumeric
# The spec says: "non-alphanumeric characters are replaced by '%HH'"
- # 1 leave alphanumerics characters alone
- # 2 Convert every other character to an array lookup
- # 3 Escape constructs that are "special" to the tcl parser
- # 4 "subst" the result, doing all the array substitutions
+ # Use a pre-computed map and [string map] to do the conversion
+ # (much faster than [regsub]/[subst]). [Bug 1020491]
if {$http(-urlencoding) ne ""} {
set string [encoding convertto $http(-urlencoding) $string]
}
- regsub -all \[^$alphanumeric\] $string {$formMap(&)} string
- regsub -all {[][{})\\]\)} $string {\\&} string
- return [subst -nocommand $string]
+ return [string map $formMap $string]
}
# http::ProxyRequired --
diff --git a/library/http/pkgIndex.tcl b/library/http/pkgIndex.tcl
index 8efa64c..c937b60 100644
--- a/library/http/pkgIndex.tcl
+++ b/library/http/pkgIndex.tcl
@@ -8,5 +8,5 @@
# script is sourced, the variable $dir must contain the
# full path name of this file's directory.
-if {![package vsatisfies [package provide Tcl] 8.2]} {return}
-package ifneeded http 2.5.0 [list tclPkgSetup $dir http 2.5.0 {{http.tcl source {::http::config ::http::formatQuery ::http::geturl ::http::reset ::http::wait ::http::register ::http::unregister}}}]
+if {![package vsatisfies [package provide Tcl] 8.4]} {return}
+package ifneeded http 2.5.1 [list tclPkgSetup $dir http 2.5.1 {{http.tcl source {::http::config ::http::formatQuery ::http::geturl ::http::reset ::http::wait ::http::register ::http::unregister}}}]