diff options
Diffstat (limited to 'tests/http.test')
| -rw-r--r-- | tests/http.test | 202 |
1 files changed, 50 insertions, 152 deletions
diff --git a/tests/http.test b/tests/http.test index c4ddbf8..752e3a2 100644 --- a/tests/http.test +++ b/tests/http.test @@ -6,21 +6,24 @@ # # 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: http.test,v 1.3 1998/11/03 02:00:54 welch Exp $ +# RCS: @(#) $Id: http.test,v 1.4 1999/04/16 00:47:28 stanton Exp $ -if {[string compare test [info procs test]] == 1} then {source defs} +if {[lsearch [namespace children] ::tcltest] == -1} { + source [file join [pwd] [file dirname [info script]] defs.tcl] +} if {[catch {package require http 2.0}]} { if {[info exist http2]} { - catch {puts stderr "Cannot load http 2.0 package"} + catch {puts "Cannot load http 2.0 package"} return } else { - catch {puts stderr "Running http 2.0 tests in slave interp"} + catch {puts "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]] @@ -29,160 +32,34 @@ if {[catch {package require http 2.0}]} { } } -############### 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 port 8010 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" +set httpdFile [file join $::tcltest::testsDir httpd] +if {[info commands testthread] == "testthread" && [file exists $httpdFile]} { + set httpthread [testthread create " + source $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 } - 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 + source $httpdFile + if [catch {httpd_init $port} listen] { + puts "Cannot start http server, http test skipped" + unset port + return } - 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 @@ -412,6 +289,27 @@ test http-6.1 {http::ProxyRequired} { <h2>GET http://$url</h2> </body></html>" +# cleanup unset url unset port -close $listen +if {[info exists httpthread]} { + testthread send -async $httpthread { + testthread exit + } +} else { + close $listen +} +::tcltest::cleanupTests +return + + + + + + + + + + + + |