who.lisp 1 ;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package:CL-WHO; Base: 10 -*-
2 ;;; $Header: /usr/local/cvsrep/cl-who/who.lisp,v 1.42 2009/01/26 11:10:49 edi Exp $
3
4 ;;; Copyright (c) 2003-2009, Dr. Edmund Weitz. All rights reserved.
5
6 ;;; Redistribution and use in source and binary forms, with or without
7 ;;; modification, are permitted provided that the following conditions
8 ;;; are met:
9
10 ;;; * Redistributions of source code must retain the above copyright
11 ;;; notice, this list of conditions and the following disclaimer.
12
13 ;;; * Redistributions in binary form must reproduce the above
14 ;;; copyright notice, this list of conditions and the following
15 ;;; disclaimer in the documentation and/or other materials
16 ;;; provided with the distribution.
17
18 ;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED
19 ;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
20 ;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
21 ;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY
22 ;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
23 ;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
24 ;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
25 ;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
26 ;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
27 ;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
28 ;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
29
30 (in-package :cl-who)
31
32 (defun html-mode ()
33 "Returns the current HTML mode. :SGML for \(SGML-)HTML, :XML for
34 XHTML and :HTML5 for HTML5 (HTML syntax)."
35 *html-mode*)
36
37 (defun (setf html-mode) (mode)
38 "Sets the output mode to XHTML or \(SGML-)HTML. MODE can be
39 :SGML for HTML, :XML for XHTML or :HTML5 for HTML5 (HTML syntax)."
40 (ecase mode
41 ((:sgml)
42 (setf *html-mode* :sgml
43 *empty-tag-end* ">"
44 *prologue* "<!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 4.01 Transitional//EN\" \"http://www.w3.org/TR/html4/loose.dtd\">"))
45 ((:xml)
46 (setf *html-mode* :xml
47 *empty-tag-end* " />"
48 *prologue* "<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.0 Strict//EN\" \"http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd\">"))
49 ((:html5)
50 (setf *html-mode* :html5
51 *empty-tag-end* ">"
52 *prologue* "<!DOCTYPE html>"))))
53
54 (defun process-tag (sexp body-fn)
55 (declare (optimize speed space))
56 "Returns a string list corresponding to the `HTML' \(in CL-WHO
57 syntax) in SEXP. Uses the generic function CONVERT-TO-STRING-LIST
58 internally. Utility function used by TREE-TO-TEMPLATE."
59 (let (tag attr-list body)
60 (cond
61 ((keywordp sexp)
62 (setq tag sexp))
63 ((atom (first sexp))
64 (setq tag (first sexp))
65 ;; collect attribute/value pairs into ATTR-LIST and tag body (if
66 ;; any) into BODY
67 (loop for rest on (cdr sexp) by #'cddr
68 if (keywordp (first rest))
69 collect (cons (first rest) (second rest)) into attr
70 else
71 do (progn (setq attr-list attr)
72 (setq body rest)
73 (return))
74 finally (setq attr-list attr)))
75 ((listp (first sexp))
76 (setq tag (first (first sexp)))
77 (loop for rest on (cdr (first sexp)) by #'cddr
78 if (keywordp (first rest))
79 collect (cons (first rest) (second rest)) into attr
80 finally (setq attr-list attr))
81 (setq body (cdr sexp))))
82 (convert-tag-to-string-list tag attr-list body body-fn)))
83
84 (defun convert-attributes (attr-list)
85 "Helper function for CONVERT-TAG-TO-STRING-LIST which converts the
86 alist ATTR-LIST of attributes into a list of strings and/or Lisp
87 forms."
88 (declare (optimize speed space))
89 (loop with =var= = (gensym)
90 for (orig-attr . val) in attr-list
91 for attr = (if *downcase-tokens-p*
92 (string-downcase orig-attr)
93 (string orig-attr))
94 unless (null val) ;; no attribute at all if VAL is NIL
95 if (constantp val)
96 if (and (eq *html-mode* :sgml) (eq val t)) ; special case for SGML
97 nconc (list " " attr)
98 else
99 nconc (list " "
100 ;; name of attribute
101 attr
102 (format nil "=~C" *attribute-quote-char*)
103 ;; value of attribute
104 (cond ((eq val t)
105 ;; VAL is T, use attribute's name
106 attr)
107 (t
108 ;; constant form, PRINC it -
109 ;; EVAL is OK here because of CONSTANTP
110 (format nil "~A" (eval val))))
111 (string *attribute-quote-char*))
112 end
113 else
114 ;; do the same things as above but at runtime
115 nconc (list `(let ((,=var= ,val))
116 (cond ((null ,=var=))
117 ((eq ,=var= t)
118 ,(case *html-mode*
119 (:sgml
120 `(fmt " ~A" ,attr))
121 ;; otherwise default to :xml mode
122 (t
123 `(fmt " ~A=~C~A~C"
124 ,attr
125 *attribute-quote-char*
126 ,attr
127 *attribute-quote-char*))))
128 (t
129 (fmt " ~A=~C~A~C"
130 ,attr
131 *attribute-quote-char*
132 ,=var=
133 *attribute-quote-char*)))))))
134
135 (defgeneric convert-tag-to-string-list (tag attr-list body body-fn)
136 (:documentation "Used by PROCESS-TAG to convert `HTML' into a list
137 of strings. TAG is a keyword symbol naming the outer tag, ATTR-LIST
138 is an alist of its attributes \(the car is the attribute's name as a
139 keyword, the cdr is its value), BODY is the tag's body, and BODY-FN is
140 a function which should be applied to BODY. The function must return
141 a list of strings or Lisp forms."))
142
143 (defmethod convert-tag-to-string-list (tag attr-list body body-fn)
144 "The standard method which is not specialized. The idea is that you
145 can use EQL specializers on the first argument."
146 (declare (optimize speed space))
147 (let ((tag (if *downcase-tokens-p* (string-downcase tag) (string tag)))
148 (body-indent
149 ;; increase *INDENT* by 2 for body -- or disable it
150 (when (and *indent* (not (member tag *html-no-indent-tags*
151 :test #'string-equal)))
152 (+ 2 *indent*))))
153 (nconc
154 (if *indent*
155 ;; indent by *INDENT* spaces
156 (list +newline+ (n-spaces *indent*)))
157 ;; tag name
158 (list "<" tag)
159 ;; attributes
160 (convert-attributes attr-list)
161 ;; body
162 (if body
163 (append
164 (list ">")
165 ;; now hand over the tag's body to TREE-TO-TEMPLATE
166 (let ((*indent* body-indent))
167 (funcall body-fn body))
168 (when body-indent
169 ;; indentation
170 (list +newline+ (n-spaces *indent*)))
171 ;; closing tag
172 (list "</" tag ">"))
173 ;; no body, so no closing tag unless defined in *HTML-EMPTY-TAGS*
174 (if (or (not *html-empty-tag-aware-p*)
175 (member tag *html-empty-tags* :test #'string-equal))
176 (list *empty-tag-end*)
177 (list ">" "</" tag ">"))))))
178
179 (defun tree-to-template (tree)
180 "Transforms an HTML tree into an intermediate format - mainly a
181 flattened list of strings. Utility function used by TREE-TO-COMMANDS."
182 (loop for element in tree
183 if (or (keywordp element)
184 (and (listp element)
185 (keywordp (first element)))
186 (and (listp element)
187 (listp (first element))
188 (keywordp (first (first element)))))
189 ;; the syntax for a tag - process it
190 nconc (process-tag element #'tree-to-template)
191 ;; list - insert as sexp
192 else if (consp element)
193 collect `(let ((*indent* ,*indent*))
194 nil ;; If the element is (declare ...) it
195 ;; won't be interpreted as a declaration and an
196 ;; appropriate error could be signaled
197 ,element)
198 ;; something else - insert verbatim
199 else
200 collect element))
201
202 (defun string-list-to-string (string-list)
203 (declare (optimize speed space))
204 "Concatenates a list of strings to one string."
205 ;; note that we can't use APPLY with CONCATENATE here because of
206 ;; CALL-ARGUMENTS-LIMIT
207 (let ((total-size 0))
208 (dolist (string string-list)
209 (incf total-size (length string)))
210 (let ((result-string (make-string total-size
211 #+:lispworks #+:lispworks
212 :element-type 'lw:simple-char))
213 (curr-pos 0))
214 (dolist (string string-list)
215 (replace result-string string :start1 curr-pos)
216 (incf curr-pos (length string)))
217 result-string)))
218
219 (defun conc (&rest string-list)
220 "Concatenates all arguments which should be string into one string."
221 (funcall #'string-list-to-string string-list))
222
223 (defun tree-to-commands (tree stream
224 &key prologue ((:indent *indent*) *indent*))
225 (declare (optimize speed space))
226 (when (and *indent*
227 (not (integerp *indent*)))
228 (setq *indent* 0))
229 (let ((in-string-p t)
230 collector
231 string-collector
232 (template (tree-to-template tree)))
233 (when prologue
234 (push +newline+ template)
235 (when (eq prologue t)
236 (setq prologue *prologue*))
237 (push prologue template))
238 (flet ((emit-string-collector ()
239 "Generate a WRITE-STRING statement for what is currently
240 in STRING-COLLECTOR."
241 (list 'write-string
242 (string-list-to-string (nreverse string-collector))
243 stream)))
244 (dolist (element template)
245 (cond ((and in-string-p (stringp element))
246 ;; this element is a string and the last one
247 ;; also was (or this is the first element) -
248 ;; collect into STRING-COLLECTOR
249 (push element string-collector))
250 ((stringp element)
251 ;; the last one wasn't a string so we start
252 ;; with an empty STRING-COLLECTOR
253 (setq string-collector (list element)
254 in-string-p t))
255 (string-collector
256 ;; not a string but STRING-COLLECTOR isn't
257 ;; empty so we have to emit the collected
258 ;; strings first
259 (push (emit-string-collector) collector)
260 (setq in-string-p nil
261 string-collector '())
262 (push element collector))
263 (t
264 ;; not a string and empty STRING-COLLECTOR
265 (push element collector))))
266 (if string-collector
267 ;; finally empty STRING-COLLECTOR if
268 ;; there's something in it
269 (nreverse (cons (emit-string-collector)
270 collector))
271 (nreverse collector)))))
272
273 (defmacro with-html-output ((var &optional stream
274 &rest rest
275 &key prologue indent)
276 &body body)
277 "Transform the enclosed BODY consisting of HTML as s-expressions
278 into Lisp code to write the corresponding HTML as strings to VAR -
279 which should either hold a stream or which'll be bound to STREAM if
280 supplied."
281 (declare (ignore prologue))
282 (multiple-value-bind (declarations forms) (extract-declarations body)
283 `(let ((,var ,(or stream var)))
284 ,@declarations
285 (check-type ,var stream)
286 (macrolet ((htm (&body body)
287 `(with-html-output (,',var nil
288 :prologue nil
289 :indent ,,indent)
290 ,@body))
291 (fmt (&rest args)
292 `(format ,',var ,@args))
293 (esc (thing)
294 (with-unique-names (result)
295 `(let ((,result ,thing))
296 (when ,result
297 (write-string (escape-string ,result) ,',var)))))
298 (str (thing)
299 (with-unique-names (result)
300 `(let ((,result ,thing))
301 (when ,result (princ ,result ,',var))))))
302 ,@(apply 'tree-to-commands forms var rest)))))
303
304 (defmacro with-html-output-to-string ((var &optional string-form
305 &key #-(or :ecl :cmu :sbcl)
306 (element-type
307 #-:lispworks ''character
308 #+:lispworks ''lw:simple-char)
309 prologue
310 indent)
311 &body body)
312 "Transform the enclosed BODY consisting of HTML as s-expressions
313 into Lisp code which creates the corresponding HTML as a string."
314 (multiple-value-bind (declarations forms) (extract-declarations body)
315 `(with-output-to-string (,var ,string-form
316 #-(or :ecl :cmu :sbcl) :element-type
317 #-(or :ecl :cmu :sbcl) ,element-type)
318 ,@declarations
319 (with-html-output (,var nil :prologue ,prologue :indent ,indent)
320 ,@forms))))
321
322 ;; stuff for Nikodemus Siivola's HYPERDOC
323 ;; see <http://common-lisp.net/project/hyperdoc/>
324 ;; and <http://www.cliki.net/hyperdoc>
325 ;; also used by LW-ADD-ONS
326
327 (defvar *hyperdoc-base-uri* "http://weitz.de/cl-who/")
328
329 (let ((exported-symbols-alist
330 (loop for symbol being the external-symbols of :cl-who
331 collect (cons symbol
332 (concatenate 'string
333 "#"
334 (string-downcase symbol))))))
335 (defun hyperdoc-lookup (symbol type)
336 (declare (ignore type))
337 (cdr (assoc symbol
338 exported-symbols-alist
339 :test #'eq))))