diff options
Diffstat (limited to 'tests/http.test')
| -rw-r--r-- | tests/http.test | 347 |
1 files changed, 215 insertions, 132 deletions
diff --git a/tests/http.test b/tests/http.test index 70ca2f6..2fc0a51 100644 --- a/tests/http.test +++ b/tests/http.test @@ -10,23 +10,21 @@ # # 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.23 2001/08/07 00:42:30 hobbs Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest + package require tcltest 2 namespace import -force ::tcltest::* } if {[catch {package require http 2} version]} { - if {[info exist http2]} { + if {[info exists http2]} { catch {puts "Cannot load http 2.* package"} return } else { catch {puts "Running http 2.* tests in slave interp"} set interp [interp create http2] $interp eval [list set http2 "running"] + $interp eval [list set argv $argv] $interp eval [list source [info script]] interp delete $interp return @@ -46,17 +44,18 @@ catch {unset data} # Ensure httpd file exists -set origFile [file join $::tcltest::testsDirectory httpd] -set newFile [file join $::tcltest::workingDirectory httpd] -if {![file exists $newFile]} { - file copy $origFile $newFile +set origFile [file join [pwd] [file dirname [info script]] httpd] +set httpdFile [file join [temporaryDirectory] httpd_[pid]] +if {![file exists $httpdFile]} { + makeFile "" $httpdFile + file delete $httpdFile + file copy $origFile $httpdFile set removeHttpd 1 } -set httpdFile [file join $::tcltest::workingDirectory httpd] if {[info commands testthread] == "testthread" && [file exists $httpdFile]} { - set httpthread [testthread create " - source $httpdFile + set httpthread [testthread create -joinable " + source [list $httpdFile] testthread wait "] testthread send $httpthread [list set port $port] @@ -64,58 +63,64 @@ if {[info commands testthread] == "testthread" && [file exists $httpdFile]} { testthread send $httpthread {httpd_init $port} puts "Running httpd in thread $httpthread" } else { - if ![file exists $httpdFile] { + if {![file exists $httpdFile]} { puts "Cannot read $httpdFile script, http test skipped" unset port return } source $httpdFile - if [catch {httpd_init $port} listen] { + # Let the OS pick the port; that's much more flexible + if {[catch {httpd_init 0} listen]} { puts "Cannot start http server, http test skipped" unset port return + } else { + set port [lindex [fconfigure $listen -sockname] 2] } } - test http-1.1 {http::config} { http::config -} [list -accept */* -proxyfilter http::ProxyRequired -proxyhost {} -proxyport {} -useragent "Tcl http client package $version"] - +} [list -accept */* -proxyfilter http::ProxyRequired -proxyhost {} -proxyport {} -urlencoding utf-8 -useragent "Tcl http client package $version"] test http-1.2 {http::config} { http::config -proxyfilter } http::ProxyRequired - test http-1.3 {http::config} { catch {http::config -junk} } 1 - test http-1.4 {http::config} { set savedconf [http::config] - http::config -proxyhost nowhere.come -proxyport 8080 -proxyfilter myFilter -useragent "Tcl Test Suite" + http::config -proxyhost nowhere.come -proxyport 8080 \ + -proxyfilter myFilter -useragent "Tcl Test Suite" \ + -urlencoding iso8859-1 set x [http::config] - eval http::config $savedconf + http::config {*}$savedconf set x -} {-accept */* -proxyfilter myFilter -proxyhost nowhere.come -proxyport 8080 -useragent {Tcl Test Suite}} - +} {-accept */* -proxyfilter myFilter -proxyhost nowhere.come -proxyport 8080 -urlencoding iso8859-1 -useragent {Tcl Test Suite}} test http-1.5 {http::config} { - catch {http::config -proxyhost {} -junk 8080} -} 1 + 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} { + 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} test http-2.1 {http::reset} { catch {http::reset http#1} } 0 test http-3.1 {http::geturl} { - catch {http::geturl -bogus flag} -} 1 + 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} - -set url [info hostname]:$port -set badurl www.scriptics.com:6666 +set url //[info hostname]:$port +set badurl //[info hostname]:[expr $port+1] test http-3.3 {http::geturl} { set token [http::geturl $url] http::data $token @@ -123,13 +128,13 @@ test http-3.3 {http::geturl} { <h1>Hello, World!</h1> <h2>GET /</h2> </body></html>" - set tail /a/b/c -set url [info hostname]:$port/a/b/c -set binurl [info hostname]:$port/binary -set posturl [info hostname]:$port/post -set badposturl [info hostname]:$port/droppost - +set url //[info hostname]:$port/a/b/c +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 +set authorityurl //[info hostname]:$port test http-3.4 {http::geturl} { set token [http::geturl $url] http::data $token @@ -137,7 +142,6 @@ test http-3.4 {http::geturl} { <h1>Hello, World!</h1> <h2>GET $tail</h2> </body></html>" - proc selfproxy {host} { global port return [list [info hostname] $port] @@ -149,9 +153,8 @@ test http-3.5 {http::geturl} { http::data $token } "<html><head><title>HTTP/1.0 TEST</title></head><body> <h1>Hello, World!</h1> -<h2>GET http://$url</h2> +<h2>GET http:$url</h2> </body></html>" - test http-3.6 {http::geturl} { http::config -proxyfilter bogus set token [http::geturl $url] @@ -161,7 +164,6 @@ test http-3.6 {http::geturl} { <h1>Hello, World!</h1> <h2>GET $tail</h2> </body></html>" - test http-3.7 {http::geturl} { set token [http::geturl $url -headers {Pragma no-cache}] http::data $token @@ -169,7 +171,6 @@ test http-3.7 {http::geturl} { <h1>Hello, World!</h1> <h2>GET $tail</h2> </body></html>" - test http-3.8 {http::geturl} { set token [http::geturl $url -query Name=Value&Foo=Bar -timeout 2000] http::data $token @@ -182,12 +183,10 @@ test http-3.8 {http::geturl} { <dt>Foo<dd>Bar </dl> </body></html>" - test http-3.9 {http::geturl} { set token [http::geturl $url -validate 1] http::code $token } "HTTP/1.0 200 OK" - test http-3.10 {http::geturl queryprogress} { set query foo=bar set sep "" @@ -204,12 +203,11 @@ test http-3.10 {http::geturl queryprogress} { lappend postProgress $y } set postProgress {} - set t [http::geturl $posturl -query $query \ + set t [http::geturl $posturl -keepalive 0 -query $query \ -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} { set query foo=bar set sep "" @@ -220,8 +218,8 @@ test http-3.11 {http::geturl querychannel with -command} { append query $sep$query set sep & } - ::tcltest::makeFile $query outdata - set fp [open outdata] + set file [makeFile $query outdata] + set fp [open $file] proc asyncCB {token} { global postResult @@ -235,22 +233,21 @@ test http-3.11 {http::geturl querychannel with -command} { # Now do async http::cleanup $t close $fp - set fp [open outdata] + set fp [open $file] set t [http::geturl $posturl -querychannel $fp -command asyncCB] set postResult [list PostStart] http::wait $t + close $fp lappend testRes [http::status $t] $postResult + removeFile outdata set testRes } {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 - +# 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} { set query foo=bar set sep "" @@ -261,8 +258,8 @@ test http-3.12 {http::geturl querychannel with aborted request} {nonPortable} { append query $sep$query set sep & } - ::tcltest::makeFile $query outdata - set fp [open outdata] + set file [makeFile $query outdata] + set fp [open $file] proc asyncCB {token} { global postResult @@ -281,77 +278,145 @@ test http-3.12 {http::geturl querychannel with aborted request} {nonPortable} { http::wait $t upvar #0 $t state } err]} { - puts $errorInfo + puts $::errorInfo error $err } + removeFile outdata list [http::status $t] [http::code $t] } {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} { - catch {http::geturl $badurl -timeout 5000} + catch {http::geturl $badurl -timeout 5000} } # No extra channels should be taken expr {[llength [file channels]] == $chanCount} } 1 +test http-3.14 "http::geturl $fullurl" { + set token [http::geturl $fullurl -validate 1] + http::code $token +} "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} +test http-3.16 {http::geturl parse failures} -body { + http::geturl http:relative/url +} -returnCodes error -result {Unsupported URL: http:relative/url} +test http-3.17 {http::geturl parse failures} -body { + http::geturl /absolute/url +} -returnCodes error -result {Missing host part: /absolute/url} +test http-3.18 {http::geturl parse failures} -body { + http::geturl http://somewhere:123456789/ +} -returnCodes error -result {Invalid port number: 123456789} +test http-3.19 {http::geturl parse failures} -body { + http::geturl http://{user}@somewhere +} -returnCodes error -result {Illegal characters in URL user} +test http-3.20 {http::geturl parse failures} -body { + http::geturl http://%user@somewhere +} -returnCodes error -result {Illegal encoding character usage "%us" in URL user} +test http-3.21 {http::geturl parse failures} -body { + http::geturl http://somewhere/{path} +} -returnCodes error -result {Illegal characters in URL path} +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} +} -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 { + set token [http::geturl $url/headers -type "text/plain" -query dummy \ + -headers [list "Content-Type" "text/plain;charset=utf-8"]] + http::data $token +} -cleanup { + http::cleanup $token +} -match regexp -result {(?n)Accept \*/\* +Host .* +User-Agent .* +Connection close +Content-Type {text/plain;charset=utf-8} +Content-Length 5} +test http-3.26 {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 +} -cleanup { + http::cleanup $token +} -match regexp -result {(?n)Accept \*/\* +Host .* +User-Agent .* +Connection close +Content-Type {text/plain;charset=utf-8} +Content-Length 5} +test http-3.30 {http::geturl query without path} -body { + set token [http::geturl $authorityurl?var=val] + http::ncode $token +} -cleanup { + catch { http::cleanup $token } +} -result 200 +test http-3.31 {http::geturl fragment without path} -body { + set token [http::geturl "$authorityurl#fragment42"] + http::ncode $token +} -cleanup { + catch { http::cleanup $token } +} -result 200 test http-4.1 {http::Event} { - set token [http::geturl $url] + set token [http::geturl $url -keepalive 0] upvar #0 $token data array set meta $data(meta) - expr ($data(totalsize) == $meta(Content-Length)) + expr {($data(totalsize) == $meta(Content-Length))} } 1 - test http-4.2 {http::Event} { 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} { set token [http::geturl $url] http::code $token } {HTTP/1.0 200 Data follows} - test http-4.4 {http::Event} { - set out [open testfile w] + set testfile [makeFile "" testfile] + set out [open $testfile w] set token [http::geturl $url -channel $out] close $out - set in [open testfile] + set in [open $testfile] set x [read $in] close $in - file delete testfile + removeFile $testfile set x } "<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} { - set out [open testfile w] + set testfile [makeFile "" testfile] + set out [open $testfile w] + fconfigure $out -translation lf set token [http::geturl $url -channel $out] close $out upvar #0 $token data - file delete testfile - expr $data(currentsize) == $data(totalsize) + removeFile $testfile + expr {$data(currentsize) == $data(totalsize)} } 1 - test http-4.6 {http::Event} { - set out [open testfile w] + set testfile [makeFile "" testfile] + set out [open $testfile w] set token [http::geturl $binurl -channel $out] close $out - set in [open testfile] + set in [open $testfile] fconfigure $in -translation binary set x [read $in] close $in - file delete testfile + removeFile $testfile set x -} "$bindata$binurl" - +} "$bindata[string trimleft $binurl /]" proc myProgress {token total current} { global progress httpLog if {[info exists httpLog] && $httpLog} { @@ -362,13 +427,13 @@ proc myProgress {token total current} { if 0 { # This test hangs on Windows95 because the client never gets EOF set httpLog 1 - test http-4.6 {http::Event} { + test http-4.6.1 {http::Event} knownBug { set token [http::geturl $url -blocksize 50 -progress myProgress] set progress } {111 111} } test http-4.7 {http::Event} { - set token [http::geturl $url -progress myProgress] + set token [http::geturl $url -keepalive 0 -progress myProgress] set progress } {111 111} test http-4.8 {http::Event} { @@ -383,74 +448,64 @@ test http-4.10 {http::Event} { set token [http::geturl $url -progress myProgress] http::size $token } {111} - # Timeout cases - -# Short timeout to working server (the test server) -# This lets us try a reset during the connection - +# 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 -command {#}] + set token [http::geturl $url -timeout 1 -keepalive 0 -command {#}] http::reset $token http::status $token } {reset} - -# Longer timeout with reset - +# Longer timeout with reset. test http-4.12 {http::Event} { - set token [http::geturl $url/?timeout=10 -command {#}] + set token [http::geturl $url/?timeout=10 -keepalive 0 -command {#}] http::reset $token http::status $token } {reset} - -# Medium timeout to working server that waits even longer -# The timeout hits while waiting for a reply - +# 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 -timeout 10 -command {#}] + set token [http::geturl $url?timeout=30 -keepalive 0 -timeout 10 -command {#}] http::wait $token http::status $token } {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} { - set code [catch { - set token [http::geturl $badurl/?timeout=10 -timeout 10000 -command {#}] - if {[string length $token] == 0} { - error "bogus return from http::geturl" - } - http::wait $token - http::status $token - } err] - # error code varies among platforms. - list $code [regexp {(connect failed|couldn't open socket)} $err] -} {1 1} - +# 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 { + set token [http::geturl $badurl/?timeout=10 -timeout 10000 -command \#] + if {$token eq ""} { + error "bogus return from http::geturl" + } + http::wait $token + lindex [http::error $token] 0 +} -result {connect failed connection refused} # Bogus host - -test http-4.15 {http::Event} { - set code [catch { - set token [http::geturl not_a_host.scriptics.com -timeout 1000 -command {#}] - http::wait $token - http::status $token - } err] - # error code varies among platforms. - list $code [string match "couldn't open socket*" $err] -} {1 1} +test http-4.15 {http::Event} -body { + # This test may fail if you use a proxy server. That is to be + # expected and is not a problem with Tcl. + set token [http::geturl //not_a_host.tcl.tk -timeout 1000 -command \#] + http::wait $token + http::status $token + # error codes vary among platforms. +} -returnCodes 1 -match glob -result "couldn't open socket*" test http-5.1 {http::formatQuery} { http::formatQuery name1 value1 name2 "value two" -} {name1=value1&name2=value+two} - -test http-5.2 {http::formatQuery} { - http::formatQuery name1 ~bwelch name2 \xa1\xa2\xa2 -} {name1=%7ebwelch&name2=%a1%a2%a2} - +} {name1=value1&name2=value%20two} +# test http-5.2 obsoleted by 5.4 and 5.5 with http 2.5 test http-5.3 {http::formatQuery} { http::formatQuery lines "line1\nline2\nline3" -} {lines=line1%0d%0aline2%0d%0aline3} +} {lines=line1%0D%0Aline2%0D%0Aline3} +test http-5.4 {http::formatQuery} { + http::formatQuery name1 ~bwelch name2 \xa1\xa2\xa2 +} {name1=~bwelch&name2=%C2%A1%C2%A2%C2%A2} +test http-5.5 {http::formatQuery} { + set enc [http::config -urlencoding] + http::config -urlencoding iso8859-1 + set res [http::formatQuery name1 ~bwelch name2 \xa1\xa2\xa2] + http::config -urlencoding $enc + set res +} {name1=~bwelch&name2=%A1%A2%A2} test http-6.1 {http::ProxyRequired} { http::config -proxyhost [info hostname] -proxyport $port @@ -461,9 +516,35 @@ test http-6.1 {http::ProxyRequired} { set data(body) } "<html><head><title>HTTP/1.0 TEST</title></head><body> <h1>Hello, World!</h1> -<h2>GET http://$url</h2> +<h2>GET http:$url</h2> </body></html>" +test http-7.1 {http::mapReply} { + http::mapReply "abc\$\[\]\"\\()\}\{" +} {abc%24%5B%5D%22%5C%28%29%7D%7B} +test http-7.2 {http::mapReply} { + # RFC 2718 specifies that we pass urlencoding on utf-8 chars by default, + # so make sure this gets converted to utf-8 then urlencoded. + http::mapReply "\u2208" +} {%E2%88%88} +test http-7.3 {http::formatQuery} { + set enc [http::config -urlencoding] + # this would be reverting to http <=2.4 behavior + http::config -urlencoding "" + set res [list [catch {http::mapReply "\u2208"} msg] $msg] + http::config -urlencoding $enc + set res +} [list 1 "can't read \"formMap(\u2208)\": no such element in array"] +test http-7.4 {http::formatQuery} { + set enc [http::config -urlencoding] + # 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::config -urlencoding $enc + set res +} {%3F} + # cleanup catch {unset url} catch {unset badurl} @@ -473,12 +554,14 @@ if {[info exists httpthread]} { testthread send -async $httpthread { testthread exit } + testthread join $httpthread } else { close $listen } -if {[info exist removeHttpd]} { +if {[info exists removeHttpd]} { removeFile $httpdFile } +rename bgerror {} ::tcltest::cleanupTests |