From b7a3af751c2791b0659d8fde644ea66d90f58791 Mon Sep 17 00:00:00 2001
From: dkf <donal.k.fellows@manchester.ac.uk>
Date: Sat, 8 Oct 2016 16:38:42 +0000
Subject: [838e99a76d] Ensure that encodings are handled with application/xml
 and friends.

---
 library/http/http.tcl | 34 +++++++++++++++++++++++++++++++++-
 tests/http.test       |  7 +++++++
 tests/httpd           |  4 ++++
 3 files changed, 44 insertions(+), 1 deletion(-)

diff --git a/library/http/http.tcl b/library/http/http.tcl
index 4c99f62..2975f82 100644
--- a/library/http/http.tcl
+++ b/library/http/http.tcl
@@ -1019,7 +1019,7 @@ proc http::Event {sock token} {
 	    fconfigure $sock -translation binary
 
 	    if {
-		$state(-binary) || ![string match -nocase text* $state(type)]
+		$state(-binary) || [IsBinaryContentType $state(type)]
 	    } then {
 		# Turn off conversions for non-text data
 		set state(binary) 1
@@ -1161,6 +1161,38 @@ proc http::Event {sock token} {
     }
 }
 
+# http::IsBinaryContentType --
+#
+#	Determine if the content-type means that we should definitely transfer
+#	the data as binary. [Bug 838e99a76d]
+#
+# Arguments
+#	type	The content-type of the data.
+#
+# Results:
+#	Boolean, true if we definitely should be binary.
+
+proc http::IsBinaryContentType {type} {
+    lassign [split [string tolower $type] "/;"] major minor
+    if {$major eq "text"} {
+	return false
+    }
+    # There's a bunch of XML-as-application-format things about. See RFC 3023
+    # and so on.
+    if {$major eq "application"} {
+	set minor [string trimright $minor]
+	if {$minor in {"xml" "xml-external-parsed-entity" "xml-dtd"}} {
+	    return false
+	}
+    }
+    # Not just application/foobar+xml but also image/svg+xml, so let us not
+    # restrict things for now...
+    if {[string match "*+xml" $minor]} {
+	return false
+    }
+    return true
+}
+
 # http::getTextLine --
 #
 #	Get one line with the stream in blocking crlf mode
diff --git a/tests/http.test b/tests/http.test
index 2fc0a51..322fb36 100644
--- a/tests/http.test
+++ b/tests/http.test
@@ -132,6 +132,7 @@ set tail /a/b/c
 set url //[info hostname]:$port/a/b/c
 set fullurl HTTP://user:pass@[info hostname]:$port/a/b/c
 set binurl //[info hostname]:$port/binary
+set xmlurl //[info hostname]:$port/xml
 set posturl //[info hostname]:$port/post
 set badposturl //[info hostname]:$port/droppost
 set authorityurl //[info hostname]:$port
@@ -364,6 +365,12 @@ test http-3.31 {http::geturl fragment without path} -body {
 } -cleanup {
     catch { http::cleanup $token }
 } -result 200
+test http-3.32 {http::geturl application/xml is text} -body {
+    set token [http::geturl "$xmlurl"]
+    scan [http::data $token] "<%\[^>]>%c<%\[^>]>"
+} -cleanup {
+    catch { http::cleanup $token }
+} -result {test 4660 /test}
 
 test http-4.1 {http::Event} {
     set token [http::geturl $url -keepalive 0]
diff --git a/tests/httpd b/tests/httpd
index 232e80a..8753912 100644
--- a/tests/httpd
+++ b/tests/httpd
@@ -171,6 +171,10 @@ proc httpdRespond { sock } {
 	    set html "$bindata[info hostname]:$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
-- 
cgit v0.12