os/persistentdata/persistentstorage/sqlite3api/TEST/TCL/tcldistribution/tests/httpd
1.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
1.2 +++ b/os/persistentdata/persistentstorage/sqlite3api/TEST/TCL/tcldistribution/tests/httpd Fri Jun 15 03:10:57 2012 +0200
1.3 @@ -0,0 +1,218 @@
1.4 +#
1.5 +# The httpd_ procedures implement a stub http server.
1.6 +#
1.7 +# Copyright (c) 1997-1998 Sun Microsystems, Inc.
1.8 +# Copyright (c) 1999-2000 Scriptics Corporation
1.9 +#
1.10 +# See the file "license.terms" for information on usage and redistribution
1.11 +# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
1.12 +#
1.13 +# SCCS: @(#) httpd 1.2 98/02/20 14:51:59
1.14 +
1.15 +#set httpLog 1
1.16 +
1.17 +proc httpd_init {{port 8015}} {
1.18 + socket -server httpdAccept $port
1.19 +}
1.20 +proc httpd_log {args} {
1.21 + global httpLog
1.22 + if {[info exists httpLog] && $httpLog} {
1.23 + puts stderr "httpd: [join $args { }]"
1.24 + }
1.25 +}
1.26 +array set httpdErrors {
1.27 + 204 {No Content}
1.28 + 400 {Bad Request}
1.29 + 401 {Authorization Required}
1.30 + 404 {Not Found}
1.31 + 503 {Service Unavailable}
1.32 + 504 {Service Temporarily Unavailable}
1.33 + }
1.34 +
1.35 +proc httpdError {sock code args} {
1.36 + global httpdErrors
1.37 + puts $sock "$code $httpdErrors($code)"
1.38 + httpd_log "error: [join $args { }]"
1.39 +}
1.40 +proc httpdAccept {newsock ipaddr port} {
1.41 + global httpd
1.42 + upvar #0 httpd$newsock data
1.43 +
1.44 + fconfigure $newsock -blocking 0 -translation {auto crlf}
1.45 + httpd_log $newsock Connect $ipaddr $port
1.46 + set data(ipaddr) $ipaddr
1.47 + fileevent $newsock readable [list httpdRead $newsock]
1.48 +}
1.49 +
1.50 +# read data from a client request
1.51 +
1.52 +proc httpdRead { sock } {
1.53 + upvar #0 httpd$sock data
1.54 +
1.55 + if {[eof $sock]} {
1.56 + set readCount -1
1.57 + } elseif {![info exists data(state)]} {
1.58 +
1.59 + # Read the protocol line and parse out the URL and query
1.60 +
1.61 + set readCount [gets $sock line]
1.62 + if [regexp {(POST|GET|HEAD) ([^?]+)\??([^ ]*) HTTP/(1.[01])} \
1.63 + $line x data(proto) data(url) data(query) data(httpversion)] {
1.64 + set data(state) mime
1.65 + httpd_log $sock Query $line
1.66 + } else {
1.67 + httpdError $sock 400
1.68 + httpd_log $sock Error "bad first line:$line"
1.69 + httpdSockDone $sock
1.70 + }
1.71 + return
1.72 + } elseif {$data(state) == "mime"} {
1.73 +
1.74 + # Read the HTTP headers
1.75 +
1.76 + set readCount [gets $sock line]
1.77 + } elseif {$data(state) == "query"} {
1.78 +
1.79 + # Read the query data
1.80 +
1.81 + if {![info exists data(length_orig)]} {
1.82 + set data(length_orig) $data(length)
1.83 + }
1.84 + set line [read $sock $data(length)]
1.85 + set readCount [string length $line]
1.86 + incr data(length) -$readCount
1.87 + }
1.88 +
1.89 + # string compare $readCount 0 maps -1 to -1, 0 to 0, and > 0 to 1
1.90 +
1.91 + set state [string compare $readCount 0],$data(state),$data(proto)
1.92 + httpd_log $sock $state
1.93 + switch -- $state {
1.94 + -1,mime,HEAD -
1.95 + -1,mime,GET -
1.96 + -1,mime,POST {
1.97 + # gets would block
1.98 + return
1.99 + }
1.100 + 0,mime,HEAD -
1.101 + 0,mime,GET -
1.102 + 0,query,POST {
1.103 + # Empty line at end of headers,
1.104 + # or eof after query data
1.105 + httpdRespond $sock
1.106 + }
1.107 + 0,mime,POST {
1.108 + # Empty line between headers and query data
1.109 + if {![info exists data(mime,content-length)]} {
1.110 + httpd_log $sock Error "No Content-Length for POST"
1.111 + httpdError $sock 400
1.112 + httpdSockDone $sock
1.113 + } else {
1.114 + set data(state) query
1.115 + set data(length) $data(mime,content-length)
1.116 +
1.117 + # Special case to simulate servers that respond
1.118 + # without reading the post data.
1.119 +
1.120 + if {[string match *droppost* $data(url)]} {
1.121 + fileevent $sock readable {}
1.122 + httpdRespond $sock
1.123 + }
1.124 + }
1.125 + }
1.126 + 1,mime,HEAD -
1.127 + 1,mime,POST -
1.128 + 1,mime,GET {
1.129 + # A line of HTTP headers
1.130 + if {[regexp {([^:]+):[ ]*(.*)} $line dummy key value]} {
1.131 + set data(mime,[string tolower $key]) $value
1.132 + }
1.133 + }
1.134 + -1,query,POST {
1.135 + httpd_log $sock Error "unexpected eof on <$data(url)> request"
1.136 + httpdError $sock 400
1.137 + httpdSockDone $sock
1.138 + }
1.139 + 1,query,POST {
1.140 + append data(query) $line
1.141 + if {$data(length) <= 0} {
1.142 + set data(length) $data(length_orig)
1.143 + httpdRespond $sock
1.144 + }
1.145 + }
1.146 + default {
1.147 + if {[eof $sock]} {
1.148 + httpd_log $sock Error "unexpected eof on <$data(url)> request"
1.149 + } else {
1.150 + httpd_log $sock Error "unhandled state <$state> fetching <$data(url)>"
1.151 + }
1.152 + httpdError $sock 404
1.153 + httpdSockDone $sock
1.154 + }
1.155 + }
1.156 +}
1.157 +proc httpdSockDone { sock } {
1.158 + upvar #0 httpd$sock data
1.159 + unset data
1.160 + catch {close $sock}
1.161 +}
1.162 +
1.163 +# Respond to the query.
1.164 +
1.165 +proc httpdRespond { sock } {
1.166 + global httpd bindata port
1.167 + upvar #0 httpd$sock data
1.168 +
1.169 + switch -glob -- $data(url) {
1.170 + *binary* {
1.171 + set html "$bindata[info hostname]:$port$data(url)"
1.172 + set type application/octet-stream
1.173 + }
1.174 + *post* {
1.175 + set html "Got [string length $data(query)] bytes"
1.176 + set type text/plain
1.177 + }
1.178 + default {
1.179 + set type text/html
1.180 +
1.181 + set html "<html><head><title>HTTP/1.0 TEST</title></head><body>
1.182 +<h1>Hello, World!</h1>
1.183 +<h2>$data(proto) $data(url)</h2>
1.184 +"
1.185 + if {[info exists data(query)] && [string length $data(query)]} {
1.186 + append html "<h2>Query</h2>\n<dl>\n"
1.187 + foreach {key value} [split $data(query) &=] {
1.188 + append html "<dt>$key<dd>$value\n"
1.189 + if {$key == "timeout"} {
1.190 + after $value ;# pause
1.191 + }
1.192 + }
1.193 + append html </dl>\n
1.194 + }
1.195 + append html </body></html>
1.196 + }
1.197 + }
1.198 +
1.199 + # Catch errors from premature client closes
1.200 +
1.201 + catch {
1.202 + if {$data(proto) == "HEAD"} {
1.203 + puts $sock "HTTP/1.0 200 OK"
1.204 + } else {
1.205 + puts $sock "HTTP/1.0 200 Data follows"
1.206 + }
1.207 + puts $sock "Date: [clock format [clock clicks]]"
1.208 + puts $sock "Content-Type: $type"
1.209 + puts $sock "Content-Length: [string length $html]"
1.210 + puts $sock ""
1.211 + flush $sock
1.212 + if {$data(proto) != "HEAD"} {
1.213 + fconfigure $sock -translation binary
1.214 + puts -nonewline $sock $html
1.215 + }
1.216 + }
1.217 + httpd_log $sock Done ""
1.218 + httpdSockDone $sock
1.219 +}
1.220 +
1.221 +