diff -r 000000000000 -r bde4ae8d615e os/persistentdata/persistentstorage/sqlite3api/TEST/TCL/tcldistribution/tests/httpd
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/os/persistentdata/persistentstorage/sqlite3api/TEST/TCL/tcldistribution/tests/httpd Fri Jun 15 03:10:57 2012 +0200
@@ -0,0 +1,218 @@
+#
+# The httpd_ procedures implement a stub http server.
+#
+# Copyright (c) 1997-1998 Sun Microsystems, Inc.
+# Copyright (c) 1999-2000 Scriptics Corporation
+#
+# 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
+
+#set httpLog 1
+
+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}
+ 401 {Authorization Required}
+ 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
+
+ if {[eof $sock]} {
+ set readCount -1
+ } elseif {![info exists data(state)]} {
+
+ # Read the protocol line and parse out the URL and query
+
+ set readCount [gets $sock line]
+ if [regexp {(POST|GET|HEAD) ([^?]+)\??([^ ]*) HTTP/(1.[01])} \
+ $line x data(proto) data(url) data(query) data(httpversion)] {
+ set data(state) mime
+ httpd_log $sock Query $line
+ } else {
+ httpdError $sock 400
+ httpd_log $sock Error "bad first line:$line"
+ httpdSockDone $sock
+ }
+ return
+ } elseif {$data(state) == "mime"} {
+
+ # Read the HTTP headers
+
+ set readCount [gets $sock line]
+ } elseif {$data(state) == "query"} {
+
+ # Read the query data
+
+ if {![info exists data(length_orig)]} {
+ set data(length_orig) $data(length)
+ }
+ set line [read $sock $data(length)]
+ set readCount [string length $line]
+ incr data(length) -$readCount
+ }
+
+ # 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 {
+ # Empty line at end of headers,
+ # or eof after query data
+ httpdRespond $sock
+ }
+ 0,mime,POST {
+ # Empty line between headers and query data
+ if {![info exists data(mime,content-length)]} {
+ httpd_log $sock Error "No Content-Length for POST"
+ httpdError $sock 400
+ httpdSockDone $sock
+ } else {
+ set data(state) query
+ set data(length) $data(mime,content-length)
+
+ # Special case to simulate servers that respond
+ # without reading the post data.
+
+ if {[string match *droppost* $data(url)]} {
+ fileevent $sock readable {}
+ httpdRespond $sock
+ }
+ }
+ }
+ 1,mime,HEAD -
+ 1,mime,POST -
+ 1,mime,GET {
+ # A line of HTTP headers
+ if {[regexp {([^:]+):[ ]*(.*)} $line dummy key value]} {
+ set data(mime,[string tolower $key]) $value
+ }
+ }
+ -1,query,POST {
+ httpd_log $sock Error "unexpected eof on <$data(url)> request"
+ httpdError $sock 400
+ httpdSockDone $sock
+ }
+ 1,query,POST {
+ append data(query) $line
+ if {$data(length) <= 0} {
+ set data(length) $data(length_orig)
+ 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
+ catch {close $sock}
+}
+
+# Respond to the query.
+
+proc httpdRespond { sock } {
+ global httpd bindata port
+ upvar #0 httpd$sock data
+
+ switch -glob -- $data(url) {
+ *binary* {
+ set html "$bindata[info hostname]:$port$data(url)"
+ set type application/octet-stream
+ }
+ *post* {
+ set html "Got [string length $data(query)] bytes"
+ set type text/plain
+ }
+ default {
+ 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 {$key == "timeout"} {
+ after $value ;# pause
+ }
+ }
+ append html </dl>\n
+ }
+ append html </body></html>
+ }
+ }
+
+ # Catch errors from premature client closes
+
+ catch {
+ 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 ""
+ flush $sock
+ if {$data(proto) != "HEAD"} {
+ fconfigure $sock -translation binary
+ puts -nonewline $sock $html
+ }
+ }
+ httpd_log $sock Done ""
+ httpdSockDone $sock
+}
+
+