Skip to content
Newer
Older
100644 361 lines (334 sloc) 15.1 KB
8f57024 @davazp Rename system and packages from html-template to x-html-template
authored
1 ;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: X-HTML-TEMPLATE; Base: 10 -*-
3cb70dd @davazp Initial commit. Fork HTML-Template
authored
2 ;;; $Header: /usr/local/cvsrep/html-template/util.lisp,v 1.20 2007/11/16 21:09:24 edi Exp $
3
4 ;;; Copyright (c) 2003-2007, 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
8f57024 @davazp Rename system and packages from html-template to x-html-template
authored
30 (in-package #:x-html-template)
3cb70dd @davazp Initial commit. Fork HTML-Template
authored
31
32 (defun no-values (&rest rest)
33 "A function which does not return any values. This is always the
34 last function in a chain of template printer closures."
35 (declare (ignore rest))
36 (values))
37
38 (defun list-to-string (string-list)
39 "Concatenates a list of strings to one string in reverse order. The
40 list is destructively modified."
41 ;; note that we can't use APPLY with CONCATENATE here because of
42 ;; CALL-ARGUMENTS-LIMIT
43 (let ((total-size 0))
44 (dolist (string string-list)
45 (incf total-size (length string)))
46 (let ((result-string (make-string total-size
47 #+:lispworks #+:lispworks
48 :element-type 'lw:simple-char))
49 (curr-pos 0))
50 (dolist (string (nreverse string-list))
51 (replace result-string string :start1 curr-pos)
52 (incf curr-pos (length string)))
53 result-string)))
54
55 (defun %read-char ()
56 "Like READ-CHAR but updates the line and column counters."
57 (let ((char (read-char)))
58 (cond ((char= char #\Newline)
59 (setf *current-column* 0)
60 (incf *current-line*))
61 (t (incf *current-column*)))
62 char))
63
7549a81 @davazp Add expressions support to TMPL_CALL, TMPL_LOOP and TMPL_REPEAT.
authored
64 (defvar *whitespace-characters*
65 '(#\Space #\Tab #\Newline #\Linefeed #\Return #\Page))
66
3cb70dd @davazp Initial commit. Fork HTML-Template
authored
67 (defmacro whitespacep (char)
68 "Checks whether CHAR is whitespace."
7549a81 @davazp Add expressions support to TMPL_CALL, TMPL_LOOP and TMPL_REPEAT.
authored
69 `(find ,char *whitespace-characters*))
3cb70dd @davazp Initial commit. Fork HTML-Template
authored
70
71 (defun read-while (predicate &key (skip t) (eof-action t))
72 "Reads characters from *STANDARD-INPUT* while PREDICATE returns a
73 true value for each character. Returns the string which was read
74 unless SKIP is true. On reading EOF an error is signaled if
75 EOF-ACTION is T, NIL is silently returned if EOF-ACTION is NIL, or the
76 function EOF-ACTION is called with one argument - the string read so
77 far."
78 (let ((collector (or skip
79 (make-array 0
80 :element-type 'character
81 :fill-pointer t
82 :adjustable t))))
83 (handler-case
84 (loop for c = (peek-char)
85 while (funcall predicate c)
86 do (cond (skip (%read-char))
87 (t (vector-push-extend (%read-char) collector)))
88 finally (return collector))
89 (end-of-file ()
90 (cond ((eq eof-action t)
91 (signal-template-syntax-error "Unexpected EOF"))
92 ((null eof-action)
93 nil)
94 (t (funcall eof-action collector)))))))
95
96 (defun read-delimited-string (&key (eof-action t))
97 "Reads and returns a string from *STANDARD-INPUT*. The string is
98 either delimited by ' or \" in which case the delimiters aren't
99 returned or it is assumed to extend to the next whitespace
100 character. See READ-WHILE's docstring for EOF-ACTION."
101 (handler-case
102 (let* ((peek-char (peek-char))
103 (delimiter (find peek-char '(#\' #\"))))
104 (when delimiter
105 (%read-char))
106 (prog1
107 (read-while (if delimiter
108 (lambda (c) (char/= c delimiter))
109 (lambda (c) (not (whitespacep c))))
110 :skip nil
111 :eof-action eof-action)
112 (when delimiter
113 (%read-char))))
114 (end-of-file ()
115 (cond ((eq eof-action t)
116 (signal-template-syntax-error
117 "Unexpected EOF while reading (delimited) string"))
118 ((null eof-action)
119 nil)
120 (t (funcall eof-action ""))))))
121
122 (defun skip-whitespace (&key assert (skip t) (eof-action t))
123 "Read characters from *STANDARD-INPUT* as long as they are
124 whitespace. Signals an error if the first character read isn't
125 whitespace and ASSERT is true. Return the string which was read unless
126 SKIP is true. See READ-WHILE's docstring for EOF-ACTION."
127 (handler-case
128 (progn
129 (when assert
130 (with-syntax-error-location ()
131 (unless (whitespacep (peek-char))
132 (signal-template-syntax-error "Whitespace expected but read ~S" (peek-char)))))
133 (read-while (lambda (c)
134 (whitespacep c))
135 :skip skip
136 :eof-action eof-action))
137 (end-of-file ()
138 (cond ((eq eof-action t)
139 (signal-template-syntax-error "EOF while skipping whitespace"))
140 ((null eof-action)
141 nil)
142 (t (funcall eof-action ""))))))
143
144 (defun skip-trailing-whitespace ()
145 "Reads and skips whitespace from *STANDARD-INPUT* until a #\Newline
146 characters is seen if *IGNORE-EMPTY-LINES* is true. If there is no
147 #\Newline before the first non-whitespace character the string read so
148 far is returned \(wrapped in a list)."
149 (cond (*ignore-empty-lines*
150 (let ((string (read-while (lambda (c)
151 (and (whitespacep c)
152 (char/= #\Newline c)))
153 :skip nil
154 :eof-action nil)))
155 (case (peek-char nil nil nil nil)
156 ((#\Newline)
157 nil)
158 (otherwise
159 (list string)))))
160 (t nil)))
7549a81 @davazp Add expressions support to TMPL_CALL, TMPL_LOOP and TMPL_REPEAT.
authored
161
3cb70dd @davazp Initial commit. Fork HTML-Template
authored
162 (defun read-until (string &key (skip t) (eof-action t))
163 "Reads characters from *STANDARD-INPUT* up to and including
164 STRING. Return the string which was read \(excluding STRING) unless
165 SKIP is true. See READ-WHILE's docstring for EOF-ACTION."
166 (let* ((length (length string))
167 (offsets
168 ;; we first check whether some substring which starts
169 ;; STRING can be found again later in STRING - this is
170 ;; necessary because we only peek one character ahead
171 (cond ((gethash string *find-string-hash*))
172 (t (setf (gethash string *find-string-hash*)
173 ;; the resulting array of offsets is
174 ;; cached in *FIND-STRING-HASH* so we can
175 ;; use it again in case READ-UNTIL is
176 ;; called with the same STRING argument
177 (loop with offsets = (make-array length
178 :initial-element nil)
179 for i from 1 below length
180 ;; check if STRING starting from 0
181 ;; has something in common with
182 ;; STRING starting from I
183 for mismatch = (mismatch string string
184 :start1 i :test #'char=)
185 when (> mismatch i)
186 ;; if this is the case remember the
187 ;; length of the match plus the
188 ;; character which must follow in
189 ;; OFFSETS
190 do (push (cons (char string (- mismatch i))
191 (1+ (- mismatch i)))
192 (svref offsets i))
193 finally (return offsets))))))
194 (collector (or skip
195 (make-array 0
196 :element-type 'character
197 :fill-pointer t
198 :adjustable t))))
199 (handler-case
200 (loop for i = 0 then (cond (match (1+ i))
201 ;; if there is an offset (see above)
202 ;; we don't have to start from the
203 ;; beginning of STRING
204 ((cdr (assoc c (svref offsets i))))
205 (t 0))
206 for c = (peek-char)
207 for match = (char= c (char string i))
208 while (or (not match)
209 (< (1+ i) length))
210 do (cond (skip (%read-char))
211 (t (vector-push-extend (%read-char) collector)))
212 finally (%read-char)
213 (unless skip
214 ;; decrement the fill pointer because collector now also
215 ;; contains STRING itself
216 (decf (fill-pointer collector) (1- length)))
217 (return collector))
218 (end-of-file ()
219 (cond ((eq eof-action t)
220 (signal-template-syntax-error "Unexpected EOF"))
221 ((null eof-action)
222 nil)
223 (t (funcall eof-action collector)))))))
224
225 (defun skip-leading-whitespace (string)
226 "Removes whitespace from the end of STRING up to and including a
227 #\Newline. If there is no #\Newline before the first non-whitespace
228 character is seen nothing is removed. STRING must have a fill
229 pointer."
230 (when *ignore-empty-lines*
231 (let ((old-fill-pointer (fill-pointer string)))
232 (loop for fill-pointer = (fill-pointer string)
233 for char = (and (plusp fill-pointer)
234 (char string (1- fill-pointer)))
235 while (and char
236 (whitespacep char)
237 (char/= #\Newline char))
238 do (decf (fill-pointer string)))
239 (cond ((let ((fill-pointer (fill-pointer string)))
240 (and (plusp fill-pointer)
241 (char= #\Newline (char string (1- fill-pointer)))))
242 (decf (fill-pointer string)))
243 (t
244 (setf (fill-pointer string)
245 old-fill-pointer)))))
246 string)
247
7549a81 @davazp Add expressions support to TMPL_CALL, TMPL_LOOP and TMPL_REPEAT.
authored
248 (defun read-tag-rest (&key read-attribute (eof-action t))
3cb70dd @davazp Initial commit. Fork HTML-Template
authored
249 "Reads the rest of a template tag from *STANDARD-INPUT* after the
250 name of the tag has been read. Reads and returns the tag's attribute
7549a81 @davazp Add expressions support to TMPL_CALL, TMPL_LOOP and TMPL_REPEAT.
authored
251 if READ-ATTRIBUTE is true. See READ-WHILE's docstring for EOF-ACTION."
3cb70dd @davazp Initial commit. Fork HTML-Template
authored
252 (with-syntax-error-location ()
7549a81 @davazp Add expressions support to TMPL_CALL, TMPL_LOOP and TMPL_REPEAT.
authored
253 (let (attribute)
254 (cond
255 ;; If we have to read the attribute, read until the
256 ;; *template-end-marker* and use the string as attribute,
257 ;; trimming whitespaces on the right.
258 (read-attribute
259 (skip-whitespace :assert t)
260 (with-syntax-error-location ()
261 (let* ((attribute-raw
262 (read-until *template-end-marker*
263 :skip nil
264 :eof-action (lambda (collector)
265 (declare (ignore collector))
266 (signal-template-syntax-error
267 "EOF while reading tag attribute")))))
268 (setq attribute (string-right-trim *whitespace-characters* attribute-raw)))))
269 ;; The tag has not attributes, so just read the
270 ;; *template-end-marker*, signal an error if EOF is found
271 ;; before the tag is closed.
272 (t
273 (let (rest)
274 (handler-case
275 (progn
276 (skip-whitespace)
277 (setq rest (read-until *template-end-marker*
278 :skip nil
279 :eof-action eof-action))
280 (when (plusp (length rest))
281 (signal-template-syntax-error "Expected ~S but read ~S"
282 *template-end-marker*
283 rest)))
284 (end-of-file ()
285 (cond ((eq eof-action t)
286 (signal-template-syntax-error "Unexpected EOF"))
287 ((null eof-action)
288 nil)
289 (t (funcall eof-action rest))))))))
290 attribute)))
291
292
293 (defun unquote-string (string)
294 "Remove initial and the final character from STRING, if they both
295 are a single quote, or they are double quotes."
296 (if (and (<= 2 (length string))
297 (let ((first (char string 0))
298 (last (char string (1- (length string)))))
299 (or (char= first last #\')
300 (char= first last #\"))))
301 (subseq string 1 (1- (length string)))
302 string))
303
3cb70dd @davazp Initial commit. Fork HTML-Template
authored
304
305 (defun escape-string (string &key (test *escape-char-p*))
306 (declare (optimize speed))
307 "Escape all characters in STRING which pass TEST. This function is
308 not guaranteed to return a fresh string. Note that you can pass NIL
309 for STRING which'll just be returned."
310 (let ((first-pos (position-if test string)))
311 (if (not first-pos)
312 ;; nothing to do, just return STRING
313 string
314 (with-output-to-string (s)
315 (loop with len = (length string)
316 for old-pos = 0 then (1+ pos)
317 for pos = first-pos
318 then (position-if test string :start old-pos)
319 ;; now the characters from OLD-POS to (excluding) POS
320 ;; don't have to be escaped while the next character has to
321 for char = (and pos (char string pos))
322 while pos
323 do (write-sequence string s :start old-pos :end pos)
324 (case char
325 ((#\<)
326 (write-sequence "&lt;" s))
327 ((#\>)
328 (write-sequence "&gt;" s))
329 ((#\&)
330 (write-sequence "&amp;" s))
331 ((#\')
332 (write-sequence "&#039;" s))
333 ((#\")
334 (write-sequence "&quot;" s))
335 (otherwise
336 (format s "&#~d;" (char-code char))))
337 while (< (1+ pos) len)
338 finally (unless pos
339 (write-sequence string s :start old-pos)))))))
340
341 (defun escape-string-minimal (string)
342 "Escape only #\<, #\>, and #\& in STRING."
343 (escape-string string :test #'(lambda (char) (find char "<>&"))))
344
345 (defun escape-string-minimal-plus-quotes (string)
346 "Like ESCAPE-STRING-MINIMAL but also escapes quotes."
347 (escape-string string :test #'(lambda (char) (find char "<>&'\""))))
348
349 (defun escape-string-iso-8859-1 (string)
350 "Escapes all characters in STRING which aren't defined in ISO-8859-1."
351 (escape-string string :test #'(lambda (char)
352 (or (find char "<>&'\"")
353 (> (char-code char) 255)))))
354
355 (defun escape-string-all (string)
356 "Escapes all characters in STRING which aren't in the 7-bit ASCII
357 character set."
358 (escape-string string :test #'(lambda (char)
359 (or (find char "<>&'\"")
360 (> (char-code char) 127)))))
Something went wrong with that request. Please try again.