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