merged tcl 8.1 branch back into the main trunk

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