Pretend a/@name is a URI
[closure-html.git] / src / parse / unparse.lisp
blob33abfb6e8f477e0c86f28db4297d9d447eed5f0e
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
11 (in-package :closure-html)
14 ;;; SINK: an HTML output sink
16 (defclass sink (hax:abstract-handler)
17 ((ystream :initarg :ystream :accessor sink-ystream)
18 (stack :initform nil :accessor stack)))
20 #-rune-is-character
21 (defmethod hax:%want-strings-p ((handler sink))
22 nil)
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)
36 #+rune-is-character
37 (define-maker make-character-stream-sink make-character-stream-ystream stream)
39 #-rune-is-character
40 (define-maker make-string-sink/utf8 make-string-ystream/utf8)
42 #-rune-is-character
43 (define-maker make-character-stream-sink/utf8
44 make-character-stream-ystream/utf8
45 stream))
47 #+rune-is-character
48 (defun make-string-sink (&rest args) (apply #'make-rod-sink args))
51 ;;;; Events
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))
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)))
71 (defmethod hax:end-document ((sink sink))
72 (close-ystream (sink-ystream sink)))
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)))
99 ;;; everything written as %URI in the DTD:
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"
121 :key #'car
122 :test #'rod=))
123 :test #'rod=))
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)
132 (if (< code 128)
133 (write-char c s)
134 (format s "%~2,'0X" code))))))
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))))
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)))))
155 (defmethod hax:unescaped ((sink sink) data)
156 (%write-rod data sink))
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))
164 (defun unparse-string (str sink)
165 (let ((y (sink-ystream sink)))
166 (loop for rune across str do (unparse-datachar rune y))))
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
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))
182 (ystream-write-escapable-rune c y))))))
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))
193 (ystream-write-escapable-rune c ystream))))
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))
202 (ystream-write-escapable-rune c ystream))))
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))))
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))
218 (ystream-write-escapable-rune c ystream))))
220 (defun %write-rune (c sink)
221 (ystream-write-rune c (sink-ystream sink)))
223 (defun %write-rod (r sink)
224 (ystream-write-rod r (sink-ystream sink)))
227 ;;;; convenience functions for PTless HTML serialization
229 (defvar *current-element*)
230 (defvar *sink*)
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))
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*)))
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*))
254 (defmacro with-element (name &body body)
255 `(invoke-with-element (lambda () ,@body) ,name))
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)))
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))))
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))
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*)))
284 (defun text (data)
285 (maybe-emit-start-tag)
286 (hax:characters *sink* (rod data))
287 data)
289 (defun comment (data)
290 (maybe-emit-start-tag)
291 (hax:comment *sink* (rod data))
292 data)