215692341bc37aa31d985b0436695b33a7bd044e
[mmondor.git] / mmsoftware / cl / test / html.lisp
1 ;;;; $Id: html.lisp,v 1.8 2011/08/19 02:32:39 mmondor Exp $
2 ;;;;
3 ;;;; Test HTML+code template compiler
4 ;;;; Copyright (c) 2011, Matthew Mondor
5 ;;;; ALL RIGHTS RESERVED.
6
7 ;;;; XXX TODO XXX
8 ;;;; - HTML-safe escaping of general content, including XHTML oddities
9 ;;;; - Possibly also FORMAT directives safe escaping, in case we use
10 ;;;; format internally with ~A general-purpose placeholders for non-HTML
11 ;;;; atoms
12
13
14 (defparameter *html-mode* :xhtml)
15
16
17 ;;; XXX Returns HTML-safe copy of STRING
18 (defun html-escape (string)
19 string)
20
21 ;;; Given keyword SYMBOL, returns two values: the tag name string and
22 ;;; a boolean on if the tag should be matched with a closing tag.
23 (defun symbol-tag (symbol)
24 (let* ((name (string-downcase (symbol-name symbol)))
25 (not-close-p (char= #\/ (schar name 0)))
26 (tag (if not-close-p (subseq name 1) name)))
27 (values tag (not not-close-p))))
28
29 ;;; Parses tag and its attributes if any, starting at LIST.
30 ;;; Returns the tag name, if it must be matched by a closing tag,
31 ;;; its attributes list as well as the tree position at which to resume
32 ;;; parsing.
33 ;;; The returned list is left in reverse-order which is better for our
34 ;;; caller, HTML-PARSE-R.
35 (defun html-tag-parse (list)
36 (macrolet ((add (i)
37 `(push ,i attr)))
38 (let* ((tag nil)
39 (close-p nil)
40 (attr '())
41 (attr-state :symbol)
42 (position
43 (loop
44 for c on list
45 do
46 (block nil
47 (let ((i (car c)))
48
49 ;; Tag itself, init state
50 (when (null tag)
51 (multiple-value-bind (tag-name tag-close-p)
52 (symbol-tag i)
53 (setf tag tag-name
54 close-p tag-close-p)
55 (add (format nil "<~A" tag-name)))
56 (when (and (eq :html i) (eq :xhtml *html-mode*))
57 (add (copy-seq
58 " xmlns=\"http://www.w3.org/1999/xhtml\"")))
59 (return))
60
61 ;; Attributes if any
62 (when (and (eq :symbol attr-state)
63 (keywordp i))
64 (multiple-value-bind (tag-name tag-close-p)
65 (symbol-tag i)
66 (cond ((and (not tag-close-p)
67 (eq :xhtml *html-mode*))
68 (add (format nil " ~A=\"~A\""
69 tag-name tag-name)))
70 (tag-close-p
71 (add (format nil " ~A=" tag-name))
72 (setf attr-state :value))
73 (t
74 (add (format nil " ~A" tag-name)))))
75 (return))
76 (when (and (eq :value attr-state)
77 (or (atom i)
78 (and (listp i)
79 (not (keywordp (first i))))))
80 (cond ((stringp i)
81 (add (format nil "\"~A\"" i)))
82 ((or (atom i)
83 (and (listp i)
84 (not (keywordp (first i)))))
85 (add (copy-seq "\""))
86 (add i)
87 (add (copy-seq "\""))))
88 (setf attr-state :symbol)
89 (return)))
90
91 (loop-finish))
92 finally
93 (progn
94 (add (copy-seq
95 (if (and (eq :xhtml *html-mode*)
96 (not close-p))
97 " />"
98 ">")))
99 (return c)))))
100 (values tag close-p attr position))))
101
102 ;;; Recursive tree parsing function
103 (defun html-parse-r (tree)
104 (macrolet ((add (i)
105 `(push ,i out)))
106 (let ((out '())
107 (tag nil)
108 (close-p t))
109 (loop
110 for c on tree
111 do
112 (block nil
113 (tagbody
114 continue
115 (let ((i (car c))
116 (last-p (null (cdr c))))
117
118 ;; Ready to scan a new tag
119 (when (and (null tag) (keywordp i))
120 (multiple-value-bind (tag-name tag-close-p tag-list pos)
121 (html-tag-parse c)
122 (when (and (eq :html i) (eq :xhtml *html-mode*))
123 (add (copy-seq
124 "<?xml version=\"1.0\" encoding=\"UTF-8\"?>
125 <!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.0 Transitional//EN\"
126 \"http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd\">
127 ")))
128 (setf out (append tag-list out)
129 tag tag-name
130 close-p tag-close-p
131 c pos)
132 (when (and (eq :head i) (eq :xhtml *html-mode*))
133 (add (copy-seq "<meta http-equiv=\"Content-Type\" content=\"text/html; charset=UTF-8\" />")))
134 (if c (go continue) (return))))
135
136 ;; Content
137 (cond ((stringp i)
138 (add (copy-seq i)))
139 ((or (atom i)
140 (and (listp i)
141 (not (keywordp (first i)))))
142 (add i))
143 ((listp i)
144 (setf out (append (reverse (html-parse-r i)) out))))
145
146 ;; Close tag if needed
147 (when (and last-p tag close-p)
148 (add (format nil "</~A>" tag))
149 (setf tag nil
150 close-p t))))))
151 (reverse out))))
152
153 ;;; Optimizes the tree produced by HTML-PARSE-R, concatenating strings.
154 ;;; Also replaces any non-string by ~A for use with FORMAT, and returns
155 ;;; as first value the format string, with as second value the list of
156 ;;; FORMAT arguments.
157 ;;; XXX A potential problem might be the number of arguments, as we have
158 ;;; to basically APPLY FORMAT...
159 (defun html-coalesce (list)
160 (let ((fmt "")
161 (args '())
162 (last nil))
163 (mapc
164 #'(lambda (i)
165 (cond ((stringp i)
166 (setf fmt (concatenate 'string fmt i)))
167 (t
168 (setf fmt (concatenate 'string fmt "~A"))
169 (push i args))))
170 list)
171 (values fmt (reverse args))))
172
173 ;;; Utility macro to generate easily HTML from Common Lisp code.
174 ;;; The HTML is converted to a string at compile-time, and the non-HTML
175 ;;; Lisp code sections are evaluated and substituted at runtime.
176 ;;; Internally, FORMAT is used.
177 ;;; Note that tags and attributes are represented using keyword symbols and
178 ;;; that sublists represent content. Tags are automatically closed unless
179 ;;; the tag symbol begins with a '/'. Likewise, attributes without a value
180 ;;; (such as OPTION's SELECTED attribute) must also be prefixed with '/'.
181 ;;; Literal text should be strings (enclosed in double quotes), and CL
182 ;;; atoms and lists may be used as placeholders for dynamic content,
183 ;;; and may be placed either as attribute values or in general content.
184 (defmacro do-html-format (stream tree)
185 (multiple-value-bind (fmt args)
186 (html-coalesce (html-parse-r tree))
187 (append `(format ,stream ,fmt) args)))
188
189 ;;; Utility macro for sane and easy loops within HTML constructs.
190 (defmacro do-html-loop ((&body loop-clause) &body body)
191 (let ((s-stream (gensym)))
192 `(with-output-to-string (,s-stream)
193 (loop
194 ,@loop-clause
195 do
196 (do-html-format ,s-stream
197 ,@body)))))
198
199
200
201 ;;; Tests
202
203 (defun http-reply (code message &optional description)
204 (let ((title (format nil "~A - ~A" code message)))
205 (do-html-format t
206 (:html (:head (:title title))
207 (:body
208 (:h1 title)
209 (if description
210 (do-html-format nil
211 (:p description))
212 "")
213 (:small (format nil "~A/~A"
214 (lisp-implementation-type)
215 (lisp-implementation-version))))))))
216
217 (defun random-page (&key (trs 10) (tds 10) (rnd 1000))
218 (do-html-format t
219 (:html (:head (:title "Random page"))
220 (:body
221 (:h1 "Random page")
222 (:table
223 (do-html-loop (repeat trs)
224 (:tr
225 (do-html-loop (repeat tds)
226 (:td (random rnd))))))))))
227
228 (defun results-page (list)
229 (do-html-format t
230 (:html (:head (:title "Results"))
231 (:body
232 (:h1 "Results")
233 (:table
234 (do-html-loop (for i in list)
235 (:tr (:td i))))))))