Fix performance nasty in http::mapReply [1020491] and clean up version numbers.

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}}}]