[Bug 3391977]: Ensure that the -headers option to http::geturl overrides the

-type option (important because -type has a default that is not always
appropriate, and the header must not be duplicated).

4 files changed, 46 insertions, 1 deletions

diff --git a/ChangeLog b/ChangeLog
index 257545c..40814b2 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,10 @@
+2011-09-16  Donal K. Fellows  <dkf@users.sf.net>
+
+	* library/http/http.tcl (http::geturl): [Bug 3391977]: Ensure that the
+	-headers option overrides the -type option (important because -type
+	has a default that is not always appropriate, and the header must not
+	be duplicated).
+
 2011-09-13  Don Porter  <dgp@users.sourceforge.net>
 
 	* generic/tclUtil.c:	[Bug 3390638] Workaround broken solaris
diff --git a/library/http/http.tcl b/library/http/http.tcl
index aaef2b8..1c2b182 100644
--- a/library/http/http.tcl
+++ b/library/http/http.tcl
@@ -674,6 +674,7 @@ proc http::geturl {url args} {
 	    puts $sock "Proxy-Connection: Keep-Alive"
         }
         set accept_encoding_seen 0
+	set content_type_seen 0
 	foreach {key value} $state(-headers) {
 	    if {[string equal -nocase $key "host"]} {
 		continue
@@ -681,6 +682,9 @@ proc http::geturl {url args} {
 	    if {[string equal -nocase $key "accept-encoding"]} {
 		set accept_encoding_seen 1
 	    }
+	    if {[string equal -nocase $key "content-type"]} {
+		set content_type_seen 1
+	    }
 	    set value [string map [list \n "" \r ""] $value]
 	    set key [string trim $key]
 	    if {[string equal -nocase $key "content-length"]} {
@@ -729,7 +733,9 @@ proc http::geturl {url args} {
 	# response.
 
 	if {$isQuery || $isQueryChannel} {
-	    puts $sock "Content-Type: $state(-type)"
+	    if {!$content_type_seen} {
+		puts $sock "Content-Type: $state(-type)"
+	    }
 	    if {!$contDone} {
 		puts $sock "Content-Length: $state(querylength)"
 	    }
diff --git a/tests/http.test b/tests/http.test
index 602047f..6dcb612 100644
--- a/tests/http.test
+++ b/tests/http.test
@@ -327,6 +327,30 @@ 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::geturl: -headers override -type} -body {
+    set token [http::geturl $url/headers -type "text/plain" -query dummy \
+	    -headers [list "Content-Type" "text/plain;charset=utf-8"]]
+    http::data $token
+} -cleanup {
+    http::cleanup $token
+} -match regexp -result {(?n)Accept \*/\*
+Host .*
+User-Agent .*
+Connection close
+Content-Type {text/plain;charset=utf-8}
+Content-Length 5}
+test http-3.26 {http::geturl: -headers override -type default} -body {
+    set token [http::geturl $url/headers -query dummy \
+	    -headers [list "Content-Type" "text/plain;charset=utf-8"]]
+    http::data $token
+} -cleanup {
+    http::cleanup $token
+} -match regexp -result {(?n)Accept \*/\*
+Host .*
+User-Agent .*
+Connection close
+Content-Type {text/plain;charset=utf-8}
+Content-Length 5}
 
 test http-4.1 {http::Event} {
     set token [http::geturl $url -keepalive 0]
diff --git a/tests/httpd b/tests/httpd
index 5272385..f810797 100644
--- a/tests/httpd
+++ b/tests/httpd
@@ -175,6 +175,14 @@ proc httpdRespond { sock } {
 	    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