sl@0: # Commands covered: http::config, http::geturl, http::wait, http::reset
sl@0: #
sl@0: # This file contains a collection of tests for the http script library.
sl@0: # Sourcing this file into Tcl runs the tests and
sl@0: # generates output for errors. No output means no errors were found.
sl@0: #
sl@0: # Copyright (c) 1991-1993 The Regents of the University of California.
sl@0: # Copyright (c) 1994-1996 Sun Microsystems, Inc.
sl@0: # Copyright (c) 1998-2000 by Ajuba Solutions.
sl@0: #
sl@0: # See the file "license.terms" for information on usage and redistribution
sl@0: # of this file, and for a DISCLAIMER OF ALL WARRANTIES.
sl@0: #
sl@0: #
sl@0: # RCS: @(#) $Id: http.test,v 1.33.2.6 2006/10/06 19:00:53 hobbs Exp $
sl@0:
sl@0: if {[lsearch [namespace children] ::tcltest] == -1} {
sl@0: package require tcltest 2
sl@0: namespace import -force ::tcltest::*
sl@0: }
sl@0:
sl@0: if {[catch {package require http 2} version]} {
sl@0: if {[info exists http2]} {
sl@0: catch {puts "Cannot load http 2.* package"}
sl@0: return
sl@0: } else {
sl@0: catch {puts "Running http 2.* tests in slave interp"}
sl@0: set interp [interp create http2]
sl@0: $interp eval [list set http2 "running"]
sl@0: $interp eval [list set argv $argv]
sl@0: $interp eval [list source [info script]]
sl@0: interp delete $interp
sl@0: return
sl@0: }
sl@0: }
sl@0:
sl@0: proc bgerror {args} {
sl@0: global errorInfo
sl@0: puts stderr "http.test bgerror"
sl@0: puts stderr [join $args]
sl@0: puts stderr $errorInfo
sl@0: }
sl@0:
sl@0: set port 8010
sl@0: set bindata "This is binary data\x0d\x0amore\x0dmore\x0amore\x00null"
sl@0: catch {unset data}
sl@0:
sl@0: # Ensure httpd file exists
sl@0:
sl@0: set origFile [file join [pwd] [file dirname [info script]] httpd]
sl@0: set httpdFile [file join [temporaryDirectory] httpd_[pid]]
sl@0: if {![file exists $httpdFile]} {
sl@0: makeFile "" $httpdFile
sl@0: file delete $httpdFile
sl@0: file copy $origFile $httpdFile
sl@0: set removeHttpd 1
sl@0: }
sl@0:
sl@0: if {[info commands testthread] == "testthread" && [file exists $httpdFile]} {
sl@0: set httpthread [testthread create "
sl@0: source [list $httpdFile]
sl@0: testthread wait
sl@0: "]
sl@0: testthread send $httpthread [list set port $port]
sl@0: testthread send $httpthread [list set bindata $bindata]
sl@0: testthread send $httpthread {httpd_init $port}
sl@0: puts "Running httpd in thread $httpthread"
sl@0: } else {
sl@0: if {![file exists $httpdFile]} {
sl@0: puts "Cannot read $httpdFile script, http test skipped"
sl@0: unset port
sl@0: return
sl@0: }
sl@0: source $httpdFile
sl@0: # Let the OS pick the port; that's much more flexible
sl@0: if {[catch {httpd_init 0} listen]} {
sl@0: puts "Cannot start http server, http test skipped"
sl@0: unset port
sl@0: return
sl@0: } else {
sl@0: set port [lindex [fconfigure $listen -sockname] 2]
sl@0: }
sl@0: }
sl@0:
sl@0: test http-1.1 {http::config} {
sl@0: http::config
sl@0: } [list -accept */* -proxyfilter http::ProxyRequired -proxyhost {} -proxyport {} -urlencoding utf-8 -useragent "Tcl http client package $version"]
sl@0: test http-1.2 {http::config} {
sl@0: http::config -proxyfilter
sl@0: } http::ProxyRequired
sl@0: test http-1.3 {http::config} {
sl@0: catch {http::config -junk}
sl@0: } 1
sl@0: test http-1.4 {http::config} {
sl@0: set savedconf [http::config]
sl@0: http::config -proxyhost nowhere.come -proxyport 8080 \
sl@0: -proxyfilter myFilter -useragent "Tcl Test Suite" \
sl@0: -urlencoding iso8859-1
sl@0: set x [http::config]
sl@0: eval http::config $savedconf
sl@0: set x
sl@0: } {-accept */* -proxyfilter myFilter -proxyhost nowhere.come -proxyport 8080 -urlencoding iso8859-1 -useragent {Tcl Test Suite}}
sl@0: test http-1.5 {http::config} {
sl@0: list [catch {http::config -proxyhost {} -junk 8080} msg] $msg
sl@0: } {1 {Unknown option -junk, must be: -accept, -proxyfilter, -proxyhost, -proxyport, -urlencoding, -useragent}}
sl@0: test http-1.6 {http::config} {
sl@0: set enc [list [http::config -urlencoding]]
sl@0: http::config -urlencoding iso8859-1
sl@0: lappend enc [http::config -urlencoding]
sl@0: http::config -urlencoding [lindex $enc 0]
sl@0: set enc
sl@0: } {utf-8 iso8859-1}
sl@0:
sl@0: test http-2.1 {http::reset} {
sl@0: catch {http::reset http#1}
sl@0: } 0
sl@0:
sl@0: test http-3.1 {http::geturl} {
sl@0: list [catch {http::geturl -bogus flag} msg] $msg
sl@0: } {1 {Unknown option flag, can be: -binary, -blocksize, -channel, -command, -handler, -headers, -progress, -query, -queryblocksize, -querychannel, -queryprogress, -validate, -timeout, -type}}
sl@0: test http-3.2 {http::geturl} {
sl@0: catch {http::geturl http:junk} err
sl@0: set err
sl@0: } {Unsupported URL: http:junk}
sl@0: set url //[info hostname]:$port
sl@0: set badurl //[info hostname]:6666
sl@0: test http-3.3 {http::geturl} {
sl@0: set token [http::geturl $url]
sl@0: http::data $token
sl@0: } "
HTTP/1.0 TEST
sl@0: Hello, World!
sl@0: GET /
sl@0: "
sl@0: set tail /a/b/c
sl@0: set url //[info hostname]:$port/a/b/c
sl@0: set fullurl http://user:pass@[info hostname]:$port/a/b/c
sl@0: set binurl //[info hostname]:$port/binary
sl@0: set posturl //[info hostname]:$port/post
sl@0: set badposturl //[info hostname]:$port/droppost
sl@0: set badcharurl //%user@[info hostname]:$port/a/^b/c
sl@0:
sl@0: test http-3.4 {http::geturl} {
sl@0: set token [http::geturl $url]
sl@0: http::data $token
sl@0: } "HTTP/1.0 TEST
sl@0: Hello, World!
sl@0: GET $tail
sl@0: "
sl@0: proc selfproxy {host} {
sl@0: global port
sl@0: return [list [info hostname] $port]
sl@0: }
sl@0: test http-3.5 {http::geturl} {
sl@0: http::config -proxyfilter selfproxy
sl@0: set token [http::geturl $url]
sl@0: http::config -proxyfilter http::ProxyRequired
sl@0: http::data $token
sl@0: } "HTTP/1.0 TEST
sl@0: Hello, World!
sl@0: GET http:$url
sl@0: "
sl@0: test http-3.6 {http::geturl} {
sl@0: http::config -proxyfilter bogus
sl@0: set token [http::geturl $url]
sl@0: http::config -proxyfilter http::ProxyRequired
sl@0: http::data $token
sl@0: } "HTTP/1.0 TEST
sl@0: Hello, World!
sl@0: GET $tail
sl@0: "
sl@0: test http-3.7 {http::geturl} {
sl@0: set token [http::geturl $url -headers {Pragma no-cache}]
sl@0: http::data $token
sl@0: } "HTTP/1.0 TEST
sl@0: Hello, World!
sl@0: GET $tail
sl@0: "
sl@0: test http-3.8 {http::geturl} {
sl@0: set token [http::geturl $url -query Name=Value&Foo=Bar -timeout 2000]
sl@0: http::data $token
sl@0: } "HTTP/1.0 TEST
sl@0: Hello, World!
sl@0: POST $tail
sl@0: Query
sl@0:
sl@0: - Name
- Value
sl@0:
- Foo
- Bar
sl@0:
sl@0: "
sl@0: test http-3.9 {http::geturl} {
sl@0: set token [http::geturl $url -validate 1]
sl@0: http::code $token
sl@0: } "HTTP/1.0 200 OK"
sl@0: test http-3.10 {http::geturl queryprogress} {
sl@0: set query foo=bar
sl@0: set sep ""
sl@0: set i 0
sl@0: # Create about 120K of query data
sl@0: while {$i < 14} {
sl@0: incr i
sl@0: append query $sep$query
sl@0: set sep &
sl@0: }
sl@0:
sl@0: proc postProgress {token x y} {
sl@0: global postProgress
sl@0: lappend postProgress $y
sl@0: }
sl@0: set postProgress {}
sl@0: set t [http::geturl $posturl -query $query \
sl@0: -queryprogress postProgress -queryblocksize 16384]
sl@0: http::wait $t
sl@0: list [http::status $t] [string length $query] $postProgress [http::data $t]
sl@0: } {ok 122879 {16384 32768 49152 65536 81920 98304 114688 122879} {Got 122879 bytes}}
sl@0: test http-3.11 {http::geturl querychannel with -command} {
sl@0: set query foo=bar
sl@0: set sep ""
sl@0: set i 0
sl@0: # Create about 120K of query data
sl@0: while {$i < 14} {
sl@0: incr i
sl@0: append query $sep$query
sl@0: set sep &
sl@0: }
sl@0: set file [makeFile $query outdata]
sl@0: set fp [open $file]
sl@0:
sl@0: proc asyncCB {token} {
sl@0: global postResult
sl@0: lappend postResult [http::data $token]
sl@0: }
sl@0: set postResult [list ]
sl@0: set t [http::geturl $posturl -querychannel $fp]
sl@0: http::wait $t
sl@0: set testRes [list [http::status $t] [string length $query] [http::data $t]]
sl@0:
sl@0: # Now do async
sl@0: http::cleanup $t
sl@0: close $fp
sl@0: set fp [open $file]
sl@0: set t [http::geturl $posturl -querychannel $fp -command asyncCB]
sl@0: set postResult [list PostStart]
sl@0: http::wait $t
sl@0: close $fp
sl@0:
sl@0: lappend testRes [http::status $t] $postResult
sl@0: removeFile outdata
sl@0: set testRes
sl@0: } {ok 122879 {Got 122880 bytes} ok {PostStart {Got 122880 bytes}}}
sl@0: # On Linux platforms when the client and server are on the same host, the
sl@0: # client is unable to read the server's response one it hits the write error.
sl@0: # The status is "eof".
sl@0: # On Windows, the http::wait procedure gets a "connection reset by peer" error
sl@0: # while reading the reply.
sl@0: test http-3.12 {http::geturl querychannel with aborted request} {nonPortable} {
sl@0: set query foo=bar
sl@0: set sep ""
sl@0: set i 0
sl@0: # Create about 120K of query data
sl@0: while {$i < 14} {
sl@0: incr i
sl@0: append query $sep$query
sl@0: set sep &
sl@0: }
sl@0: set file [makeFile $query outdata]
sl@0: set fp [open $file]
sl@0:
sl@0: proc asyncCB {token} {
sl@0: global postResult
sl@0: lappend postResult [http::data $token]
sl@0: }
sl@0: proc postProgress {token x y} {
sl@0: global postProgress
sl@0: lappend postProgress $y
sl@0: }
sl@0: set postProgress {}
sl@0: # Now do async
sl@0: set postResult [list PostStart]
sl@0: if {[catch {
sl@0: set t [http::geturl $badposturl -querychannel $fp -command asyncCB \
sl@0: -queryprogress postProgress]
sl@0: http::wait $t
sl@0: upvar #0 $t state
sl@0: } err]} {
sl@0: puts $errorInfo
sl@0: error $err
sl@0: }
sl@0:
sl@0: removeFile outdata
sl@0: list [http::status $t] [http::code $t]
sl@0: } {ok {HTTP/1.0 200 Data follows}}
sl@0: test http-3.13 {http::geturl socket leak test} {
sl@0: set chanCount [llength [file channels]]
sl@0: for {set i 0} {$i < 3} {incr i} {
sl@0: catch {http::geturl $badurl -timeout 5000}
sl@0: }
sl@0:
sl@0: # No extra channels should be taken
sl@0: expr {[llength [file channels]] == $chanCount}
sl@0: } 1
sl@0: test http-3.14 "http::geturl $fullurl" {
sl@0: set token [http::geturl $fullurl -validate 1]
sl@0: http::code $token
sl@0: } "HTTP/1.0 200 OK"
sl@0: test http-3.15 {http::geturl parse failures} -body {
sl@0: http::geturl "{invalid}:url"
sl@0: } -returnCodes error -result {Unsupported URL: {invalid}:url}
sl@0: test http-3.16 {http::geturl parse failures} -body {
sl@0: http::geturl http:relative/url
sl@0: } -returnCodes error -result {Unsupported URL: http:relative/url}
sl@0: test http-3.17 {http::geturl parse failures} -body {
sl@0: http::geturl /absolute/url
sl@0: } -returnCodes error -result {Missing host part: /absolute/url}
sl@0: test http-3.18 {http::geturl parse failures} -body {
sl@0: http::geturl http://somewhere:123456789/
sl@0: } -returnCodes error -result {Invalid port number: 123456789}
sl@0: test http-3.19 {http::geturl parse failures} -body {
sl@0: set ::http::strict 1
sl@0: http::geturl http://{user}@somewhere
sl@0: } -returnCodes error -result {Illegal characters in URL user}
sl@0: test http-3.20 {http::geturl parse failures} -body {
sl@0: set ::http::strict 1
sl@0: http::geturl http://%user@somewhere
sl@0: } -returnCodes error -result {Illegal encoding character usage "%us" in URL user}
sl@0: test http-3.21 {http::geturl parse failures} -body {
sl@0: set ::http::strict 1
sl@0: http::geturl http://somewhere/{path}
sl@0: } -returnCodes error -result {Illegal characters in URL path}
sl@0: test http-3.22 {http::geturl parse failures} -body {
sl@0: set ::http::strict 1
sl@0: http::geturl http://somewhere/%path
sl@0: } -returnCodes error -result {Illegal encoding character usage "%pa" in URL path}
sl@0: test http-3.23 {http::geturl parse failures} -body {
sl@0: set ::http::strict 1
sl@0: http::geturl http://somewhere/path?{query}
sl@0: } -returnCodes error -result {Illegal characters in URL path}
sl@0: test http-3.24 {http::geturl parse failures} -body {
sl@0: set ::http::strict 1
sl@0: http::geturl http://somewhere/path?%query
sl@0: } -returnCodes error -result {Illegal encoding character usage "%qu" in URL path}
sl@0: test http-3.25 {http::geturl parse failures} -body {
sl@0: set ::http::strict 0
sl@0: set token [http::geturl $badcharurl]
sl@0: http::cleanup $token
sl@0: } -returnCodes ok -result {}
sl@0:
sl@0: test http-4.1 {http::Event} {
sl@0: set token [http::geturl $url]
sl@0: upvar #0 $token data
sl@0: array set meta $data(meta)
sl@0: expr ($data(totalsize) == $meta(Content-Length))
sl@0: } 1
sl@0: test http-4.2 {http::Event} {
sl@0: set token [http::geturl $url]
sl@0: upvar #0 $token data
sl@0: array set meta $data(meta)
sl@0: string compare $data(type) [string trim $meta(Content-Type)]
sl@0: } 0
sl@0: test http-4.3 {http::Event} {
sl@0: set token [http::geturl $url]
sl@0: http::code $token
sl@0: } {HTTP/1.0 200 Data follows}
sl@0: test http-4.4 {http::Event} {
sl@0: set testfile [makeFile "" testfile]
sl@0: set out [open $testfile w]
sl@0: set token [http::geturl $url -channel $out]
sl@0: close $out
sl@0: set in [open $testfile]
sl@0: set x [read $in]
sl@0: close $in
sl@0: removeFile $testfile
sl@0: set x
sl@0: } "HTTP/1.0 TEST
sl@0: Hello, World!
sl@0: GET $tail
sl@0: "
sl@0: test http-4.5 {http::Event} {
sl@0: set testfile [makeFile "" testfile]
sl@0: set out [open $testfile w]
sl@0: set token [http::geturl $url -channel $out]
sl@0: close $out
sl@0: upvar #0 $token data
sl@0: removeFile $testfile
sl@0: expr $data(currentsize) == $data(totalsize)
sl@0: } 1
sl@0: test http-4.6 {http::Event} {
sl@0: set testfile [makeFile "" testfile]
sl@0: set out [open $testfile w]
sl@0: set token [http::geturl $binurl -channel $out]
sl@0: close $out
sl@0: set in [open $testfile]
sl@0: fconfigure $in -translation binary
sl@0: set x [read $in]
sl@0: close $in
sl@0: removeFile $testfile
sl@0: set x
sl@0: } "$bindata[string trimleft $binurl /]"
sl@0: proc myProgress {token total current} {
sl@0: global progress httpLog
sl@0: if {[info exists httpLog] && $httpLog} {
sl@0: puts "progress $total $current"
sl@0: }
sl@0: set progress [list $total $current]
sl@0: }
sl@0: if 0 {
sl@0: # This test hangs on Windows95 because the client never gets EOF
sl@0: set httpLog 1
sl@0: test http-4.6.1 {http::Event} knownBug {
sl@0: set token [http::geturl $url -blocksize 50 -progress myProgress]
sl@0: set progress
sl@0: } {111 111}
sl@0: }
sl@0: test http-4.7 {http::Event} {
sl@0: set token [http::geturl $url -progress myProgress]
sl@0: set progress
sl@0: } {111 111}
sl@0: test http-4.8 {http::Event} {
sl@0: set token [http::geturl $url]
sl@0: http::status $token
sl@0: } {ok}
sl@0: test http-4.9 {http::Event} {
sl@0: set token [http::geturl $url -progress myProgress]
sl@0: http::code $token
sl@0: } {HTTP/1.0 200 Data follows}
sl@0: test http-4.10 {http::Event} {
sl@0: set token [http::geturl $url -progress myProgress]
sl@0: http::size $token
sl@0: } {111}
sl@0: # Timeout cases
sl@0: # Short timeout to working server (the test server). This lets us try a
sl@0: # reset during the connection.
sl@0: test http-4.11 {http::Event} {
sl@0: set token [http::geturl $url -timeout 1 -command {#}]
sl@0: http::reset $token
sl@0: http::status $token
sl@0: } {reset}
sl@0: # Longer timeout with reset.
sl@0: test http-4.12 {http::Event} {
sl@0: set token [http::geturl $url/?timeout=10 -command {#}]
sl@0: http::reset $token
sl@0: http::status $token
sl@0: } {reset}
sl@0: # Medium timeout to working server that waits even longer. The timeout
sl@0: # hits while waiting for a reply.
sl@0: test http-4.13 {http::Event} {
sl@0: set token [http::geturl $url?timeout=30 -timeout 10 -command {#}]
sl@0: http::wait $token
sl@0: http::status $token
sl@0: } {timeout}
sl@0: # Longer timeout to good host, bad port, gets an error after the
sl@0: # connection "completes" but the socket is bad.
sl@0: test http-4.14 {http::Event} {
sl@0: set code [catch {
sl@0: set token [http::geturl $badurl/?timeout=10 -timeout 10000 -command {#}]
sl@0: if {[string length $token] == 0} {
sl@0: error "bogus return from http::geturl"
sl@0: }
sl@0: http::wait $token
sl@0: http::status $token
sl@0: } err]
sl@0: # error code varies among platforms.
sl@0: list $code [regexp {(connect failed|couldn't open socket)} $err]
sl@0: } {1 1}
sl@0: # Bogus host
sl@0: test http-4.15 {http::Event} {
sl@0: # This test may fail if you use a proxy server. That is to be
sl@0: # expected and is not a problem with Tcl.
sl@0: set code [catch {
sl@0: set token [http::geturl //not_a_host.tcl.tk -timeout 1000 -command {#}]
sl@0: http::wait $token
sl@0: http::status $token
sl@0: } err]
sl@0: # error code varies among platforms.
sl@0: list $code [string match "couldn't open socket*" $err]
sl@0: } {1 1}
sl@0:
sl@0: test http-5.1 {http::formatQuery} {
sl@0: http::formatQuery name1 value1 name2 "value two"
sl@0: } {name1=value1&name2=value%20two}
sl@0: # test http-5.2 obsoleted by 5.4 and 5.5 with http 2.5
sl@0: test http-5.3 {http::formatQuery} {
sl@0: http::formatQuery lines "line1\nline2\nline3"
sl@0: } {lines=line1%0d%0aline2%0d%0aline3}
sl@0: test http-5.4 {http::formatQuery} {
sl@0: http::formatQuery name1 ~bwelch name2 \xa1\xa2\xa2
sl@0: } {name1=~bwelch&name2=%c2%a1%c2%a2%c2%a2}
sl@0: test http-5.5 {http::formatQuery} {
sl@0: set enc [http::config -urlencoding]
sl@0: http::config -urlencoding iso8859-1
sl@0: set res [http::formatQuery name1 ~bwelch name2 \xa1\xa2\xa2]
sl@0: http::config -urlencoding $enc
sl@0: set res
sl@0: } {name1=~bwelch&name2=%a1%a2%a2}
sl@0:
sl@0: test http-6.1 {http::ProxyRequired} {
sl@0: http::config -proxyhost [info hostname] -proxyport $port
sl@0: set token [http::geturl $url]
sl@0: http::wait $token
sl@0: http::config -proxyhost {} -proxyport {}
sl@0: upvar #0 $token data
sl@0: set data(body)
sl@0: } "HTTP/1.0 TEST
sl@0: Hello, World!
sl@0: GET http:$url
sl@0: "
sl@0:
sl@0: test http-7.1 {http::mapReply} {
sl@0: http::mapReply "abc\$\[\]\"\\()\}\{"
sl@0: } {abc%24%5b%5d%22%5c%28%29%7d%7b}
sl@0: test http-7.2 {http::mapReply} {
sl@0: # RFC 2718 specifies that we pass urlencoding on utf-8 chars by default,
sl@0: # so make sure this gets converted to utf-8 then urlencoded.
sl@0: http::mapReply "\u2208"
sl@0: } {%e2%88%88}
sl@0: test http-7.3 {http::formatQuery} {
sl@0: set enc [http::config -urlencoding]
sl@0: # this would be reverting to http <=2.4 behavior
sl@0: http::config -urlencoding ""
sl@0: set res [list [catch {http::mapReply "\u2208"} msg] $msg]
sl@0: http::config -urlencoding $enc
sl@0: set res
sl@0: } [list 1 "can't read \"formMap(\u2208)\": no such element in array"]
sl@0: test http-7.4 {http::formatQuery} {
sl@0: set enc [http::config -urlencoding]
sl@0: # this would be reverting to http <=2.4 behavior w/o errors
sl@0: # (unknown chars become '?')
sl@0: http::config -urlencoding "iso8859-1"
sl@0: set res [http::mapReply "\u2208"]
sl@0: http::config -urlencoding $enc
sl@0: set res
sl@0: } {%3f}
sl@0:
sl@0: # cleanup
sl@0: catch {unset url}
sl@0: catch {unset badurl}
sl@0: catch {unset port}
sl@0: catch {unset data}
sl@0: if {[info exists httpthread]} {
sl@0: testthread send -async $httpthread {
sl@0: testthread exit
sl@0: }
sl@0: } else {
sl@0: close $listen
sl@0: }
sl@0:
sl@0: if {[info exists removeHttpd]} {
sl@0: removeFile $httpdFile
sl@0: }
sl@0:
sl@0: rename bgerror {}
sl@0: ::tcltest::cleanupTests