diff options
| author | stanton <stanton> | 1999-04-16 00:46:29 (GMT) |
|---|---|---|
| committer | stanton <stanton> | 1999-04-16 00:46:29 (GMT) |
| commit | 97464e6cba8eb0008cf2727c15718671992b913f (patch) | |
| tree | ce9959f2747257d98d52ec8d18bf3b0de99b9535 /tests/httpd | |
| parent | a8c96ddb94d1483a9de5e340b740cb74ef6cafa7 (diff) | |
| download | tcl-97464e6cba8eb0008cf2727c15718671992b913f.zip tcl-97464e6cba8eb0008cf2727c15718671992b913f.tar.gz tcl-97464e6cba8eb0008cf2727c15718671992b913f.tar.bz2 | |
merged tcl 8.1 branch back into the main trunk
Diffstat (limited to 'tests/httpd')
| -rw-r--r-- | tests/httpd | 148 |
1 files changed, 148 insertions, 0 deletions
diff --git a/tests/httpd b/tests/httpd new file mode 100644 index 0000000..1531964 --- /dev/null +++ b/tests/httpd @@ -0,0 +1,148 @@ +# +# The httpd_ procedures implement a stub http server. +# +# Copyright (c) 1997-1998 Sun Microsystems, Inc. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# SCCS: @(#) httpd 1.2 98/02/20 14:51:59 + +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. + +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" + } + 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" + } + 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 + } + httpd_log $sock Done "" + httpdSockDone $sock +} + + |