merged tcl 8.1 branch back into the main trunk

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
+
+
+
+
+
+
+
+
+
+
+
+