summaryrefslogtreecommitdiffstats
path: root/tests/httpold.test
diff options
context:
space:
mode:
Diffstat (limited to 'tests/httpold.test')
-rw-r--r--tests/httpold.test52
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
+
+
+
+
+
+
+
+
+
+
+
+