summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
authorpatthoyts <patthoyts@users.sourceforge.net>2009-04-10 09:37:52 (GMT)
committerpatthoyts <patthoyts@users.sourceforge.net>2009-04-10 09:37:52 (GMT)
commit6626a523f72667a745e0137510e8b65b4984bed0 (patch)
treecb986f83de3ab045e92d999f6b4bf58e10d25b49
parent9185b616460eb962ba1546ffb5db0eabd0d68619 (diff)
downloadtcl-6626a523f72667a745e0137510e8b65b4984bed0.zip
tcl-6626a523f72667a745e0137510e8b65b4984bed0.tar.gz
tcl-6626a523f72667a745e0137510e8b65b4984bed0.tar.bz2
Specific check for [Bug 26245326]
This bug is caused by receiving a partial HTTP response line which caused premature switching of the state in the client package before we received the whole line.
-rw-r--r--ChangeLog5
-rw-r--r--tests/http.test16
-rw-r--r--tests/httpd16
3 files changed, 34 insertions, 3 deletions
diff --git a/ChangeLog b/ChangeLog
index 81d42e7..ebe410b 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,8 @@
+2009-04-10 Pat Thoyts <patthoyts@users.sourceforge.net>
+
+ * tests/http.test: Added specific check for [Bug 26245326]
+ * tests/httpd: (return incomplete HTTP response header)
+
2009-04-08 Kevin B. Kenny <kennykb@acm.org>
* tools/tclZIC.tcl: Always emit files with Unix line termination.
diff --git a/tests/http.test b/tests/http.test
index dfc884c..c4006f9 100644
--- a/tests/http.test
+++ b/tests/http.test
@@ -12,7 +12,7 @@
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
#
-# RCS: @(#) $Id: http.test,v 1.49 2008/12/09 22:38:05 patthoyts Exp $
+# RCS: @(#) $Id: http.test,v 1.50 2009/04/10 09:37:52 patthoyts Exp $
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest 2
@@ -330,6 +330,16 @@ test http-3.23 {http::geturl parse failures} -body {
test http-3.24 {http::geturl parse failures} -body {
http::geturl http://somewhere/path?%query
} -returnCodes error -result {Illegal encoding character usage "%qu" in URL path}
+test http-3.25 {http::meta} {
+ set token [http::geturl $url -timeout 2000]
+ array set m [http::meta $token]
+ lsort [array names m]
+} {Content-Length Content-Type Date}
+test http-3.26 {http::meta} {
+ set token [http::geturl $url -headers {X-Check 1} -timeout 2000]
+ array set m [http::meta $token]
+ lsort [array names m]
+} {Content-Length Content-Type Date X-Check}
test http-4.1 {http::Event} {
set token [http::geturl $url -keepalive 0]
@@ -531,3 +541,7 @@ if {[info exists removeHttpd]} {
rename bgerror {}
::tcltest::cleanupTests
+
+# Local variables:
+# mode: tcl
+# End: \ No newline at end of file
diff --git a/tests/httpd b/tests/httpd
index b46a3f0..93ee08a 100644
--- a/tests/httpd
+++ b/tests/httpd
@@ -72,6 +72,10 @@ proc httpdRead { sock } {
# 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
@@ -195,17 +199,25 @@ proc httpdRespond { sock } {
}
# 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"
+ # 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"} {