summaryrefslogtreecommitdiffstats
path: root/tests/http.test
diff options
context:
space:
mode:
Diffstat (limited to 'tests/http.test')
-rw-r--r--tests/http.test332
1 files changed, 212 insertions, 120 deletions
diff --git a/tests/http.test b/tests/http.test
index 81e16a1..a52cfb1 100644
--- a/tests/http.test
+++ b/tests/http.test
@@ -1,20 +1,18 @@
# 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.
-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]} {
@@ -53,14 +51,13 @@ if {![file exists $httpdFile]} {
set removeHttpd 1
}
-if {[info commands testthread] == "testthread" && [file exists $httpdFile]} {
- set httpthread [testthread create "
- source [list $httpdFile]
- testthread wait
- "]
- testthread send $httpthread [list set port $port]
- testthread send $httpthread [list set bindata $bindata]
- testthread send $httpthread {httpd_init $port}
+catch {package require Thread 2.7-}
+if {[catch {package present Thread}] == 0 && [file exists $httpdFile]} {
+ set httpthread [thread::create -preserved]
+ thread::send $httpthread [list source $httpdFile]
+ thread::send $httpthread [list set port $port]
+ thread::send $httpthread [list set bindata $bindata]
+ thread::send $httpthread {httpd_init $port}
puts "Running httpd in thread $httpthread"
} else {
if {![file exists $httpdFile]} {
@@ -78,10 +75,11 @@ 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
-} [list -accept */* -proxyfilter http::ProxyRequired -proxyhost {} -proxyport {} -urlencoding utf-8 -useragent "Tcl http client package $version"]
+} [list -accept */* -proxyfilter http::ProxyRequired -proxyhost {} -proxyport {} -urlencoding utf-8 -useragent "UserAgent"]
test http-1.2 {http::config} {
http::config -proxyfilter
} http::ProxyRequired
@@ -97,34 +95,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]:[expr $port+1]
-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>"
@@ -135,10 +136,13 @@ set binurl //[info hostname]:$port/binary
set posturl //[info hostname]:$port/post
set badposturl //[info hostname]:$port/droppost
set authorityurl //[info hostname]:$port
-test http-3.4 {http::geturl} {
+set ipv6url http://\[::1\]:$port/
+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>"
@@ -146,35 +150,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>
@@ -183,11 +195,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
@@ -197,7 +211,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
@@ -207,8 +221,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
@@ -219,8 +235,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]
@@ -229,7 +245,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
@@ -238,17 +253,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
@@ -259,8 +274,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]
@@ -281,10 +296,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} {
@@ -294,10 +310,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}
@@ -323,12 +341,32 @@ test http-3.22 {http::geturl parse failures} -body {
http::geturl http://somewhere/%path
} -returnCodes error -result {Illegal encoding character usage "%pa" in URL path}
test http-3.23 {http::geturl parse failures} -body {
- http::geturl http://somewhere/path?{query}
+ http::geturl http://somewhere/path?{query}?
} -returnCodes error -result {Illegal characters in URL path}
test http-3.24 {http::geturl parse failures} -body {
http::geturl http://somewhere/path?%query
} -returnCodes error -result {Illegal encoding character usage "%qu" in URL path}
-test http-3.25 {http::geturl: -headers override -type} -body {
+test http-3.25 {http::meta} -setup {
+ unset -nocomplain m token
+} -body {
+ set token [http::geturl $url -timeout 2000]
+ 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 {
+ unset -nocomplain m token
+} -body {
+ set token [http::geturl $url -headers {X-Check 1} -timeout 2000]
+ 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-3.27 {http::geturl: -headers override -type} -body {
set token [http::geturl $url/headers -type "text/plain" -query dummy \
-headers [list "Content-Type" "text/plain;charset=utf-8"]]
http::data $token
@@ -339,8 +377,9 @@ Host .*
User-Agent .*
Connection close
Content-Type {text/plain;charset=utf-8}
+Accept-Encoding .*
Content-Length 5}
-test http-3.26 {http::geturl: -headers override -type default} -body {
+test http-3.28 {http::geturl: -headers override -type default} -body {
set token [http::geturl $url/headers -query dummy \
-headers [list "Content-Type" "text/plain;charset=utf-8"]]
http::data $token
@@ -351,7 +390,22 @@ Host .*
User-Agent .*
Connection close
Content-Type {text/plain;charset=utf-8}
+Accept-Encoding .*
Content-Length 5}
+test http-3.29 {http::geturl IPv6 address} -body {
+ # We only want to see if the URL gets parsed correctly. This is
+ # the case if http::geturl succeeds or returns a socket related
+ # error. If the parsing is wrong, we'll get a parse error.
+ # It'd be better to separate the URL parser from http::geturl, so
+ # that it can be tested without also trying to make a connection.
+ set error [catch {http::geturl $ipv6url -validate 1} token]
+ if {$error && [string match "couldn't open socket: *" $token]} {
+ set error 0
+ }
+ set error
+} -cleanup {
+ catch { http::cleanup $token }
+} -result 0
test http-3.30 {http::geturl query without path} -body {
set token [http::geturl $authorityurl?var=val]
http::ncode $token
@@ -364,59 +418,73 @@ test http-3.31 {http::geturl fragment without path} -body {
} -cleanup {
catch { http::cleanup $token }
} -result 200
-
-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} {
@@ -429,46 +497,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 {
@@ -478,6 +560,8 @@ test http-4.14 {http::Event} -body {
}
http::wait $token
lindex [http::error $token] 0
+} -cleanup {
+ catch {http::cleanup $token}
} -result {connect failed connection refused}
# Bogus host
test http-4.15 {http::Event} -body {
@@ -487,6 +571,8 @@ test http-4.15 {http::Event} -body {
http::wait $token
http::status $token
# error codes vary among platforms.
+} -cleanup {
+ catch {http::cleanup $token}
} -returnCodes 1 -match glob -result "couldn't open socket*"
test http-5.1 {http::formatQuery} {
@@ -507,14 +593,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>"
@@ -527,33 +615,33 @@ 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}
catch {unset port}
catch {unset data}
if {[info exists httpthread]} {
- testthread send -async $httpthread {
- testthread exit
- }
+ thread::release $httpthread
} else {
close $listen
}
@@ -564,3 +652,7 @@ if {[info exists removeHttpd]} {
rename bgerror {}
::tcltest::cleanupTests
+
+# Local variables:
+# mode: tcl
+# End: