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>
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
)
19 (encoding :initarg
:encoding
:reader sink-encoding
)))
22 (defmethod hax:%want-strings-p
((handler sink
))
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 (runes:find-output-encoding encoding
))
34 (apply #'make-instance
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
)
44 (define-maker make-character-stream-sink make-character-stream-ystream stream
)
47 (define-maker make-string-sink
/utf8 make-string-ystream
/utf8
)
50 (define-maker make-character-stream-sink
/utf8
51 make-character-stream-ystream
/utf8
55 (defun make-string-sink (&rest args
) (apply #'make-rod-sink args
))
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))
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
)
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
))
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
)))
86 (defmethod hax:end-document
((sink sink
))
87 (close-ystream (sink-ystream sink
)))
89 (defmethod hax:start-element
((sink sink
) name attributes
)
90 (let* ((key (find-symbol (string-upcase (rod-string name
)) :keyword
))
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
)))
114 ;;; everything written as %URI in the DTD:
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")
124 (#"img" #"src" #"longdesc" #"usemap")
125 (#"object" #"classid" #"codebase" #"data" #"usemap")
127 (#"blockquote" #"cite")
131 (#"input" #"src" #"usemap")
134 (#"script" #"src" ;; #"for"
140 (defun escape-uri-attribute (x)
142 (with-output-to-string (s)
144 for c across
(rod-to-utf8-string x
)
145 for code
= (char-code c
)
149 (format s
"%~2,'0X" code
))))))
151 (defmethod hax:end-element
153 (let* ((prev (pop (stack sink
)))
154 (prev-name (car prev
))
156 (unless (rod= prev-name name
)
157 (error "output does not nest: expected ~A but got ~A"
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
))))
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
)))))
170 (defmethod hax:unescaped
((sink sink
) data
)
171 (sink-write-rod data sink
))
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
))
179 (defun unparse-string (str sink
)
180 (let ((y (sink-ystream sink
)))
181 (loop for rune across str do
(unparse-datachar rune y
))))
183 (defun unparse-attribute-string (str sink
)
184 (let ((y (sink-ystream sink
)))
190 (if (and (< i
(length str
)) (rune= (rune str i
) #/{))
191 (ystream-write-rune c y
)
192 (ystream-write-rod '#.
(string-rod "&") y
)))
193 ((rune= c
#/\") (ystream-write-rod '#.
(string-rod """) y
))
194 ((rune= c
#/U
+000A
) (ystream-write-rod '#.
(string-rod " ") y
))
195 ((rune= c
#/U
+000D
) (ystream-write-rod '#.
(string-rod " ") y
))
197 (ystream-write-escapable-rune c y
))))))
199 (defun unparse-datachar (c ystream
)
200 (cond ((rune= c
#/&) (ystream-write-rod '#.
(string-rod "&") ystream
))
201 ((rune= c
#/<) (ystream-write-rod '#.
(string-rod "<") ystream
))
202 ((rune= c
#/>) (ystream-write-rod '#.
(string-rod ">") ystream
))
203 ((rune= c
#/\") (ystream-write-rod '#.
(string-rod """) ystream
))
204 ((rune= c
#/U
+0009) (ystream-write-rod '#.
(string-rod "	") ystream
))
205 ((rune= c
#/U
+000A
) (ystream-write-rod '#.
(string-rod " ") ystream
))
206 ((rune= c
#/U
+000D
) (ystream-write-rod '#.
(string-rod " ") ystream
))
208 (ystream-write-escapable-rune c ystream
))))
210 (defun unparse-datachar-readable (c ystream
)
211 (cond ((rune= c
#/&) (ystream-write-rod '#.
(string-rod "&") ystream
))
212 ((rune= c
#/<) (ystream-write-rod '#.
(string-rod "<") ystream
))
213 ((rune= c
#/>) (ystream-write-rod '#.
(string-rod ">") ystream
))
214 ((rune= c
#/\") (ystream-write-rod '#.
(string-rod """) ystream
))
215 ((rune= c
#/U
+000D
) (ystream-write-rod '#.
(string-rod " ") ystream
))
217 (ystream-write-escapable-rune c ystream
))))
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
))))
223 (defun unparse-dtd-char (c ystream
)
224 (cond ((rune= c
#/%
) (ystream-write-rod '#.
(string-rod "%") ystream
))
225 ((rune= c
#/&) (ystream-write-rod '#.
(string-rod "&") ystream
))
226 ((rune= c
#/<) (ystream-write-rod '#.
(string-rod "<") ystream
))
227 ((rune= c
#/>) (ystream-write-rod '#.
(string-rod ">") ystream
))
228 ((rune= c
#/\") (ystream-write-rod '#.
(string-rod """) ystream
))
229 ((rune= c
#/U
+0009) (ystream-write-rod '#.
(string-rod "	") ystream
))
230 ((rune= c
#/U
+000A
) (ystream-write-rod '#.
(string-rod " ") ystream
))
231 ((rune= c
#/U
+000D
) (ystream-write-rod '#.
(string-rod " ") ystream
))
233 (ystream-write-escapable-rune c ystream
))))
235 (defun sink-write-rune (c sink
)
236 (ystream-write-rune c
(sink-ystream sink
)))
238 (defun sink-write-rod (r sink
)
239 (ystream-write-rod r
(sink-ystream sink
)))
242 ;;;; convenience functions for PTless HTML serialization
244 (defvar *current-element
*)
247 (defmacro with-html-output
248 ((sink &key
(name "HTML") public-id system-id
) &body body
)
249 `(invoke-with-html-output (lambda () ,@body
)
255 (defun invoke-with-html-output (fn sink name pubid sysid
)
257 (*current-element
* nil
))
258 (hax:start-document
*sink
* name pubid sysid
)
260 (hax:end-document
*sink
*)))
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)
269 (defmacro with-element
(name &body body
)
270 `(invoke-with-element (lambda () ,@body
) ,name
))
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
)))
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
285 (maybe-emit-start-tag)
286 (hax:end-element
*sink
* name
))))
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
))
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
*)))
300 (maybe-emit-start-tag)
301 (hax:characters
*sink
* (rod data
))
304 (defun comment (data)
305 (maybe-emit-start-tag)
306 (hax:comment
*sink
* (rod data
))