From b6af2b07f487d514bc61607068a3ae45422f531c Mon Sep 17 00:00:00 2001
From: David Lichteblau <david@lichteblau.com>
Date: Sun, 23 Mar 2008 20:53:51 +0100
Subject: [PATCH] Escape non-ASCII characters in URIs

---
 doc/index.xml          |  6 +++++
 src/parse/unparse.lisp | 59 +++++++++++++++++++++++++++-----------------------
 2 files changed, 38 insertions(+), 27 deletions(-)

diff --git a/doc/index.xml b/doc/index.xml
index 1ed6410..96f13dc 100644
--- a/doc/index.xml
+++ b/doc/index.xml
@@ -74,6 +74,12 @@
 	<li>
 	  Don't escape &lt; in attributes.
 	</li>
+	<li>
+	  Don't escape &amp;{ in attributes.
+	</li>
+	<li>
+	  Escape non-ASCII characters in URIs.
+	</li>
       </ul>
     </li>
     <li>
diff --git a/src/parse/unparse.lisp b/src/parse/unparse.lisp
index 622eb43..4f93ad3 100644
--- a/src/parse/unparse.lisp
+++ b/src/parse/unparse.lisp
@@ -90,40 +90,45 @@
 	  (%write-rune #/= sink)
 	  (%write-rune #/\" sink)
 	  (let ((value (hax:attribute-value a)))
-	    (when (uri-attribute-p aname)
+	    (when (uri-attribute-p name aname)
 	      (setf value (escape-uri-attribute value)))
 	    (unparse-attribute-string value sink))
 	  (%write-rune #/\" sink))))
     (%write-rune #/> sink)))
 
-;;; everything written as %URI in the DTD.  Complete list per element,
-;;; as found in the HTML 4.01 Strict DTD
-;;;
-;;; a          href
-;;; area       href
-;;; link       href
-;;; img        src longdesc usemap
-;;; object     classid codebase data usemap
-;;; q          cite
-;;; blockquote cite
-;;; inl        cite
-;;; del        cite
-;;; form       action
-;;; input      src usemap
-;;; head       profile
-;;; base       href
-;;; script     src for
-;;;
-;;; plus the reserved attribute datasrc.
-(defun uri-attribute-p (name)
-  (find (rod-downcase name)
-	'(#"action" #"cite" #"classid" #"codebase" #"data" #"for" #"href"
-	  #"longdesc" #"profile" #"src" #"usemap")
-	:test 'rod=))
+;;; everything written as %URI in the DTD:
+(defun uri-attribute-p (ename aname)
+  (find (rod-downcase aname)
+	(cdr (find (rod-downcase ename)
+		   '((#"a"          #"href")
+		     (#"area"       #"href")
+		     (#"link"       #"href")
+		     (#"img"        #"src" #"longdesc" #"usemap")
+		     (#"object"     #"classid" #"codebase" #"data" #"usemap")
+		     (#"q"          #"cite")
+		     (#"blockquote" #"cite")
+		     (#"inl"        #"cite")
+		     (#"del"        #"cite")
+		     (#"form"       #"action")
+		     (#"input"      #"src" #"usemap")
+		     (#"head"       #"profile")
+		     (#"base"       #"href")
+		     (#"script"     #"src"  ;; #"for"
+		      ))
+		   :key #'car
+		   :test #'rod=))
+	:test #'rod=))
 
 (defun escape-uri-attribute (x)
-  ;; implementme
-  x)
+  (string-rod
+   (with-output-to-string (s)
+     (loop
+	for c across (rod-to-utf8-string x)
+	for code = (char-code c)
+	do
+	  (if (< code 128)
+	      (write-char c s)
+	      (format s "%~2,'0X" code))))))
 
 (defmethod hax:end-element
     ((sink sink) name)
-- 
2.11.4.GIT