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