diff options
Diffstat (limited to 'tests/httpold.test')
| -rw-r--r-- | tests/httpold.test | 441 |
1 files changed, 0 insertions, 441 deletions
diff --git a/tests/httpold.test b/tests/httpold.test deleted file mode 100644 index 5d874f6..0000000 --- a/tests/httpold.test +++ /dev/null @@ -1,441 +0,0 @@ -# Commands covered: http_config, http_get, 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-1999 by Scriptics Corporation. -# -# See the file "license.terms" for information on usage and redistribution -# of this file, and for a DISCLAIMER OF ALL WARRANTIES. -# -# RCS: @(#) $Id: httpold.test,v 1.3 1999/04/16 00:47:28 stanton Exp $ - -if {[lsearch [namespace children] ::tcltest] == -1} { - source [file join [pwd] [file dirname [info script]] defs.tcl] -} - -if {[catch {package require http 1.0}]} { - if {[info exist httpold]} { - catch {puts "Cannot load http 1.0 package"} - ::tcltest::cleanupTests - return - } else { - catch {puts "Running http 1.0 tests in slave interp"} - set interp [interp create httpold] - $interp eval [list set httpold "running"] - $interp eval [list source [info script]] - interp delete $interp - ::tcltest::cleanupTests - 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 "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 - catch {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" - if {[string compare $key timeout] == 0} { - # Simulate a timeout by not responding, - # but clean up our socket later. - - after 50 [list httpdSockDone $sock] - httpd_log $sock Noresponse "" - return - } - } - 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 "Cannot start http server, http test skipped" - unset port - ::tcltest::cleanupTests - return -} - -test http-1.1 {http_config} { - http_config -} {-accept */* -proxyfilter httpProxyRequired -proxyhost {} -proxyport {} -useragent {Tcl http client package 1.0}} - -test http-1.2 {http_config} { - http_config -proxyfilter -} httpProxyRequired - -test http-1.3 {http_config} { - catch {http_config -junk} -} 1 - -test http-1.4 {http_config} { - http_config -proxyhost nowhere.come -proxyport 8080 -proxyfilter myFilter -useragent "Tcl Test Suite" - set x [http_config] - http_config -proxyhost {} -proxyport {} -proxyfilter httpProxyRequired \ - -useragent "Tcl http client package 1.0" - 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_get} { - catch {http_get -bogus flag} -} 1 -test http-3.2 {http_get} { - catch {http_get http:junk} err - set err -} {Unsupported URL: http:junk} - -set url [info hostname]:$port -test http-3.3 {http_get} { - set token [http_get $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_get} { - set token [http_get $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_get} { - http_config -proxyfilter selfproxy - set token [http_get $url] - http_config -proxyfilter httpProxyRequired - 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_get} { - http_config -proxyfilter bogus - set token [http_get $url] - http_config -proxyfilter httpProxyRequired - 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_get} { - set token [http_get $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_get} { - set token [http_get $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_get} { - set token [http_get $url -validate 1] - http_code $token -} "HTTP/1.0 200 OK" - - -test http-4.1 {httpEvent} { - set token [http_get $url] - upvar #0 $token data - array set meta $data(meta) - expr ($data(totalsize) == $meta(Content-Length)) -} 1 - -test http-4.2 {httpEvent} { - set token [http_get $url] - upvar #0 $token data - array set meta $data(meta) - string compare $data(type) [string trim $meta(Content-Type)] -} 0 - -test http-4.3 {httpEvent} { - set token [http_get $url] - http_code $token -} {HTTP/1.0 200 Data follows} - -test http-4.4 {httpEvent} { - set out [open testfile w] - set token [http_get $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 {httpEvent} { - set out [open testfile w] - set token [http_get $url -channel $out] - close $out - upvar #0 $token data - file delete testfile - expr $data(currentsize) == $data(totalsize) -} 1 - -test http-4.6 {httpEvent} { - set out [open testfile w] - set token [http_get $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 {httpEvent} { - set token [http_get $url -blocksize 50 -progress myProgress] - set progress - } {111 111} -} -test http-4.7 {httpEvent} { - set token [http_get $url -progress myProgress] - set progress -} {111 111} -test http-4.8 {httpEvent} { - set token [http_get $url] - http_status $token -} {ok} -test http-4.9 {httpEvent} { - set token [http_get $url -progress myProgress] - http_code $token -} {HTTP/1.0 200 Data follows} -test http-4.10 {httpEvent} { - set token [http_get $url -progress myProgress] - http_size $token -} {111} -test http-4.11 {httpEvent} { - set token [http_get $url -timeout 1 -command {#}] - http_reset $token - http_status $token -} {reset} -test http-4.12 {httpEvent} { - update - set x {} - after 500 {lappend x ok} - set token [http_get $url -timeout 1 -command {lappend x fail}] - vwait x - list [http_status $token] $x -} {timeout ok} - -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 {httpProxyRequired} { - update - http_config -proxyhost [info hostname] -proxyport $port - set token [http_get $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>" - -# cleanup -unset url -unset port -close $listen -::tcltest::cleanupTests -return - - - - - - - - - - - - |