# 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. # # 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. # # # RCS: @(#) $Id: http.test,v 1.53 2009/06/24 15:17:40 dgp Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest 2 namespace import -force ::tcltest::* } if {[catch {package require http 2} version]} { 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 } } proc bgerror {args} { global errorInfo puts stderr "http.test bgerror" puts stderr [join $args] puts stderr $errorInfo } set port 8010 set bindata "This is binary data\x0d\x0amore\x0dmore\x0amore\x00null" catch {unset data} # Ensure httpd file exists 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 } 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} puts "Running httpd in thread $httpthread" } else { if {![file exists $httpdFile]} { puts "Cannot read $httpdFile script, http test skipped" unset port return } source $httpdFile # 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 -useragent UserAgent http::config } [list -accept */* -proxyfilter http::ProxyRequired -proxyhost {} -proxyport {} -urlencoding utf-8 -useragent "UserAgent"] 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" \ -urlencoding iso8859-1 set x [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} { 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} { 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 //[info hostname]:6666 test http-3.3 {http::geturl} { set token [http::geturl $url] http::data $token } "HTTP/1.0 TEST

Hello, World!

GET /

" set tail /a/b/c 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 test http-3.4 {http::geturl} { set token [http::geturl $url] http::data $token } "HTTP/1.0 TEST

Hello, World!

GET $tail

" proc selfproxy {host} { global port return [list [info hostname] $port] } test http-3.5 {http::geturl} { http::config -proxyfilter selfproxy set token [http::geturl $url] http::config -proxyfilter http::ProxyRequired http::data $token } "HTTP/1.0 TEST

Hello, World!

GET http:$url

" test http-3.6 {http::geturl} { http::config -proxyfilter bogus set token [http::geturl $url] http::config -proxyfilter http::ProxyRequired http::data $token } "HTTP/1.0 TEST

Hello, World!

GET $tail

" test http-3.7 {http::geturl} { set token [http::geturl $url -headers {Pragma no-cache}] http::data $token } "HTTP/1.0 TEST

Hello, World!

GET $tail

" test http-3.8 {http::geturl} { set token [http::geturl $url -query Name=Value&Foo=Bar -timeout 2000] http::data $token } "HTTP/1.0 TEST

Hello, World!

POST $tail

Query

Name
Value
Foo
Bar
" 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 "" set i 0 # Create about 120K of query data while {$i < 14} { incr i append query $sep$query set sep & } proc postProgress {token x y} { global postProgress lappend postProgress $y } set postProgress {} 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 "" set i 0 # Create about 120K of query data while {$i < 14} { incr i append query $sep$query set sep & } set file [makeFile $query outdata] set fp [open $file] proc asyncCB {token} { global postResult lappend postResult [http::data $token] } set postResult [list ] 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 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. test http-3.12 {http::geturl querychannel with aborted request} {nonPortable} { set query foo=bar set sep "" set i 0 # Create about 120K of query data while {$i < 14} { incr i append query $sep$query set sep & } set file [makeFile $query outdata] set fp [open $file] proc asyncCB {token} { global postResult lappend postResult [http::data $token] } proc postProgress {token x y} { global postProgress lappend postProgress $y } set postProgress {} # Now do async set postResult [list PostStart] if {[catch { set t [http::geturl $badposturl -querychannel $fp -command asyncCB \ -queryprogress postProgress] http::wait $t upvar #0 $t state } err]} { 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} } # 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::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 { 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 { unset -nocomplain m token } -result {Content-Length Content-Type Date X-Check} test http-4.1 {http::Event} { 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} { 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 testfile [makeFile "" testfile] set out [open $testfile w] set token [http::geturl $url -channel $out] close $out set in [open $testfile] set x [read $in] close $in removeFile $testfile set x } "HTTP/1.0 TEST

Hello, World!

GET $tail

" test http-4.5 {http::Event} { 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 removeFile $testfile expr {$data(currentsize) == $data(totalsize)} } 1 test http-4.6 {http::Event} { set testfile [makeFile "" testfile] 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 removeFile $testfile set x } "$bindata[string trimleft $binurl /]" proc myProgress {token total current} { global progress httpLog if {[info exists httpLog] && $httpLog} { puts "progress $total $current" } set progress [list $total $current] } if 0 { # This test hangs on Windows95 because the client never gets EOF set httpLog 1 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 -keepalive 0 -progress myProgress] set progress } {111 111} test http-4.8 {http::Event} { set token [http::geturl $url] http::status $token } {ok} test http-4.9 {http::Event} { set token [http::geturl $url -progress myProgress] http::code $token } {HTTP/1.0 200 Data follows} 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. test http-4.11 {http::Event} { set token [http::geturl $url -timeout 1 -keepalive 0 -command {#}] http::reset $token http::status $token } {reset} # Longer timeout with reset. test http-4.12 {http::Event} { 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. test http-4.13 {http::Event} { 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} -body { set token [http::geturl $badurl/?timeout=10 -timeout 10000 -command \#] if {$token eq ""} { error "bogus return from http::geturl" } http::wait $token http::status $token # error code varies among platforms. } -returnCodes 1 -match regexp -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 # 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%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} 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 set token [http::geturl $url] http::wait $token http::config -proxyhost {} -proxyport {} upvar #0 $token data set data(body) } "HTTP/1.0 TEST

Hello, World!

GET http:$url

" 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} catch {unset port} catch {unset data} if {[info exists httpthread]} { testthread send -async $httpthread { testthread exit } } else { close $listen } if {[info exists removeHttpd]} { removeFile $httpdFile } rename bgerror {} ::tcltest::cleanupTests # Local variables: # mode: tcl # End: