escape % in internal entities

new function unparsed-internal-subset
use " to escape IDs containing '

xml/unparse.lisp

@@ -79,6 +79,7 @@
      (name-for-dtd :accessor name-for-dtd)
      (previous-notation :initform nil :accessor previous-notation)
      (have-doctype :initform nil :accessor have-doctype)
+     (have-internal-subset :initform nil :accessor have-internal-subset)
      (stack :initform nil :accessor stack)))
 
 (defmethod initialize-instance :after ((instance sink) &key)
@@ -156,6 +157,9 @@
         (%write-rod #"\"" sink)))))
 
 (defmethod sax:start-internal-subset ((sink sink))
+  (when (have-internal-subset sink)
+    (error "duplicate internal subset"))
+  (setf (have-internal-subset sink) t)
   (ensure-doctype sink)
   (%write-rod #" [" sink)
   (%write-rune #/U+000A sink))
@@ -164,6 +168,25 @@
   (ensure-doctype sink)
   (%write-rod #"]" sink))
 
+(defmethod sax:unparsed-internal-subset ((sink sink) str)
+  (when (have-internal-subset sink)
+    (error "duplicate internal subset"))
+  (setf (have-internal-subset sink) t)
+  (ensure-doctype sink)
+  (%write-rod #" [" sink)
+  (%write-rune #/U+000A sink)
+  (unparse-string str sink)
+  (%write-rod #"]" sink))
+
+;; for the benefit of the XML test suite, prefer ' over "
+(defun write-quoted-rod (x sink)
+  (let ((q (if (find #/' x) #/" #/'
+               ;; '" (thanks you Emacs indentation, the if ends here)
+		     )))
+    (%write-rune q sink)
+    (%write-rod x sink)
+    (%write-rune q sink)))
+
 (defmethod sax:notation-declaration ((sink sink) name public-id system-id)
   (let ((prev (previous-notation sink)))
     (when (and (and (canonical sink) (>= (canonical sink) 2))
@@ -175,19 +198,16 @@
   (%write-rod name sink)
   (cond
     ((zerop (length public-id))
-      (%write-rod #" SYSTEM '" sink)
+      (%write-rod #" SYSTEM " sink)
-      (%write-rod system-id sink)
+      (write-quoted-rod system-id sink))
-      (%write-rune #/' sink))
     ((zerop (length system-id))
-      (%write-rod #" PUBLIC '" sink)
+      (%write-rod #" PUBLIC " sink)
-      (%write-rod public-id sink)
+      (write-quoted-rod public-id sink))
-      (%write-rune #/' sink))
     (t 
-      (%write-rod #" PUBLIC '" sink)
+      (%write-rod #" PUBLIC " sink)
-      (%write-rod public-id sink)
+      (write-quoted-rod public-id sink)
-      (%write-rod #"' '" sink)
+      (%write-rod #" " sink)
-      (%write-rod system-id sink)
+      (write-quoted-rod system-id sink)))
-      (%write-rune #/' sink)))
   (%write-rune #/> sink)
   (%write-rune #/U+000A sink))
 
@@ -198,19 +218,16 @@
     (%write-rod name sink)
     (cond
       ((zerop (length public-id))
-	(%write-rod #" SYSTEM '" sink)
+	(%write-rod #" SYSTEM " sink)
-	(%write-rod system-id sink)
+	(write-quoted-rod system-id sink))
-	(%write-rune #/' sink))
       ((zerop (length system-id))
-	(%write-rod #" PUBLIC '" sink)
+	(%write-rod #" PUBLIC " sink)
-	(%write-rod public-id sink)
+	(write-quoted-rod public-id sink))
-	(%write-rune #/' sink))
       (t 
-	(%write-rod #" PUBLIC '" sink)
+	(%write-rod #" PUBLIC " sink)
-	(%write-rod public-id sink)
+	(write-quoted-rod public-id sink)
-	(%write-rod #"' '" sink)
+	(%write-rod #" " sink)
-	(%write-rod system-id sink)
+	(write-quoted-rod system-id sink)))
-	(%write-rune #/' sink)))
     (%write-rod #" NDATA " sink)
     (%write-rod notation-name sink)
     (%write-rune #/> sink)
@@ -226,19 +243,16 @@
   (%write-rod name sink)
   (cond
     ((zerop (length public-id))
-      (%write-rod #" SYSTEM '" sink)
+      (%write-rod #" SYSTEM " sink)
-      (%write-rod system-id sink)
+      (write-quoted-rod system-id sink))
-      (%write-rune #/' sink))
     ((zerop (length system-id))
-      (%write-rod #" PUBLIC '" sink)
+      (%write-rod #" PUBLIC " sink)
-      (%write-rod public-id sink)
+      (write-quoted-rod public-id sink))
-      (%write-rune #/' sink))
     (t 
-      (%write-rod #" PUBLIC '" sink)
+      (%write-rod #" PUBLIC " sink)
-      (%write-rod public-id sink)
+      (write-quoted-rod public-id sink)
-      (%write-rod #"' '" sink)
+      (%write-rod #" " sink)
-      (%write-rod system-id sink)
+      (write-quoted-rod system-id sink)))
-      (%write-rune #/' sink)))
   (%write-rune #/> sink)
   (%write-rune #/U+000A sink))
 
@@ -251,7 +265,7 @@
   (%write-rod name sink)
   (%write-rune #/U+0020 sink)
   (%write-rune #/\" sink)
-  (unparse-string value sink)
+  (unparse-dtd-string value sink)
   (%write-rune #/\" sink)
   (%write-rune #/> sink)
   (%write-rune #/U+000A sink))
@@ -319,6 +333,7 @@
 	    (when rest
 	      (%write-rune #\| sink)))
       (%write-rune #/\) sink)))
+  (%write-rune #/U+0020 sink)
   (cond
     ((atom default)
       (%write-rune #/# sink)
@@ -498,6 +513,22 @@
         (t
           (write-rune c ystream))))
 
+(defun unparse-dtd-string (str sink)
+  (let ((y (sink-ystream sink)))
+    (loop for rune across str do (unparse-dtd-char rune y))))
+
+(defun unparse-dtd-char (c ystream)
+  (cond ((rune= c #/%) (write-rod '#.(string-rod "%") ystream))
+        ((rune= c #/&) (write-rod '#.(string-rod "&") ystream))
+        ((rune= c #/<) (write-rod '#.(string-rod "&lt;") ystream))
+        ((rune= c #/>) (write-rod '#.(string-rod "&gt;") ystream))
+        ((rune= c #/\") (write-rod '#.(string-rod "&quot;") ystream))
+        ((rune= c #/U+0009) (write-rod '#.(string-rod "&#9;") ystream))
+        ((rune= c #/U+000A) (write-rod '#.(string-rod "&#10;") ystream))
+        ((rune= c #/U+000D) (write-rod '#.(string-rod "&#13;") ystream))
+        (t
+         (write-rune c ystream))))
+
 (defun %write-rune (c sink)
   (write-rune c (sink-ystream sink)))