diff options
Diffstat (limited to 'tests/httpold.test')
| -rw-r--r-- | tests/httpold.test | 52 |
1 files changed, 41 insertions, 11 deletions
diff --git a/tests/httpold.test b/tests/httpold.test index f6d5fe0..5d874f6 100644 --- a/tests/httpold.test +++ b/tests/httpold.test @@ -6,25 +6,29 @@ # # 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.2 1998/09/14 18:40:09 stanton Exp $ - -if {[string compare test [info procs test]] == 1} then {source defs} +# 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 stderr "Cannot load http 1.0 package"} + catch {puts "Cannot load http 1.0 package"} + ::tcltest::cleanupTests return } else { - catch {puts stderr "Running http 1.0 tests in slave interp"} + 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 } } @@ -36,7 +40,7 @@ proc httpd_init {{port 8015}} { proc httpd_log {args} { global httpLog if {[info exists httpLog] && $httpLog} { - puts stderr "httpd: [join $args { }]" + puts "httpd: [join $args { }]" } } array set httpdErrors { @@ -145,6 +149,14 @@ proc httpdRespond { sock } { 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 } @@ -171,8 +183,9 @@ proc httpdRespond { sock } { set port 8010 if [catch {httpd_init $port} listen] { - puts stderr "Cannot start http server, http test skipped" + puts "Cannot start http server, http test skipped" unset port + ::tcltest::cleanupTests return } @@ -376,10 +389,12 @@ test http-4.11 {httpEvent} { } {reset} test http-4.12 {httpEvent} { update - set token [http_get $url -timeout 1 -command {#}] - update - http_status $token -} {timeout} + 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" @@ -406,6 +421,21 @@ test http-6.1 {httpProxyRequired} { <h2>GET http://$url</h2> </body></html>" +# cleanup unset url unset port close $listen +::tcltest::cleanupTests +return + + + + + + + + + + + + |