output encoding fixes
authorDavid Lichteblau <david@lichteblau.com>
Fri, 9 May 2008 23:09:08 +0000 (10 01:09 +0200)
committerDavid Lichteblau <david@radon.(none)>
Fri, 9 May 2008 23:09:08 +0000 (10 01:09 +0200)
src/parse/unparse.lisp

index 33abfb6..dc303c8 100644 (file)
@@ -15,7 +15,8 @@
 
 (defclass sink (hax:abstract-handler)
     ((ystream :initarg :ystream :accessor sink-ystream)
-     (stack :initform nil :accessor stack)))
+     (stack :initform nil :accessor stack)
+     (encoding :initarg :encoding :reader sink-encoding)))
 
 #-rune-is-character
 (defmethod hax:%want-strings-p ((handler sink))
 ;; bisschen unschoen hier SCHON WIEDER die ganze api zu duplizieren, aber die
 ;; ystreams sind noch undokumentiert
 (macrolet ((define-maker (make-sink make-ystream &rest args)
-            `(defun ,make-sink (,@args &rest initargs)
-               (apply #'make-instance
+            `(defun ,make-sink (,@args &rest initargs
+                                       &key encoding &allow-other-keys)
+               (let* ((encoding (or encoding "UTF-8"))
+                      (ystream (,make-ystream ,@args)))
+                 (setf (ystream-encoding ystream)
+                       (cxml::find-output-encoding encoding))
+                 (apply #'make-instance
                       'sink
-                      :ystream (,make-ystream ,@args)
-                      initargs))))
+                      :ystream ystream
+                      :encoding encoding
+                      initargs)))))
   (define-maker make-octet-vector-sink make-octet-vector-ystream)
   (define-maker make-octet-stream-sink make-octet-stream-ystream stream)
   (define-maker make-rod-sink make-rod-ystream)
 #+rune-is-character
 (defun make-string-sink (&rest args) (apply #'make-rod-sink args))
 
+(defmethod initialize-instance :after ((instance sink) &key)
+  ;; not sure about this.  We do it for XML, but the HTML parser doesn't
+  ;; currently look for it.
+;;;   (when (let ((encoding (ystream-encoding (sink-ystream instance))))
+;;;      (and (not (symbolp encoding))
+;;;           (eq (babel-encodings:enc-name encoding) :utf-16)))
+;;;     (sink-write-rune #/U+FEFF instance))
+  )
 
 ;;;; Events
 
 (defmethod hax:start-document ((sink sink) name public-id system-id)
   (when (plusp (length system-id))
-    (%write-rod #"<!DOCTYPE " sink)
-    (%write-rod name sink)
+    (sink-write-rod #"<!DOCTYPE " sink)
+    (sink-write-rod name sink)
     (cond
       ((plusp (length public-id))
-       (%write-rod #" PUBLIC \"" sink)
+       (sink-write-rod #" PUBLIC \"" sink)
        (unparse-string public-id sink)
-       (%write-rod #"\" \"" sink)
+       (sink-write-rod #"\" \"" sink)
        (unparse-string system-id sink)
-       (%write-rod #"\"" sink))
+       (sink-write-rod #"\"" sink))
       (t
-       (%write-rod #" SYSTEM \"" sink)
+       (sink-write-rod #" SYSTEM \"" sink)
        (unparse-string system-id sink)
-       (%write-rod #"\"" sink)))
-    (%write-rod #">" sink)
-    (%write-rune #/U+000A sink)))
+       (sink-write-rod #"\"" sink)))
+    (sink-write-rod #">" sink)
+    (sink-write-rune #/U+000A sink)))
 
 (defmethod hax:end-document ((sink sink))
   (close-ystream (sink-ystream sink)))
          (and key (sgml::find-element closure-html::*html-dtd* key nil nil)))
         (attlist (and elt (sgml::element-attlist elt))))
     (push (cons name elt) (stack sink))
-    (%write-rune #/< sink)
-    (%write-rod name sink)
+    (sink-write-rune #/< sink)
+    (sink-write-rod name sink)
     (dolist (a attributes)
       (let* ((aname (hax:attribute-name a))
             (akey (find-symbol (string-upcase (string-rod aname)) :keyword))
             (att (and akey (assoc akey attlist)))
             (values (second att)))
-       (%write-rune #/space sink)
-       (%write-rod aname sink)
+       (sink-write-rune #/space sink)
+       (sink-write-rod aname sink)
        (unless (and att (listp values) (eq (car att) (car values)))
-         (%write-rune #/= sink)
-         (%write-rune #/\" sink)
+         (sink-write-rune #/= sink)
+         (sink-write-rune #/\" sink)
          (let ((value (hax:attribute-value a)))
            (when (uri-attribute-p name aname)
              (setf value (escape-uri-attribute value)))
            (unparse-attribute-string value sink))
-         (%write-rune #/\" sink))))
-    (%write-rune #/> sink)))
+         (sink-write-rune #/\" sink))))
+    (sink-write-rune #/> sink)))
 
 ;;; everything written as %URI in the DTD:
 ;;;
       (error "output does not nest: expected ~A but got ~A"
              name prev-name))
     (unless (and elt (null (sgml::element-include elt)))
-      (%write-rod '#.(string-rod "</") sink)
-      (%write-rod name sink)
-      (%write-rod '#.(string-rod ">") sink))))
+      (sink-write-rod '#.(string-rod "</") sink)
+      (sink-write-rod name sink)
+      (sink-write-rod '#.(string-rod ">") sink))))
 
 (defmethod hax:characters ((sink sink) data)
   (let ((y (sink-ystream sink)))
        (loop for c across data do (unparse-datachar-readable c y)))))
 
 (defmethod hax:unescaped ((sink sink) data)
-  (%write-rod data sink))
+  (sink-write-rod data sink))
 
 (defmethod hax:comment ((sink sink) data)
   ;; XXX signal error if body is unprintable?
-  (%write-rod #"<!--" sink)
-  (map nil (lambda (c) (%write-rune c sink)) data)
-  (%write-rod #"-->" sink))
+  (sink-write-rod #"<!--" sink)
+  (map nil (lambda (c) (sink-write-rune c sink)) data)
+  (sink-write-rod #"-->" sink))
 
 (defun unparse-string (str sink)
   (let ((y (sink-ystream sink)))
         (t
          (ystream-write-escapable-rune c ystream))))
 
-(defun %write-rune (c sink)
+(defun sink-write-rune (c sink)
   (ystream-write-rune c (sink-ystream sink)))
 
-(defun %write-rod (r sink)
+(defun sink-write-rod (r sink)
   (ystream-write-rod r (sink-ystream sink)))