summaryrefslogtreecommitdiffstats
path: root/tests/http.test
diff options
context:
space:
mode:
Diffstat (limited to 'tests/http.test')
-rw-r--r--tests/http.test409
1 files changed, 409 insertions, 0 deletions
diff --git a/tests/http.test b/tests/http.test
new file mode 100644
index 0000000..2770e13
--- /dev/null
+++ b/tests/http.test
@@ -0,0 +1,409 @@
+# 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.
+#
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+#
+#
+# SCCS: @(#) http2.test 1.8 97/08/13 11:16:50
+
+if {[string compare test [info procs test]] == 1} then {source defs}
+
+if {[catch {package require http 2.0}]} {
+ if {[info exist http2]} {
+ catch {puts stderr "Cannot load http 2.0 package"}
+ return
+ } else {
+ catch {puts stderr "Running http 2.0 tests in slave interp"}
+ set interp [interp create http2]
+ $interp eval [list set http2 "running"]
+ $interp eval [list source [info script]]
+ interp delete $interp
+ return
+ }
+}
+
+############### The httpd_ procedures implement a stub http server. ########
+proc httpd_init {{port 8015}} {
+ socket -server httpdAccept $port
+}
+proc httpd_log {args} {
+ global httpLog
+ if {[info exists httpLog] && $httpLog} {
+ puts stderr "httpd: [join $args { }]"
+ }
+}
+array set httpdErrors {
+ 204 {No Content}
+ 400 {Bad Request}
+ 404 {Not Found}
+ 503 {Service Unavailable}
+ 504 {Service Temporarily Unavailable}
+ }
+
+proc httpdError {sock code args} {
+ global httpdErrors
+ puts $sock "$code $httpdErrors($code)"
+ httpd_log "error: [join $args { }]"
+}
+proc httpdAccept {newsock ipaddr port} {
+ global httpd
+ upvar #0 httpd$newsock data
+
+ fconfigure $newsock -blocking 0 -translation {auto crlf}
+ httpd_log $newsock Connect $ipaddr $port
+ set data(ipaddr) $ipaddr
+ fileevent $newsock readable [list httpdRead $newsock]
+}
+
+# read data from a client request
+
+proc httpdRead { sock } {
+ upvar #0 httpd$sock data
+
+ set readCount [gets $sock line]
+ if {![info exists data(state)]} {
+ if [regexp {(POST|GET|HEAD) ([^?]+)\??([^ ]*) HTTP/1.0} \
+ $line x data(proto) data(url) data(query)] {
+ set data(state) mime
+ httpd_log $sock Query $line
+ } else {
+ httpdError $sock 400
+ httpd_log $sock Error "bad first line:$line"
+ httpdSockDone $sock
+ }
+ return
+ }
+
+ # string compare $readCount 0 maps -1 to -1, 0 to 0, and > 0 to 1
+
+ set state [string compare $readCount 0],$data(state),$data(proto)
+ httpd_log $sock $state
+ switch -- $state {
+ -1,mime,HEAD -
+ -1,mime,GET -
+ -1,mime,POST {
+ # gets would block
+ return
+ }
+ 0,mime,HEAD -
+ 0,mime,GET -
+ 0,query,POST { httpdRespond $sock }
+ 0,mime,POST { set data(state) query }
+ 1,mime,HEAD -
+ 1,mime,POST -
+ 1,mime,GET {
+ if [regexp {([^:]+):[ ]*(.*)} $line dummy key value] {
+ set data(mime,[string tolower $key]) $value
+ }
+ }
+ 1,query,POST {
+ append data(query) $line
+ httpdRespond $sock
+ }
+ default {
+ if [eof $sock] {
+ httpd_log $sock Error "unexpected eof on <$data(url)> request"
+ } else {
+ httpd_log $sock Error "unhandled state <$state> fetching <$data(url)>"
+ }
+ httpdError $sock 404
+ httpdSockDone $sock
+ }
+ }
+}
+proc httpdSockDone { sock } {
+upvar #0 httpd$sock data
+ unset data
+ close $sock
+}
+
+# Respond to the query.
+
+set bindata "This is binary data\x0d\x0amore\x0dmore\x0amore\x00null"
+proc httpdRespond { sock } {
+ global httpd bindata port
+ upvar #0 httpd$sock data
+
+ if {[string match *binary* $data(url)]} {
+ set html "$bindata[info hostname]:$port$data(url)"
+ set type application/octet-stream
+ } else {
+ set type text/html
+
+ set html "<html><head><title>HTTP/1.0 TEST</title></head><body>
+<h1>Hello, World!</h1>
+<h2>$data(proto) $data(url)</h2>
+"
+ if {[info exists data(query)] && [string length $data(query)]} {
+ append html "<h2>Query</h2>\n<dl>\n"
+ foreach {key value} [split $data(query) &=] {
+ append html "<dt>$key<dd>$value\n"
+ }
+ append html </dl>\n
+ }
+ append html </body></html>
+ }
+
+ if {$data(proto) == "HEAD"} {
+ puts $sock "HTTP/1.0 200 OK"
+ } else {
+ puts $sock "HTTP/1.0 200 Data follows"
+ }
+ puts $sock "Date: [clock format [clock clicks]]"
+ puts $sock "Content-Type: $type"
+ puts $sock "Content-Length: [string length $html]"
+ puts $sock ""
+ if {$data(proto) != "HEAD"} {
+ fconfigure $sock -translation binary
+ puts -nonewline $sock $html
+ }
+ httpd_log $sock Done ""
+ httpdSockDone $sock
+}
+##################### end server ###########################
+
+set port 8010
+if [catch {httpd_init $port} listen] {
+ puts stderr "Cannot start http server, http test skipped"
+ unset port
+ return
+}
+
+test http-1.1 {http::config} {
+ http::config
+} {-accept */* -proxyfilter http::ProxyRequired -proxyhost {} -proxyport {} -useragent {Tcl http client package 2.0}}
+
+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"
+ set x [http::config]
+ eval http::config $savedconf
+ set x
+} {-accept */* -proxyfilter myFilter -proxyhost nowhere.come -proxyport 8080 -useragent {Tcl Test Suite}}
+
+test http-1.5 {http::config} {
+ catch {http::config -proxyhost {} -junk 8080}
+} 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
+test http-3.2 {http::geturl} {
+ catch {http::geturl http:junk} err
+ set err
+} {Unsupported URL: http:junk}
+
+set url [info hostname]:$port
+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 binurl [info hostname]:$port/binary
+
+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]
+ 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-4.1 {http::Event} {
+ set token [http::geturl $url]
+ 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 out [open testfile w]
+ set token [http::geturl $url -channel $out]
+ close $out
+ set in [open testfile]
+ set x [read $in]
+ close $in
+ file delete 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 token [http::geturl $url -channel $out]
+ close $out
+ upvar #0 $token data
+ file delete testfile
+ expr $data(currentsize) == $data(totalsize)
+} 1
+
+test http-4.6 {http::Event} {
+ 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
+ file delete testfile
+ set x
+} "$bindata$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 {http::Event} {
+ 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 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}
+test http-4.11 {http::Event} {
+ set token [http::geturl $url -timeout 1 -command {#}]
+ http::reset $token
+ http::status $token
+} {reset}
+test http-4.12 {http::Event} {
+ set token [http::geturl $url -timeout 1 -command {#}]
+ http::wait $token
+ http::status $token
+} {timeout}
+
+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}
+
+test http-5.3 {http::formatQuery} {
+ http::formatQuery lines "line1\nline2\nline3"
+} {lines=line1%0d%0aline2%0d%0aline3}
+
+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>"
+
+unset url
+unset port
+close $listen
generated by cgit v0.12 at 2024-11-02 01:04:10 (GMT)