summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
authordkf <donal.k.fellows@manchester.ac.uk>2005-01-06 11:15:18 (GMT)
committerdkf <donal.k.fellows@manchester.ac.uk>2005-01-06 11:15:18 (GMT)
commit6486719f0c7028711902d98c299289de759010d7 (patch)
tree1b84f0755837fee40d4de39a39422f42a6eca152
parentc73ac088fcee2f6300273f60c4cfcbd1d6230162 (diff)
downloadtcl-6486719f0c7028711902d98c299289de759010d7.zip
tcl-6486719f0c7028711902d98c299289de759010d7.tar.gz
tcl-6486719f0c7028711902d98c299289de759010d7.tar.bz2
Performance updates to http::mapReply [1020491] and fix version numbering.
-rw-r--r--ChangeLog6
-rw-r--r--library/http/http.tcl44
-rw-r--r--library/http/pkgIndex.tcl4
-rw-r--r--unix/Makefile.in6
-rw-r--r--win/Makefile.in6
5 files changed, 34 insertions, 32 deletions
diff --git a/ChangeLog b/ChangeLog
index a0f9539..e76a18b 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>
* doc/lsearch.n, doc/re_syntax.n: Convert to other form of emacs
diff --git a/library/http/http.tcl b/library/http/http.tcl
index 29662a4..9baeef4 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.48 2004/05/25 22:56:33 hobbs Exp $
+# RCS: @(#) $Id: http.tcl,v 1.49 2005/01/06 11:15:21 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}}}]
diff --git a/unix/Makefile.in b/unix/Makefile.in
index d5cecd5..1979184 100644
--- a/unix/Makefile.in
+++ b/unix/Makefile.in
@@ -5,7 +5,7 @@
# "autoconf" program (constructs like "@foo@" will get replaced in the
# actual Makefile.
#
-# RCS: @(#) $Id: Makefile.in,v 1.159 2004/12/29 20:57:30 kennykb Exp $
+# RCS: @(#) $Id: Makefile.in,v 1.160 2005/01/06 11:15:21 dkf Exp $
VERSION = @TCL_VERSION@
MAJOR_VERSION = @TCL_MAJOR_VERSION@
@@ -665,8 +665,8 @@ install-libraries: libraries install-tzdata install-msgs
do \
$(INSTALL_DATA) $$j $(SCRIPT_INSTALL_DIR)/http1.0; \
done;
- @echo "Installing package http 2.5.0 as a Tcl Module";
- @$(INSTALL_DATA) $(TOP_DIR)/library/http/http.tcl $(SCRIPT_INSTALL_DIR)/../tcl8/8.2/http-2.5.0.tm;
+ @echo "Installing package http 2.5.1 as a Tcl Module";
+ @$(INSTALL_DATA) $(TOP_DIR)/library/http/http.tcl $(SCRIPT_INSTALL_DIR)/../tcl8/8.2/http-2.5.1.tm;
@echo "Installing library opt0.4 directory";
@for j in $(TOP_DIR)/library/opt/*.tcl ; \
do \
diff --git a/win/Makefile.in b/win/Makefile.in
index a4187de..4a25f8f 100644
--- a/win/Makefile.in
+++ b/win/Makefile.in
@@ -5,7 +5,7 @@
# "autoconf" program (constructs like "@foo@" will get replaced in the
# actual Makefile.
#
-# RCS: @(#) $Id: Makefile.in,v 1.86 2004/12/29 20:57:30 kennykb Exp $
+# RCS: @(#) $Id: Makefile.in,v 1.87 2005/01/06 11:15:22 dkf Exp $
VERSION = @TCL_VERSION@
@@ -560,8 +560,8 @@ install-libraries: libraries install-tzdata install-msgs
do \
$(COPY) "$$j" "$(SCRIPT_INSTALL_DIR)/http1.0"; \
done;
- @echo "Installing package http 2.5.0 as a Tcl Module";
- @$(COPY) $(ROOT_DIR)/library/http/http.tcl $(SCRIPT_INSTALL_DIR)/../tcl8/8.2/http-2.5.0.tm;
+ @echo "Installing package http 2.5.1 as a Tcl Module";
+ @$(COPY) $(ROOT_DIR)/library/http/http.tcl $(SCRIPT_INSTALL_DIR)/../tcl8/8.2/http-2.5.1.tm;
@echo "Installing library opt0.4 directory";
@for j in $(ROOT_DIR)/library/opt/*.tcl; \
do \