src/parse/unparse.lisp

   1 ;;; -*- show-trailing-whitespace: t; indent-tabs: nil -*-
   2 ;;; ---------------------------------------------------------------------------
   3 ;;;     Title: Unparse HTML
   4 ;;;   Created: 2007-10-14
   5 ;;;    Author: David Lichteblau <david@lichteblau.com>
   6 ;;;   License: BSD-style
   7 ;;; ---------------------------------------------------------------------------
   8 ;;;  (c) copyright 2005-2007 David Lichteblau
   9
  10
  11 (in-package :closure-html)
  12
  13
  14 ;;; SINK: an HTML output sink
  15
  16 (defclass sink (hax:abstract-handler)
  17     ((ystream :initarg :ystream :accessor sink-ystream)
  18      (stack :initform nil :accessor stack)
  19      (encoding :initarg :encoding :reader sink-encoding)))
  20
  21 #-rune-is-character
  22 (defmethod hax:%want-strings-p ((handler sink))
  23   nil)
  24
  25 ;; bisschen unschoen hier SCHON WIEDER die ganze api zu duplizieren, aber die
  26 ;; ystreams sind noch undokumentiert
  27 (macrolet ((define-maker (make-sink make-ystream &rest args)
  28              `(defun ,make-sink (,@args &rest initargs
  29                                         &key encoding &allow-other-keys)
  30                 (let* ((encoding (or encoding "UTF-8"))
  31                        (ystream (,make-ystream ,@args)))
  32                   (setf (ystream-encoding ystream)
  33                         (cxml::find-output-encoding encoding))
  34                   (apply #'make-instance
  35                        'sink
  36                        :ystream ystream
  37                        :encoding encoding
  38                        initargs)))))
  39   (define-maker make-octet-vector-sink make-octet-vector-ystream)
  40   (define-maker make-octet-stream-sink make-octet-stream-ystream stream)
  41   (define-maker make-rod-sink make-rod-ystream)
  42
  43   #+rune-is-character
  44   (define-maker make-character-stream-sink make-character-stream-ystream stream)
  45
  46   #-rune-is-character
  47   (define-maker make-string-sink/utf8 make-string-ystream/utf8)
  48
  49   #-rune-is-character
  50   (define-maker make-character-stream-sink/utf8
  51       make-character-stream-ystream/utf8
  52     stream))
  53
  54 #+rune-is-character
  55 (defun make-string-sink (&rest args) (apply #'make-rod-sink args))
  56
  57 (defmethod initialize-instance :after ((instance sink) &key)
  58   ;; not sure about this.  We do it for XML, but the HTML parser doesn't
  59   ;; currently look for it.
  60 ;;;   (when (let ((encoding (ystream-encoding (sink-ystream instance))))
  61 ;;;       (and (not (symbolp encoding))
  62 ;;;            (eq (babel-encodings:enc-name encoding) :utf-16)))
  63 ;;;     (sink-write-rune #/U+FEFF instance))
  64   )
  65
  66 ;;;; Events
  67
  68 (defmethod hax:start-document ((sink sink) name public-id system-id)
  69   (when (plusp (length system-id))
  70     (sink-write-rod #"<!DOCTYPE " sink)
  71     (sink-write-rod name sink)
  72     (cond
  73       ((plusp (length public-id))
  74        (sink-write-rod #" PUBLIC \"" sink)
  75        (unparse-string public-id sink)
  76        (sink-write-rod #"\" \"" sink)
  77        (unparse-string system-id sink)
  78        (sink-write-rod #"\"" sink))
  79       (t
  80        (sink-write-rod #" SYSTEM \"" sink)
  81        (unparse-string system-id sink)
  82        (sink-write-rod #"\"" sink)))
  83     (sink-write-rod #">" sink)
  84     (sink-write-rune #/U+000A sink)))
  85
  86 (defmethod hax:end-document ((sink sink))
  87   (close-ystream (sink-ystream sink)))
  88
  89 (defmethod hax:start-element ((sink sink) name attributes)
  90   (let* ((key (find-symbol (string-upcase (rod-string name)) :keyword))
  91          (elt
  92           (and key (sgml::find-element closure-html::*html-dtd* key nil nil)))
  93          (attlist (and elt (sgml::element-attlist elt))))
  94     (push (cons name elt) (stack sink))
  95     (sink-write-rune #/< sink)
  96     (sink-write-rod name sink)
  97     (dolist (a attributes)
  98       (let* ((aname (hax:attribute-name a))
  99              (akey (find-symbol (string-upcase (string-rod aname)) :keyword))
 100              (att (and akey (assoc akey attlist)))
 101              (values (second att)))
 102         (sink-write-rune #/space sink)
 103         (sink-write-rod aname sink)
 104         (unless (and att (listp values) (eq (car att) (car values)))
 105           (sink-write-rune #/= sink)
 106           (sink-write-rune #/\" sink)
 107           (let ((value (hax:attribute-value a)))
 108             (when (uri-attribute-p name aname)
 109               (setf value (escape-uri-attribute value)))
 110             (unparse-attribute-string value sink))
 111           (sink-write-rune #/\" sink))))
 112     (sink-write-rune #/> sink)))
 113
 114 ;;; everything written as %URI in the DTD:
 115 ;;;
 116 ;;; a/@name shouldn't be in here according to that rule, but
 117 ;;; the XSLT test suite wants it.
 118 (defun uri-attribute-p (ename aname)
 119   (find (rod-downcase aname)
 120         (cdr (find (rod-downcase ename)
 121                    '((#"a"          #"href" #"name")
 122                      (#"area"       #"href")
 123                      (#"link"       #"href")
 124                      (#"img"        #"src" #"longdesc" #"usemap")
 125                      (#"object"     #"classid" #"codebase" #"data" #"usemap")
 126                      (#"q"          #"cite")
 127                      (#"blockquote" #"cite")
 128                      (#"inl"        #"cite")
 129                      (#"del"        #"cite")
 130                      (#"form"       #"action")
 131                      (#"input"      #"src" #"usemap")
 132                      (#"head"       #"profile")
 133                      (#"base"       #"href")
 134                      (#"script"     #"src"  ;; #"for"
 135                       ))
 136                    :key #'car
 137                    :test #'rod=))
 138         :test #'rod=))
 139
 140 (defun escape-uri-attribute (x)
 141   (string-rod
 142    (with-output-to-string (s)
 143      (loop
 144         for c across (rod-to-utf8-string x)
 145         for code = (char-code c)
 146         do
 147           (if (< code 128)
 148               (write-char c s)
 149               (format s "%~2,'0X" code))))))
 150
 151 (defmethod hax:end-element
 152     ((sink sink) name)
 153   (let* ((prev (pop (stack sink)))
 154          (prev-name (car prev))
 155          (elt (cdr prev)))
 156     (unless (rod= prev-name name)
 157       (error "output does not nest: expected ~A but got ~A"
 158              name prev-name))
 159     (unless (and elt (null (sgml::element-include elt)))
 160       (sink-write-rod '#.(string-rod "</") sink)
 161       (sink-write-rod name sink)
 162       (sink-write-rod '#.(string-rod ">") sink))))
 163
 164 (defmethod hax:characters ((sink sink) data)
 165   (let ((y (sink-ystream sink)))
 166     (if (find (caar (stack sink)) '("script" "style") :test 'equalp)
 167         (ystream-write-escapable-rod data (sink-ystream sink))
 168         (loop for c across data do (unparse-datachar-readable c y)))))
 169
 170 (defmethod hax:unescaped ((sink sink) data)
 171   (sink-write-rod data sink))
 172
 173 (defmethod hax:comment ((sink sink) data)
 174   ;; XXX signal error if body is unprintable?
 175   (sink-write-rod #"<!--" sink)
 176   (map nil (lambda (c) (sink-write-rune c sink)) data)
 177   (sink-write-rod #"-->" sink))
 178
 179 (defun unparse-string (str sink)
 180   (let ((y (sink-ystream sink)))
 181     (loop for rune across str do (unparse-datachar rune y))))
 182
 183 (defun unparse-attribute-string (str sink)
 184   (let ((y (sink-ystream sink)))
 185     (loop
 186        for i from 1
 187        for c across str
 188        do
 189          (cond ((rune= c #/&)
 190                 (if (and (< i (length str)) (rune= (rune str i) #/{))
 191                     (ystream-write-rune c y)
 192                     (ystream-write-rod '#.(string-rod "&amp;") y)))
 193                ((rune= c #/\") (ystream-write-rod '#.(string-rod "&quot;") y))
 194                ((rune= c #/U+000A) (ystream-write-rod '#.(string-rod "&#10;") y))
 195                ((rune= c #/U+000D) (ystream-write-rod '#.(string-rod "&#13;") y))
 196                (t
 197                 (ystream-write-escapable-rune c y))))))
 198
 199 (defun unparse-datachar (c ystream)
 200   (cond ((rune= c #/&) (ystream-write-rod '#.(string-rod "&amp;") ystream))
 201         ((rune= c #/<) (ystream-write-rod '#.(string-rod "&lt;") ystream))
 202         ((rune= c #/>) (ystream-write-rod '#.(string-rod "&gt;") ystream))
 203         ((rune= c #/\") (ystream-write-rod '#.(string-rod "&quot;") ystream))
 204         ((rune= c #/U+0009) (ystream-write-rod '#.(string-rod "&#9;") ystream))
 205         ((rune= c #/U+000A) (ystream-write-rod '#.(string-rod "&#10;") ystream))
 206         ((rune= c #/U+000D) (ystream-write-rod '#.(string-rod "&#13;") ystream))
 207         (t
 208          (ystream-write-escapable-rune c ystream))))
 209
 210 (defun unparse-datachar-readable (c ystream)
 211   (cond ((rune= c #/&) (ystream-write-rod '#.(string-rod "&amp;") ystream))
 212         ((rune= c #/<) (ystream-write-rod '#.(string-rod "&lt;") ystream))
 213         ((rune= c #/>) (ystream-write-rod '#.(string-rod "&gt;") ystream))
 214         ((rune= c #/\") (ystream-write-rod '#.(string-rod "&quot;") ystream))
 215         ((rune= c #/U+000D) (ystream-write-rod '#.(string-rod "&#13;") ystream))
 216         (t
 217           (ystream-write-escapable-rune c ystream))))
 218
 219 (defun unparse-dtd-string (str sink)
 220   (let ((y (sink-ystream sink)))
 221     (loop for rune across str do (unparse-dtd-char rune y))))
 222
 223 (defun unparse-dtd-char (c ystream)
 224   (cond ((rune= c #/%) (ystream-write-rod '#.(string-rod "&#37;") ystream))
 225         ((rune= c #/&) (ystream-write-rod '#.(string-rod "&amp;") ystream))
 226         ((rune= c #/<) (ystream-write-rod '#.(string-rod "&lt;") ystream))
 227         ((rune= c #/>) (ystream-write-rod '#.(string-rod "&gt;") ystream))
 228         ((rune= c #/\") (ystream-write-rod '#.(string-rod "&quot;") ystream))
 229         ((rune= c #/U+0009) (ystream-write-rod '#.(string-rod "&#9;") ystream))
 230         ((rune= c #/U+000A) (ystream-write-rod '#.(string-rod "&#10;") ystream))
 231         ((rune= c #/U+000D) (ystream-write-rod '#.(string-rod "&#13;") ystream))
 232         (t
 233          (ystream-write-escapable-rune c ystream))))
 234
 235 (defun sink-write-rune (c sink)
 236   (ystream-write-rune c (sink-ystream sink)))
 237
 238 (defun sink-write-rod (r sink)
 239   (ystream-write-rod r (sink-ystream sink)))
 240
 241
 242 ;;;; convenience functions for PTless HTML serialization
 243
 244 (defvar *current-element*)
 245 (defvar *sink*)
 246
 247 (defmacro with-html-output
 248     ((sink &key (name "HTML") public-id system-id) &body body)
 249   `(invoke-with-html-output (lambda () ,@body)
 250                             ,sink
 251                             ,name
 252                             ,public-id
 253                             ,system-id))
 254
 255 (defun invoke-with-html-output (fn sink name pubid sysid)
 256   (let ((*sink* sink)
 257         (*current-element* nil))
 258     (hax:start-document *sink* name pubid sysid)
 259     (funcall fn)
 260     (hax:end-document *sink*)))
 261
 262 ;; fuer XML ist hier mehr zu tun, also gehen wir vorsichtshalber fuer HTML
 263 ;; erstmal auch diesen Weg
 264 (defmacro with-output-sink ((var) &body body)
 265   `(invoke-with-output-sink (lambda (,var) ,@body)))
 266 (defun invoke-with-output-sink (fn)
 267   (funcall fn *sink*))
 268
 269 (defmacro with-element (name &body body)
 270   `(invoke-with-element (lambda () ,@body) ,name))
 271
 272 (defun maybe-emit-start-tag ()
 273   (when *current-element*
 274     ;; starting child node, need to emit opening tag of parent first:
 275     (destructuring-bind (name &rest attributes) *current-element*
 276       (hax:start-element *sink* name (reverse attributes)))
 277     (setf *current-element* nil)))
 278
 279 (defun invoke-with-element (fn name)
 280   (setf name (rod name))
 281   (maybe-emit-start-tag)
 282   (let ((*current-element* (list name)))
 283     (multiple-value-prog1
 284         (funcall fn)
 285       (maybe-emit-start-tag)
 286       (hax:end-element *sink* name))))
 287
 288 (defgeneric unparse-attribute (value))
 289 (defmethod unparse-attribute ((value string)) value)
 290 (defmethod unparse-attribute ((value null)) nil)
 291 (defmethod unparse-attribute ((value integer)) (write-to-string value))
 292
 293 (defun attribute (name value)
 294   (setf name (rod name))
 295   (setf value (unparse-attribute value))
 296   (push (hax:make-attribute name value t)
 297         (cdr *current-element*)))
 298
 299 (defun text (data)
 300   (maybe-emit-start-tag)
 301   (hax:characters *sink* (rod data))
 302   data)
 303
 304 (defun comment (data)
 305   (maybe-emit-start-tag)
 306   (hax:comment *sink* (rod data))
 307   data)