# 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.48.2.2 2009/04/10 13:15:57 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
} [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" \
-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
} "<html><head><title>HTTP/1.0 TEST</title></head><body>
<h1>Hello, World!</h1>
<h2>GET /</h2>
</body></html>"
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
} "<html><head><title>HTTP/1.0 TEST</title></head><body>
<h1>Hello, World!</h1>
<h2>GET $tail</h2>
</body></html>"
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
} "<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} {
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>
<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
} "<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} {
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>
<h1>Hello, World!</h1>
<h2>POST $tail</h2>
<h2>Query</h2>
<dl>
<dt>Name<dd>Value
<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 ""
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-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
} "<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 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)
} "<html><head><title>HTTP/1.0 TEST</title></head><body>
<h1>Hello, World!</h1>
<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}
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
|
