2 ;; This version by david@lichteblau.com for headcraft (http://headcraft.de/)
4 ;; Derived from htmlgen.cl:
5 ;; copyright (c) 1986-2000 Franz Inc, Berkeley, CA
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
27 (:export
#:with-html
#:write-doctype
))
29 (in-package :xhtml-generator
)
33 (defstruct (html-process (:type list
) (:constructor
34 make-html-process
(key macro special
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
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
51 (defun write-doctype (sink)
54 "-//W3C//DTD XHTML 1.0 Transitional//EN"
55 "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd")
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
*)))
65 (error "unknown html keyword ~s" form
))
68 (defun process-html-forms (forms env
)
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
79 (let ((special (html-process-special ent
)))
81 (funcall special ent args argsp body
)
82 `(,(html-process-macro ent
)
84 ,(process-html-forms body env
)))
86 (do* ((xforms forms
(cdr xforms
))
87 (form (car xforms
) (car xforms
)))
90 (setq form
(macroexpand form env
))
94 (keyword (do-ent (get-process form
) nil nil nil
))
95 (string (push `(sax:characters
*html-sink
* ,form
) res
))
97 (let ((first (car form
)))
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.
116 for
(name value
) on args by
#'cddr
119 :qname
,(etypecase name
120 (symbol (symbol-name name
))
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
))
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)
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
))
196 (def-special-html :prin1
197 #'(lambda (ent args argsp body
)
198 (declare (ignore ent args argsp
))
199 `(progn ,@(mapcar #'(lambda (bod)
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
))
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
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
)
