Clean up http tokens properly.

2 files changed, 167 insertions, 107 deletions

diff --git a/ChangeLog b/ChangeLog
index 4620b9f..a597ccc 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,8 @@
+2009-09-11  Donal K. Fellows  <dkf@users.sf.net>
+
+	* tests/http.test: Added in cleaning up of http tokens for each test
+	to reduce amount of global-variable pollution.
+
 2009-09-10  Donal K. Fellows  <dkf@users.sf.net>
 
 	* library/http/http.tcl (http::Event): [Bug 2849860]: Handle charset
diff --git a/tests/http.test b/tests/http.test
index 2516a48..a62f1c1 100644
--- a/tests/http.test
+++ b/tests/http.test
@@ -1,23 +1,20 @@
 # Commands covered:  http::config, http::geturl, http::wait, http::reset
 #
 # This file contains a collection of tests for the http script library.
-# Sourcing this file into Tcl runs the tests and
-# generates output for errors.  No output means no errors were found.
+# Sourcing this file into Tcl runs the tests and generates output for errors.
+# No output means no errors were found.
 #
 # Copyright (c) 1991-1993 The Regents of the University of California.
 # Copyright (c) 1994-1996 Sun Microsystems, Inc.
 # Copyright (c) 1998-2000 by Ajuba Solutions.
 #
-# See the file "license.terms" for information on usage and redistribution
-# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+# See the file "license.terms" for information on usage and redistribution of
+# this file, and for a DISCLAIMER OF ALL WARRANTIES.
 #
-#
-# RCS: @(#) $Id: http.test,v 1.53 2009/06/24 15:17:40 dgp Exp $
+# RCS: @(#) $Id: http.test,v 1.54 2009/09/11 15:45:19 dkf Exp $
 
