Support for various windows codepages, thanks to Pierre Mai
[cxml/s11.git] / contrib / xhtmlgen.lisp
blob0202ba7fdccd259823914938aae36d7236acb8e5
1 ;; xhtmlgen.lisp
2 ;; This version by david@lichteblau.com for headcraft (http://headcraft.de/)
3 ;;
4 ;; Derived from htmlgen.cl:
5 ;; copyright (c) 1986-2000 Franz Inc, Berkeley, CA
6 ;;
7 ;; This code is free software; you can redistribute it and/or
8 ;; modify it under the terms of the version 2.1 of
9 ;; the GNU Lesser General Public License as published by
10 ;; the Free Software Foundation, as clarified by the AllegroServe
11 ;; prequel found in license-allegroserve.txt.
13 ;; This code is distributed in the hope that it will be useful,
14 ;; but without any warranty; without even the implied warranty of
15 ;; merchantability or fitness for a particular purpose. See the GNU
16 ;; Lesser General Public License for more details.
18 ;; Version 2.1 of the GNU Lesser General Public License is in the file
19 ;; license-lgpl.txt that was distributed with this file.
20 ;; If it is not present, you can access it from
21 ;; http://www.gnu.org/copyleft/lesser.txt (until superseded by a newer
22 ;; version) or write to the Free Software Foundation, Inc., 59 Temple Place,
23 ;; Suite 330, Boston, MA 02111-1307 USA
25 (defpackage :xhtml-generator
26 (:use :common-lisp)
27 (:export #:with-html #:write-doctype))
29 (in-package :xhtml-generator)
31 ;; html generation
33 (defstruct (html-process (:type list) (:constructor
34 make-html-process (key macro special
35 name-attr
36 )))
37 key ; keyword naming this tag
38 macro ; the macro to define this
39 special ; if true then call this to process the keyword and return
40 ; the macroexpansion
41 name-attr ; attribute symbols which can name this object for subst purposes
45 (defparameter *html-process-table*
46 (make-hash-table :test #'equal) ; #'eq is accurate but want to avoid rehashes
49 (defvar *html-sink*)
51 (defun write-doctype (sink)
52 (sax:start-dtd sink
53 "html"
54 "-//W3C//DTD XHTML 1.0 Transitional//EN"
55 "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd")
56 (sax:end-dtd sink))
58 (defmacro with-html (sink &rest forms &environment env)
59 `(let ((*html-sink* ,sink))
60 ,(process-html-forms forms env)))
62 (defun get-process (form)
63 (let ((ent (gethash form *html-process-table*)))
64 (unless ent
65 (error "unknown html keyword ~s" form))
66 ent))
68 (defun process-html-forms (forms env)
69 (let (res)
70 (flet ((do-ent (ent args argsp body)
71 ;; ent is an html-process object associated with the
72 ;; html tag we're processing
73 ;; args is the list of values after the tag in the form
74 ;; ((:tag &rest args) ....)
75 ;; argsp is true if this isn't a singleton tag (i.e. it has
76 ;; a body) .. (:tag ...) or ((:tag ...) ...)
77 ;; body is the body if any of the form
78 ;;
79 (let ((special (html-process-special ent)))
80 (push (if special
81 (funcall special ent args argsp body)
82 `(,(html-process-macro ent)
83 ,args
84 ,(process-html-forms body env)))
85 res))))
86 (do* ((xforms forms (cdr xforms))
87 (form (car xforms) (car xforms)))
88 ((null xforms))
90 (setq form (macroexpand form env))
92 (if (atom form)
93 (typecase form
94 (keyword (do-ent (get-process form) nil nil nil))
95 (string (push `(sax:characters *html-sink* ,form) res))
96 (t (push form res)))
97 (let ((first (car form)))
98 (cond
99 ((keywordp first)
100 ;; (:xxx . body) form
101 (do-ent (get-process (car form)) nil t (cdr form)))
102 ((and (consp first) (keywordp (car first)))
103 ;; ((:xxx args ) . body)
104 (do-ent (get-process (caar form)) (cdr first) t (cdr form)))
106 (push form res)))))))
107 `(progn ,@(nreverse res))))
109 (defun html-body-key-form (string-code args body)
110 (unless (evenp (length args))
111 (error "attribute list ~S isn't even" args))
112 `(let ((.tagname. ,string-code))
113 (sax:start-element *html-sink* nil nil .tagname.
114 (list
115 ,@(loop
116 for (name value) on args by #'cddr
117 collect
118 `(sax:make-attribute
119 :qname ,(etypecase name
120 (symbol (symbol-name name))
121 (string name))
122 :value ,value
123 :specified-p t))))
124 ,@body
125 (sax:end-element *html-sink* nil nil .tagname.)))
127 (defun emit-without-quoting (str)
128 (let ((s (cxml::chained-handler *html-sink*)))
129 (cxml::maybe-close-tag s)
130 (map nil (lambda (c) (cxml::write-rune (char-code c) s)) str)))
132 (defun princ-http (val)
133 (warn "use of deprecated :PRINC (use :PRINC-SAFE instead?)")
134 (emit-without-quoting (princ-to-string val)))
136 (defun prin1-http (val)
137 (warn "use of deprecated :PRIN1 (use :PRIN1-SAFE instead?)")
138 (emit-without-quoting (prin1-to-string val)))
140 (defun princ-safe-http (val)
141 (sax:characters *html-sink* (princ-to-string val)))
143 (defun prin1-safe-http (val)
144 (sax:characters *html-sink* (prin1-to-string val)))
147 ;; -- defining how html tags are handled. --
149 ;; most tags are handled in a standard way and the def-std-html
150 ;; macro is used to define such tags
152 ;; Some tags need special treatment and def-special-html defines
153 ;; how these are handled. The tags requiring special treatment
154 ;; are the pseudo tags we added to control operations
155 ;; in the html generator.
158 ;; tags can be found in three ways:
159 ;; :br - singleton, no attributes, no body
160 ;; (:b "foo") - no attributes but with a body
161 ;; ((:a href="foo") "balh") - attributes and body
164 (defmacro def-special-html (kwd fcn)
165 ;; kwd - the tag we're defining behavior for.
166 ;; fcn - function to compute the macroexpansion of a use of this
167 ;; tag. args to fcn are:
168 ;; ent - html-process object holding info on this tag
169 ;; args - list of attribute-values following tag
170 ;; argsp - true if there is a body in this use of the tag
171 ;; body - list of body forms.
172 `(setf (gethash ,kwd *html-process-table*)
173 (make-html-process ,kwd nil ,fcn nil)))
175 (def-special-html :newline
176 #'(lambda (ent args argsp body)
177 (declare (ignore ent args argsp))
178 (when body
179 (error "can't have a body with :newline -- body is ~s" body))
180 (emit-without-quoting (string #\newline))))
182 (def-special-html :princ
183 #'(lambda (ent args argsp body)
184 (declare (ignore ent args argsp))
185 `(progn ,@(mapcar #'(lambda (bod)
186 `(princ-http ,bod))
187 body))))
189 (def-special-html :princ-safe
190 #'(lambda (ent args argsp body)
191 (declare (ignore ent args argsp))
192 `(progn ,@(mapcar #'(lambda (bod)
193 `(princ-safe-http ,bod))
194 body))))
196 (def-special-html :prin1
197 #'(lambda (ent args argsp body)
198 (declare (ignore ent args argsp))
199 `(progn ,@(mapcar #'(lambda (bod)
200 `(prin1-http ,bod))
201 body))))
203 (def-special-html :prin1-safe
204 #'(lambda (ent args argsp body)
205 (declare (ignore ent args argsp))
206 `(progn ,@(mapcar #'(lambda (bod)
207 `(prin1-safe-http ,bod))
208 body))))
210 (def-special-html :comment
211 #'(lambda (ent args argsp body)
212 (declare (ignore ent args argsp body))
213 `(warn ":COMMENT in html macro not supported yet")))
215 (defmacro def-std-html (kwd name-attrs)
216 (let ((mac-name (intern (format nil "~a-~a" :with-html kwd)))
217 (string-code (string-downcase (string kwd))))
218 `(progn (setf (gethash ,kwd *html-process-table*)
219 (make-html-process ,kwd
220 ',mac-name
222 ',name-attrs))
223 (defmacro ,mac-name (args &rest body)
224 (html-body-key-form ,string-code args body)))))
226 (def-std-html :a nil)
227 (def-std-html :abbr nil)
228 (def-std-html :acronym nil)
229 (def-std-html :address nil)
230 (def-std-html :applet nil)
231 (def-std-html :area nil)
233 (def-std-html :b nil)
234 (def-std-html :base nil)
235 (def-std-html :basefont nil)
236 (def-std-html :bdo nil)
237 (def-std-html :bgsound nil)
238 (def-std-html :big nil)
239 (def-std-html :blink nil)
240 (def-std-html :blockquote nil)
241 (def-std-html :body nil)
242 (def-std-html :br nil)
243 (def-std-html :button nil)
245 (def-std-html :caption nil)
246 (def-std-html :center nil)
247 (def-std-html :cite nil)
248 (def-std-html :code nil)
249 (def-std-html :col nil)
250 (def-std-html :colgroup nil)
252 (def-std-html :dd nil)
253 (def-std-html :del nil)
254 (def-std-html :dfn nil)
255 (def-std-html :dir nil)
256 (def-std-html :div nil)
257 (def-std-html :dl nil)
258 (def-std-html :dt nil)
260 (def-std-html :em nil)
261 (def-std-html :embed nil)
263 (def-std-html :fieldset nil)
264 (def-std-html :font nil)
265 (def-std-html :form :name)
266 (def-std-html :frame nil)
267 (def-std-html :frameset nil)
269 (def-std-html :h1 nil)
270 (def-std-html :h2 nil)
271 (def-std-html :h3 nil)
272 (def-std-html :h4 nil)
273 (def-std-html :h5 nil)
274 (def-std-html :h6 nil)
275 (def-std-html :head nil)
276 (def-std-html :hr nil)
277 (def-std-html :html nil)
279 (def-std-html :i nil)
280 (def-std-html :iframe nil)
281 (def-std-html :ilayer nil)
282 (def-std-html :img :id)
283 (def-std-html :input nil)
284 (def-std-html :ins nil)
285 (def-std-html :isindex nil)
287 (def-std-html :kbd nil)
288 (def-std-html :keygen nil)
290 (def-std-html :label nil)
291 (def-std-html :layer nil)
292 (def-std-html :legend nil)
293 (def-std-html :li nil)
294 (def-std-html :link nil)
295 (def-std-html :listing nil)
297 (def-std-html :map nil)
298 (def-std-html :marquee nil)
299 (def-std-html :menu nil)
300 (def-std-html :meta nil)
301 (def-std-html :multicol nil)
303 (def-std-html :nobr nil)
304 (def-std-html :noembed nil)
305 (def-std-html :noframes nil)
306 (def-std-html :noscript nil)
308 (def-std-html :object nil)
309 (def-std-html :ol nil)
310 (def-std-html :optgroup nil)
311 (def-std-html :option nil)
313 (def-std-html :p nil)
314 (def-std-html :param nil)
315 (def-std-html :plaintext nil)
316 (def-std-html :pre nil)
318 (def-std-html :q nil)
320 (def-std-html :s nil)
321 (def-std-html :samp nil)
322 (def-std-html :script nil)
323 (def-std-html :select nil)
324 (def-std-html :server nil)
325 (def-std-html :small nil)
326 (def-std-html :spacer nil)
327 (def-std-html :span :id)
328 (def-std-html :strike nil)
329 (def-std-html :strong nil)
330 (def-std-html :style nil)
331 (def-std-html :sub nil)
332 (def-std-html :sup nil)
334 (def-std-html :table :name)
335 (def-std-html :tbody nil)
336 (def-std-html :td nil)
337 (def-std-html :textarea nil)
338 (def-std-html :tfoot nil)
339 (def-std-html :th nil)
340 (def-std-html :thead nil)
341 (def-std-html :title nil)
342 (def-std-html :tr nil)
343 (def-std-html :tt nil)
345 (def-std-html :u nil)
346 (def-std-html :ul nil)
348 (def-std-html :var nil)
350 (def-std-html :wbr nil)
352 (def-std-html :xmp nil)