diff options
Diffstat (limited to 'tests/httpd')
| -rw-r--r-- | tests/httpd | 252 |
1 files changed, 0 insertions, 252 deletions
diff --git a/tests/httpd b/tests/httpd deleted file mode 100644 index 982f3b8..0000000 --- a/tests/httpd +++ /dev/null @@ -1,252 +0,0 @@ -# -*- tcl -*- -# -# 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. - -#set httpLog 1 - -if {$::tcl_platform(os) eq "Darwin"} { - # Name resolution often a problem on OSX; not focus of HTTP package anyway - set HOST localhost -} else { - set HOST [info hostname] -} - -proc httpd_init {{port 8015}} { - set s [socket -server httpdAccept $port] - # Save the actual port number in a global variable. - # This is important when we're called with port 0 - # for picking an unused port at random. - set ::port [lindex [chan configure $s -sockname] 2] - return $s -} -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 - after 50 [list 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 \ - -> 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] - if {[regexp {^([^:]+):(.*)$} $line -> key val]} { - lappend data(meta) $key [string trim $val] - } - - } 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${::HOST}:$port$data(url)" - set type application/octet-stream - } - *xml* { - set html [encoding convertto utf-8 "<test>\u1234</test>"] - set type "application/xml;charset=UTF-8" - } - *post* { - set html "Got [string length $data(query)] bytes" - set type text/plain - } - *headers* { - set html "" - set type text/plain - foreach {key value} $data(meta) { - append html [list $key $value] "\n" - } - set html [string trim $html] - } - 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 { - # Split the response to test for [Bug 26245326] - puts -nonewline $sock "HT" - flush $sock - puts $sock "TP/1.0 200 Data follows" - } - puts $sock "Date: [clock format [clock seconds] \ - -format {%a, %d %b %Y %H:%M:%S %Z}]" - puts $sock "Content-Type: $type" - puts $sock "Content-Length: [string length $html]" - foreach {key val} $data(meta) { - if {[string match "X-*" $key]} { - puts $sock "$key: $val" - } - } - puts $sock "" - flush $sock - if {$data(proto) != "HEAD"} { - fconfigure $sock -translation binary - puts -nonewline $sock $html - } - } - httpd_log $sock Done "" - httpdSockDone $sock -} |