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 ;; bisschen unschoen hier SCHON WIEDER die ganze api zu duplizieren, aber die
  21 ;; ystreams sind noch undokumentiert
  22 (macrolet ((define-maker (make-sink make-ystream &rest args)
  23              `(defun ,make-sink (,@args &rest initargs)
  24                 (apply #'make-instance
  25                        'sink
  26                        :ystream (,make-ystream ,@args)
  27                        initargs))))
  28   (define-maker make-octet-vector-sink make-octet-vector-ystream)
  29   (define-maker make-octet-stream-sink make-octet-stream-ystream stream)
  30   (define-maker make-rod-sink make-rod-ystream)
  31
  32   #+rune-is-character
  33   (define-maker make-character-stream-sink make-character-stream-ystream stream)
  34
  35   #-rune-is-character
  36   (define-maker make-string-sink/utf8 make-string-ystream/utf8)
  37
  38   #-rune-is-character
  39   (define-maker make-character-stream-sink/utf8
  40       make-character-stream-ystream/utf8
  41     stream))
  42
  43 #+rune-is-character
  44 (defun make-string-sink (&rest args) (apply #'make-rod-sink args))
  45
  46
  47 ;;;; Events
  48
  49 (defmethod hax:start-document ((sink sink) name public-id system-id)
  50   (%write-rod #"<!DOCTYPE " sink)
  51   (%write-rod name sink)
  52   (cond
  53     ((not (zerop (length public-id)))
  54      (%write-rod #" PUBLIC \"" sink)
  55      (unparse-string public-id sink)
  56      (%write-rod #"\" \"" sink)
  57      (unparse-string system-id sink)
  58      (%write-rod #"\"" sink))
  59     ((not (zerop (length system-id)))
  60      (%write-rod #" SYSTEM \"" sink)
  61      (unparse-string system-id sink)
  62      (%write-rod #"\"" sink))))
  63
  64 (defmethod hax:end-document ((sink sink))
  65   (close-ystream (sink-ystream sink)))
  66
  67 (defmethod hax:start-element ((sink sink) name attributes)
  68   (let* ((key (find-symbol (string-upcase name) :keyword))
  69          (elt (and key (sgml::find-element closure-html::*html-dtd* key)))
  70          (attlist (sgml::element-attlist elt)))
  71     (push (cons name elt) (stack sink))
  72     (%write-rune #/< sink)
  73     (%write-rod name sink)
  74     (dolist (a attributes)
  75       (%write-rune #/space sink)
  76       (%write-rod (hax:attribute-name a) sink)
  77       (let* ((akey (find-symbol (string-upcase name) :keyword))
  78              (att (and akey (assoc akey attlist)))
  79              (values (second att)))
  80         (unless (and att (listp values) (eq (car att) (car values)))
  81           (%write-rune #/= sink)
  82           (%write-rune #/\" sink)
  83           (unparse-string (hax:attribute-value a) sink)
  84           (%write-rune #/\" sink))))
  85     (%write-rune #/> sink)))
  86
  87 (defmethod hax:end-element
  88     ((sink sink) name)
  89   (let* ((prev (pop (stack sink)))
  90          (prev-name (car prev))
  91          (elt (cdr prev)))
  92     (unless (rod= prev-name name)
  93       (error "output does not nest: expected ~A but got ~A"
  94              name prev-name))
  95     (unless (and (sgml::element-include elt)
  96                  (null (sgml::element-include elt)))
  97       (%write-rod '#.(string-rod "</") sink)
  98       (%write-rod name sink)
  99       (%write-rod '#.(string-rod ">") sink))))
 100
 101 (defmethod hax:characters ((sink sink) data)
 102   (let ((y (sink-ystream sink)))
 103     (loop for c across data do (unparse-datachar-readable c y))))
 104
 105 (defmethod hax:comment ((sink sink) data)
 106   ;; XXX signal error if body is unprintable?
 107   (%write-rod #"<!--" sink)
 108   (map nil (lambda (c) (%write-rune c sink)) data)
 109   (%write-rod #"-->" sink))
 110
 111 (defun unparse-string (str sink)
 112   (let ((y (sink-ystream sink)))
 113     (loop for rune across str do (unparse-datachar rune y))))
 114
 115 (defun unparse-datachar (c ystream)
 116   (cond ((rune= c #/&) (write-rod '#.(string-rod "&amp;") ystream))
 117         ((rune= c #/<) (write-rod '#.(string-rod "&lt;") ystream))
 118         ((rune= c #/>) (write-rod '#.(string-rod "&gt;") ystream))
 119         ((rune= c #/\") (write-rod '#.(string-rod "&quot;") ystream))
 120         ((rune= c #/U+0009) (write-rod '#.(string-rod "&#9;") ystream))
 121         ((rune= c #/U+000A) (write-rod '#.(string-rod "&#10;") ystream))
 122         ((rune= c #/U+000D) (write-rod '#.(string-rod "&#13;") ystream))
 123         (t
 124          (write-rune c ystream))))
 125
 126 (defun unparse-datachar-readable (c ystream)
 127   (cond ((rune= c #/&) (write-rod '#.(string-rod "&amp;") ystream))
 128         ((rune= c #/<) (write-rod '#.(string-rod "&lt;") ystream))
 129         ((rune= c #/>) (write-rod '#.(string-rod "&gt;") ystream))
 130         ((rune= c #/\") (write-rod '#.(string-rod "&quot;") ystream))
 131         ((rune= c #/U+000D) (write-rod '#.(string-rod "&#13;") ystream))
 132         (t
 133           (write-rune c ystream))))
 134
 135 (defun unparse-dtd-string (str sink)
 136   (let ((y (sink-ystream sink)))
 137     (loop for rune across str do (unparse-dtd-char rune y))))
 138
 139 (defun unparse-dtd-char (c ystream)
 140   (cond ((rune= c #/%) (write-rod '#.(string-rod "&#37;") ystream))
 141         ((rune= c #/&) (write-rod '#.(string-rod "&amp;") ystream))
 142         ((rune= c #/<) (write-rod '#.(string-rod "&lt;") ystream))
 143         ((rune= c #/>) (write-rod '#.(string-rod "&gt;") ystream))
 144         ((rune= c #/\") (write-rod '#.(string-rod "&quot;") ystream))
 145         ((rune= c #/U+0009) (write-rod '#.(string-rod "&#9;") ystream))
 146         ((rune= c #/U+000A) (write-rod '#.(string-rod "&#10;") ystream))
 147         ((rune= c #/U+000D) (write-rod '#.(string-rod "&#13;") ystream))
 148         (t
 149          (write-rune c ystream))))
 150
 151 (defun %write-rune (c sink)
 152   (write-rune c (sink-ystream sink)))
 153
 154 (defun %write-rod (r sink)
 155   (write-rod r (sink-ystream sink)))
 156
 157
 158 ;;;; convenience functions for PTless HTML serialization
 159
 160 (defvar *current-element*)
 161 (defvar *sink*)
 162
 163 (defmacro with-html-output ((sink &optional pubid sysid) &body body)
 164   `(invoke-with-html-output (lambda () ,@body) ,sink ,pubid ,sysid))
 165
 166 (defun invoke-with-xml-output (fn sink pubid sysid)
 167   (let ((*sink* sink)
 168         (*current-element* nil))
 169     (hax:start-document *sink* "HTML" pubid sysid)
 170     (funcall fn)
 171     (hax:end-document *sink*)))
 172
 173 ;; fuer XML ist hier mehr zu tun, also gehen wir vorsichtshalber fuer HTML
 174 ;; erstmal auch diesen Weg
 175 (defmacro with-output-sink ((var) &body body)
 176   `(invoke-with-output-sink (lambda (,var) ,@body)))
 177 (defun invoke-with-output-sink (fn)
 178   (funcall fn *sink*))
 179
 180 (defmacro with-element (name &body body)
 181   `(invoke-with-element (lambda () ,@body) ,name))
 182
 183 (defun maybe-emit-start-tag ()
 184   (when *current-element*
 185     ;; starting child node, need to emit opening tag of parent first:
 186     (destructuring-bind (name &rest attributes) *current-element*
 187       (hax:start-element *sink* name (reverse attributes)))
 188     (setf *current-element* nil)))
 189
 190 (defun invoke-with-element (fn name)
 191   (setf name (rod name))
 192   (maybe-emit-start-tag)
 193   (let ((*current-element* (list name)))
 194     (multiple-value-prog1
 195         (funcall fn)
 196       (maybe-emit-start-tag)
 197       (hax:end-element *sink* name))))
 198
 199 (defgeneric unparse-attribute (value))
 200 (defmethod unparse-attribute ((value string)) value)
 201 (defmethod unparse-attribute ((value null)) nil)
 202 (defmethod unparse-attribute ((value integer)) (write-to-string value))
 203
 204 (defun attribute (name value)
 205   (setf name (rod name))
 206   (setf value (unparse-attribute value))
 207   (push (hax:make-attribute name value t)
 208         (cdr *current-element*)))
 209
 210 (defun text (data)
 211   (maybe-emit-start-tag)
 212   (hax:characters *sink* (rod data))
 213   data)
 214
 215 (defun comment (data)
 216   (maybe-emit-start-tag)
 217   (hax:comment *sink* (rod data))
 218   data)