summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
authorhobbs <hobbs>2000-02-05 12:37:57 (GMT)
committerhobbs <hobbs>2000-02-05 12:37:57 (GMT)
commitb1a627adb918460dca6a08f089350fd1b9a235a3 (patch)
tree3d5f8b0b768f0790a10ab998354c36c5a33fa884
parentf2697f9021bc81c9342e262abccc375582402efb (diff)
downloadtcl-b1a627adb918460dca6a08f089350fd1b9a235a3.zip
tcl-b1a627adb918460dca6a08f089350fd1b9a235a3.tar.gz
tcl-b1a627adb918460dca6a08f089350fd1b9a235a3.tar.bz2
* tests/httpold.test: changed test script to source in the httpd
server procs from httpd instead of having its own set.
-rw-r--r--ChangeLog3
-rw-r--r--tests/httpold.test155
2 files changed, 9 insertions, 149 deletions
diff --git a/ChangeLog b/ChangeLog
index ba8e3d1..194641c 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,5 +1,8 @@
2000-02-05 Jeff Hobbs <hobbs@scriptics.com>
+ * tests/httpold.test: changed test script to source in the httpd
+ server procs from httpd instead of having its own set.
+
* tests/httpd: improved query support in test httpd to handle fix
in http.tcl. [Bug: 4089 change 2000-02-01]
diff --git a/tests/httpold.test b/tests/httpold.test
index 3e8aa76..f6d02f4 100644
--- a/tests/httpold.test
+++ b/tests/httpold.test
@@ -11,7 +11,7 @@
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
-# RCS: @(#) $Id: httpold.test,v 1.6 1999/07/27 01:42:23 redman Exp $
+# RCS: @(#) $Id: httpold.test,v 1.7 2000/02/05 12:37:59 hobbs Exp $
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest
@@ -34,156 +34,13 @@ if {[catch {package require http 1.0}]} {
}
}
-catch {unset data}
-
-############### The httpd_ procedures implement a stub http server. ########
-proc httpd_init {{port 8015}} {
- socket -server httpdAccept $port
-}
-proc httpd_log {args} {
- global httpLog
- if {[info exists httpLog] && $httpLog} {
- puts "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
- after 10
- 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
- catch {close $sock}
-}
-
-# Respond to the query.
-
set bindata "This is binary data\x0d\x0amore\x0dmore\x0amore\x00null"
-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"
- if {[string compare $key timeout] == 0} {
- # Simulate a timeout by not responding,
- # but clean up our socket later.
-
- after 50 [list httpdSockDone $sock]
- httpd_log $sock Noresponse ""
- return
- }
- }
- append html </dl>\n
- }
- append html </body></html>
- }
+catch {unset data}
- 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
-}
-##################### end server ###########################
+##
+## The httpd script implement a stub http server
+##
+source [file join [file dirname [info script]] httpd]
set port 8010
if [catch {httpd_init $port} listen] {