From 6626a523f72667a745e0137510e8b65b4984bed0 Mon Sep 17 00:00:00 2001
From: patthoyts <patthoyts@users.sourceforge.net>
Date: Fri, 10 Apr 2009 09:37:52 +0000
Subject: 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.

---
 ChangeLog       |  5 +++++
 tests/http.test | 16 +++++++++++++++-
 tests/httpd     | 16 ++++++++++++++--
 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"} {
-- 
cgit v0.12