-if {[lsearch [namespace children] ::tcltest] == -1} {
-    package require tcltest 2
-    namespace import -force ::tcltest::*
-}
+package require tcltest 2
+namespace import -force ::tcltest::*
 
 if {[catch {package require http 2} version]} {
     if {[info exists http2]} {
@@ -81,7 +78,7 @@ if {[info commands testthread] == "testthread" && [file exists $httpdFile]} {
 	set port [lindex [fconfigure $listen -sockname] 2]
     }
 }
-
+
 test http-1.1 {http::config} {
     http::config -useragent UserAgent
     http::config
@@ -101,34 +98,37 @@ test http-1.4 {http::config} {
     http::config {*}$savedconf
     set x
 } {-accept */* -proxyfilter myFilter -proxyhost nowhere.come -proxyport 8080 -urlencoding iso8859-1 -useragent {Tcl Test Suite}}
-test http-1.5 {http::config} {
-    list [catch {http::config -proxyhost {} -junk 8080} msg] $msg
-} {1 {Unknown option -junk, must be: -accept, -proxyfilter, -proxyhost, -proxyport, -urlencoding, -useragent}}
-test http-1.6 {http::config} {
+test http-1.5 {http::config} -returnCodes error -body {
+    http::config -proxyhost {} -junk 8080
+} -result {Unknown option -junk, must be: -accept, -proxyfilter, -proxyhost, -proxyport, -urlencoding, -useragent}
+test http-1.6 {http::config} -setup {
+    set oldenc [http::config -urlencoding]
+} -body {
     set enc [list [http::config -urlencoding]]
     http::config -urlencoding iso8859-1
     lappend enc [http::config -urlencoding]
-    http::config -urlencoding [lindex $enc 0]
-    set enc
-} {utf-8 iso8859-1}
+} -cleanup {
+    http::config -urlencoding $oldenc
+} -result {utf-8 iso8859-1}
 
 test http-2.1 {http::reset} {
     catch {http::reset http#1}
 } 0
 
-test http-3.1 {http::geturl} {
-    list [catch {http::geturl -bogus flag} msg] $msg
-} {1 {Unknown option flag, can be: -binary, -blocksize, -channel, -command, -handler, -headers, -keepalive, -method, -myaddr, -progress, -protocol, -query, -queryblocksize, -querychannel, -queryprogress, -strict, -timeout, -type, -validate}}
-test http-3.2 {http::geturl} {
-    catch {http::geturl http:junk} err
-    set err
-} {Unsupported URL: http:junk}
+test http-3.1 {http::geturl} -returnCodes error -body {
+    http::geturl -bogus flag
+} -result {Unknown option flag, can be: -binary, -blocksize, -channel, -command, -handler, -headers, -keepalive, -method, -myaddr, -progress, -protocol, -query, -queryblocksize, -querychannel, -queryprogress, -strict, -timeout, -type, -validate}
+test http-3.2 {http::geturl} -returnCodes error -body {
+    http::geturl http:junk
+} -result {Unsupported URL: http:junk}
 set url //[info hostname]:$port
 set badurl //[info hostname]:6666
-test http-3.3 {http::geturl} {
+test http-3.3 {http::geturl} -body {
     set token [http::geturl $url]
     http::data $token
-} "<html><head><title>HTTP/1.0 TEST</title></head><body>
+} -cleanup {
+    http::cleanup $token
+} -result "<html><head><title>HTTP/1.0 TEST</title></head><body>
 <h1>Hello, World!</h1>
 <h2>GET /</h2>
 </body></html>"
@@ -138,10 +138,12 @@ set fullurl http://user:pass@[info hostname]:$port/a/b/c
 set binurl //[info hostname]:$port/binary
 set posturl //[info hostname]:$port/post
 set badposturl //[info hostname]:$port/droppost
-test http-3.4 {http::geturl} {
+test http-3.4 {http::geturl} -body {
     set token [http::geturl $url]
     http::data $token
-} "<html><head><title>HTTP/1.0 TEST</title></head><body>
+} -cleanup {
+    http::cleanup $token
+} -result "<html><head><title>HTTP/1.0 TEST</title></head><body>
 <h1>Hello, World!</h1>
 <h2>GET $tail</h2>
 </body></html>"
@@ -149,35 +151,43 @@ proc selfproxy {host} {
     global port
     return [list [info hostname] $port]
 }
-test http-3.5 {http::geturl} {
+test http-3.5 {http::geturl} -body {
     http::config -proxyfilter selfproxy
     set token [http::geturl $url]
-    http::config -proxyfilter http::ProxyRequired
     http::data $token
-} "<html><head><title>HTTP/1.0 TEST</title></head><body>
+} -cleanup {
+    http::config -proxyfilter http::ProxyRequired
+    http::cleanup $token
+} -result "<html><head><title>HTTP/1.0 TEST</title></head><body>
 <h1>Hello, World!</h1>
 <h2>GET http:$url</h2>
 </body></html>"
-test http-3.6 {http::geturl} {
+test http-3.6 {http::geturl} -body {
     http::config -proxyfilter bogus
     set token [http::geturl $url]
-    http::config -proxyfilter http::ProxyRequired
     http::data $token
-} "<html><head><title>HTTP/1.0 TEST</title></head><body>
+} -cleanup {
+    http::config -proxyfilter http::ProxyRequired
+    http::cleanup $token
+} -result "<html><head><title>HTTP/1.0 TEST</title></head><body>
 <h1>Hello, World!</h1>
 <h2>GET $tail</h2>
 </body></html>"
-test http-3.7 {http::geturl} {
+test http-3.7 {http::geturl} -body {
     set token [http::geturl $url -headers {Pragma no-cache}]
     http::data $token
-} "<html><head><title>HTTP/1.0 TEST</title></head><body>
+} -cleanup {
+    http::cleanup $token
+} -result "<html><head><title>HTTP/1.0 TEST</title></head><body>
 <h1>Hello, World!</h1>
 <h2>GET $tail</h2>
 </body></html>"
-test http-3.8 {http::geturl} {
+test http-3.8 {http::geturl} -body {
     set token [http::geturl $url -query Name=Value&Foo=Bar -timeout 2000]
     http::data $token
-} "<html><head><title>HTTP/1.0 TEST</title></head><body>
+} -cleanup {
+    http::cleanup $token
+} -result "<html><head><title>HTTP/1.0 TEST</title></head><body>
 <h1>Hello, World!</h1>
 <h2>POST $tail</h2>
 <h2>Query</h2>
@@ -186,11 +196,13 @@ test http-3.8 {http::geturl} {
 <dt>Foo<dd>Bar
 </dl>
 </body></html>"
-test http-3.9 {http::geturl} {
+test http-3.9 {http::geturl} -body {
     set token [http::geturl $url -validate 1]
     http::code $token
-} "HTTP/1.0 200 OK"
-test http-3.10 {http::geturl queryprogress} {
+} -cleanup {
+    http::cleanup $token
+} -result "HTTP/1.0 200 OK"
+test http-3.10 {http::geturl queryprogress} -setup {
     set query foo=bar
     set sep ""
     set i 0
@@ -200,7 +212,7 @@ test http-3.10 {http::geturl queryprogress} {
 	append query $sep$query
 	set sep &
     }
-
+} -body {
     proc postProgress {token x y} {
 	global postProgress
 	lappend postProgress $y
@@ -210,8 +222,10 @@ test http-3.10 {http::geturl queryprogress} {
 	    -queryprogress postProgress -queryblocksize 16384]
     http::wait $t
     list [http::status $t] [string length $query] $postProgress [http::data $t]
-} {ok 122879 {16384 32768 49152 65536 81920 98304 114688 122879} {Got 122879 bytes}}
-test http-3.11 {http::geturl querychannel with -command} {
+} -cleanup {
+    http::cleanup $t
+} -result {ok 122879 {16384 32768 49152 65536 81920 98304 114688 122879} {Got 122879 bytes}}
+test http-3.11 {http::geturl querychannel with -command} -setup {
     set query foo=bar
     set sep ""
     set i 0
@@ -222,8 +236,8 @@ test http-3.11 {http::geturl querychannel with -command} {
 	set sep &
     }
     set file [makeFile $query outdata]
+} -body {
     set fp [open $file]
-
     proc asyncCB {token} {
 	global postResult
 	lappend postResult [http::data $token]
@@ -232,7 +246,6 @@ test http-3.11 {http::geturl querychannel with -command} {
     set t [http::geturl $posturl -querychannel $fp]
     http::wait $t
     set testRes [list [http::status $t] [string length $query] [http::data $t]]
-
     # Now do async
     http::cleanup $t
     close $fp
@@ -241,17 +254,17 @@ test http-3.11 {http::geturl querychannel with -command} {
     set postResult [list PostStart]
     http::wait $t
     close $fp
-
     lappend testRes [http::status $t] $postResult
+} -cleanup {
     removeFile outdata
-    set testRes
-} {ok 122879 {Got 122880 bytes} ok {PostStart {Got 122880 bytes}}}
+    http::cleanup $t
+} -result {ok 122879 {Got 122880 bytes} ok {PostStart {Got 122880 bytes}}}
 # On Linux platforms when the client and server are on the same host, the
 # client is unable to read the server's response one it hits the write error.
 # The status is "eof".
 # On Windows, the http::wait procedure gets a "connection reset by peer" error
 # while reading the reply.
-test http-3.12 {http::geturl querychannel with aborted request} {nonPortable} {
+test http-3.12 {http::geturl querychannel with aborted request} -setup {
     set query foo=bar
     set sep ""
     set i 0
@@ -262,8 +275,8 @@ test http-3.12 {http::geturl querychannel with aborted request} {nonPortable} {
 	set sep &
     }
     set file [makeFile $query outdata]
+} -constraints {nonPortable} -body {
     set fp [open $file]
-
     proc asyncCB {token} {
 	global postResult
 	lappend postResult [http::data $token]
@@ -284,10 +297,11 @@ test http-3.12 {http::geturl querychannel with aborted request} {nonPortable} {
 	puts $::errorInfo
 	error $err
     }
-
-    removeFile outdata
     list [http::status $t] [http::code $t]
-} {ok {HTTP/1.0 200 Data follows}}
+} -cleanup {
+    removeFile outdata
+    http::cleanup $t
+} -result {ok {HTTP/1.0 200 Data follows}}
 test http-3.13 {http::geturl socket leak test} {
     set chanCount [llength [file channels]]
     for {set i 0} {$i < 3} {incr i} {
@@ -297,10 +311,12 @@ test http-3.13 {http::geturl socket leak test} {
     # No extra channels should be taken
     expr {[llength [file channels]] == $chanCount}
 } 1
-test http-3.14 "http::geturl $fullurl" {
+test http-3.14 "http::geturl $fullurl" -body {
     set token [http::geturl $fullurl -validate 1]
     http::code $token
-} "HTTP/1.0 200 OK"
+} -cleanup {
+    http::cleanup $token
+} -result "HTTP/1.0 200 OK"
 test http-3.15 {http::geturl parse failures} -body {
     http::geturl "{invalid}:url"
 } -returnCodes error -result {Unsupported URL: {invalid}:url}
@@ -338,6 +354,7 @@ test http-3.25 {http::meta} -setup {
     array set m [http::meta $token]
     lsort [array names m]
 } -cleanup {
+    http::cleanup $token
     unset -nocomplain m token
 } -result {Content-Length Content-Type Date}
 test http-3.26 {http::meta} -setup {
@@ -347,61 +364,77 @@ test http-3.26 {http::meta} -setup {
     array set m [http::meta $token]
     lsort [array names m]
 } -cleanup {
+    http::cleanup $token
     unset -nocomplain m token
 } -result {Content-Length Content-Type Date X-Check}
 
-test http-4.1 {http::Event} {
+test http-4.1 {http::Event} -body {
     set token [http::geturl $url -keepalive 0]
     upvar #0 $token data
     array set meta $data(meta)
     expr {($data(totalsize) == $meta(Content-Length))}
-} 1
-test http-4.2 {http::Event} {
+} -cleanup {
+    http::cleanup $token
+} -result 1
+test http-4.2 {http::Event} -body {
     set token [http::geturl $url]
     upvar #0 $token data
     array set meta $data(meta)
     string compare $data(type) [string trim $meta(Content-Type)]
-} 0
-test http-4.3 {http::Event} {
+} -cleanup {
+    http::cleanup $token
+} -result 0
+test http-4.3 {http::Event} -body {
     set token [http::geturl $url]
     http::code $token
-} {HTTP/1.0 200 Data follows}
-test http-4.4 {http::Event} {
+} -cleanup {
+    http::cleanup $token
+} -result {HTTP/1.0 200 Data follows}
+test http-4.4 {http::Event} -setup {
     set testfile [makeFile "" testfile]
+} -body {
     set out [open $testfile w]
     set token [http::geturl $url -channel $out]
     close $out
     set in [open $testfile]
     set x [read $in]
-    close $in
+} -cleanup {
+    catch {close $in}
+    catch {close $out}
     removeFile $testfile
-    set x
-} "<html><head><title>HTTP/1.0 TEST</title></head><body>
+    http::cleanup $token
+} -result "<html><head><title>HTTP/1.0 TEST</title></head><body>
 <h1>Hello, World!</h1>
 <h2>GET $tail</h2>
 </body></html>"
-test http-4.5 {http::Event} {
+test http-4.5 {http::Event} -setup {
     set testfile [makeFile "" testfile]
+} -body {
     set out [open $testfile w]
     fconfigure $out -translation lf
     set token [http::geturl $url -channel $out]
     close $out
     upvar #0 $token data
-    removeFile $testfile
     expr {$data(currentsize) == $data(totalsize)}
-} 1
-test http-4.6 {http::Event} {
+} -cleanup {
+    removeFile $testfile
+    http::cleanup $token
+} -result 1
+test http-4.6 {http::Event} -setup {
     set testfile [makeFile "" testfile]
+} -body {
     set out [open $testfile w]
     set token [http::geturl $binurl -channel $out]
     close $out
     set in [open $testfile]
     fconfigure $in -translation binary
-    set x [read $in]
-    close $in
+    read $in
+} -cleanup {
+    catch {close $in}
+    catch {close $out}
     removeFile $testfile
-    set x
-} "$bindata[string trimleft $binurl /]"
+    http::cleanup $token
+} -result "$bindata[string trimleft $binurl /]"
 proc myProgress {token total current} {
     global progress httpLog
     if {[info exists httpLog] && $httpLog} {
@@ -414,46 +447,60 @@ if 0 {
     set httpLog 1
     test http-4.6.1 {http::Event} knownBug {
 	set token [http::geturl $url -blocksize 50 -progress myProgress]
-	set progress
+	return $progress
     } {111 111}
 }
-test http-4.7 {http::Event} {
+test http-4.7 {http::Event} -body {
     set token [http::geturl $url -keepalive 0 -progress myProgress]
-    set progress
-} {111 111}
-test http-4.8 {http::Event} {
+    return $progress
+} -cleanup {
+    http::cleanup $token
+} -result {111 111}
+test http-4.8 {http::Event} -body {
     set token [http::geturl $url]
     http::status $token
-} {ok}
-test http-4.9 {http::Event} {
+} -cleanup {
+    http::cleanup $token
+} -result {ok}
+test http-4.9 {http::Event} -body {
     set token [http::geturl $url -progress myProgress]
     http::code $token
-} {HTTP/1.0 200 Data follows}
-test http-4.10 {http::Event} {
+} -cleanup {
+    http::cleanup $token
+} -result {HTTP/1.0 200 Data follows}
+test http-4.10 {http::Event} -body {
     set token [http::geturl $url -progress myProgress]
     http::size $token
-} {111}
+} -cleanup {
+    http::cleanup $token
+} -result {111}
 # Timeout cases
 #	Short timeout to working server (the test server). This lets us try a
 #	reset during the connection.
-test http-4.11 {http::Event} {
-    set token [http::geturl $url -timeout 1 -keepalive 0 -command {#}]
+test http-4.11 {http::Event} -body {
+    set token [http::geturl $url -timeout 1 -keepalive 0 -command \#]
     http::reset $token
     http::status $token
-} {reset}
+} -cleanup {
+    http::cleanup $token
+} -result {reset}
 #	Longer timeout with reset.
-test http-4.12 {http::Event} {
-    set token [http::geturl $url/?timeout=10 -keepalive 0 -command {#}]
+test http-4.12 {http::Event} -body {
+    set token [http::geturl $url/?timeout=10 -keepalive 0 -command \#]
     http::reset $token
     http::status $token
-} {reset}
+} -cleanup {
+    http::cleanup $token
+} -result {reset}
 #	Medium timeout to working server that waits even longer. The timeout
 #	hits while waiting for a reply.
-test http-4.13 {http::Event} {
-    set token [http::geturl $url?timeout=30 -keepalive 0 -timeout 10 -command {#}]
+test http-4.13 {http::Event} -body {
+    set token [http::geturl $url?timeout=30 -keepalive 0 -timeout 10 -command \#]
     http::wait $token
     http::status $token
-} {timeout}
+} -cleanup {
+    http::cleanup $token
+} -result {timeout}
 #	Longer timeout to good host, bad port, gets an error after the
 #	connection "completes" but the socket is bad.
 test http-4.14 {http::Event} -body {
@@ -464,7 +511,9 @@ test http-4.14 {http::Event} -body {
     http::wait $token
     http::status $token
     # error code varies among platforms.
-} -returnCodes 1 -match regexp -result {(connect failed|couldn't open socket)}
+} -returnCodes 1 -match regexp -cleanup {
+    catch {http::cleanup $token}
+} -result {(connect failed|couldn't open socket)}
 # Bogus host
 test http-4.15 {http::Event} -body {
     # This test may fail if you use a proxy server. That is to be
@@ -473,6 +522,8 @@ test http-4.15 {http::Event} -body {
     http::wait $token
     http::status $token
     # error codes vary among platforms.
+} -cleanup {
+    http::cleanup $token
 } -returnCodes 1 -match glob -result "couldn't open socket*"
 
 test http-5.1 {http::formatQuery} {
@@ -493,14 +544,16 @@ test http-5.5 {http::formatQuery} {
     set res
 } {name1=~bwelch&name2=%a1%a2%a2}
 
-test http-6.1 {http::ProxyRequired} {
+test http-6.1 {http::ProxyRequired} -body {
     http::config -proxyhost [info hostname] -proxyport $port
     set token [http::geturl $url]
     http::wait $token
-    http::config -proxyhost {} -proxyport {}
     upvar #0 $token data
     set data(body)
-} "<html><head><title>HTTP/1.0 TEST</title></head><body>
+} -cleanup {
+    http::config -proxyhost {} -proxyport {}
+    http::cleanup $token
+} -result "<html><head><title>HTTP/1.0 TEST</title></head><body>
 <h1>Hello, World!</h1>
 <h2>GET http:$url</h2>
 </body></html>"
@@ -513,24 +566,26 @@ test http-7.2 {http::mapReply} {
     # so make sure this gets converted to utf-8 then urlencoded.
     http::mapReply "\u2208"
 } {%e2%88%88}
-test http-7.3 {http::formatQuery} {
+test http-7.3 {http::formatQuery} -setup {
     set enc [http::config -urlencoding]
+} -returnCodes error -body {
     # this would be reverting to http <=2.4 behavior
     http::config -urlencoding ""
-    set res [list [catch {http::mapReply "\u2208"} msg] $msg]
+    http::mapReply "\u2208"
+} -cleanup {
     http::config -urlencoding $enc
-    set res
-} [list 1 "can't read \"formMap(\u2208)\": no such element in array"]
-test http-7.4 {http::formatQuery} {
+} -result "can't read \"formMap(\u2208)\": no such element in array"
+test http-7.4 {http::formatQuery} -setup {
     set enc [http::config -urlencoding]
+} -body {
     # this would be reverting to http <=2.4 behavior w/o errors
     # (unknown chars become '?')
     http::config -urlencoding "iso8859-1"
-    set res [http::mapReply "\u2208"]
+    http::mapReply "\u2208"
+} -cleanup {
     http::config -urlencoding $enc
-    set res
-} {%3f}
-
+} -result {%3f}
+
 # cleanup
 catch {unset url}
 catch {unset badurl}