summaryrefslogtreecommitdiffstats
path: root/tests/http.test
diff options
context:
space:
mode:
authorstanton <stanton>1999-04-16 00:46:29 (GMT)
committerstanton <stanton>1999-04-16 00:46:29 (GMT)
commit97464e6cba8eb0008cf2727c15718671992b913f (patch)
treece9959f2747257d98d52ec8d18bf3b0de99b9535 /tests/http.test
parenta8c96ddb94d1483a9de5e340b740cb74ef6cafa7 (diff)
downloadtcl-97464e6cba8eb0008cf2727c15718671992b913f.zip
tcl-97464e6cba8eb0008cf2727c15718671992b913f.tar.gz
tcl-97464e6cba8eb0008cf2727c15718671992b913f.tar.bz2
merged tcl 8.1 branch back into the main trunk
Diffstat (limited to 'tests/http.test')
-rw-r--r--tests/http.test202
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
+
+
+
+
+
+
+
+
+
+
+
+