Loose changes
This commit is contained in:
Ian Keane
parent
1cb167b597
commit
612c72bae1
57 changed files with 8904 additions and 80 deletions
|
|
@ -0,0 +1,342 @@
|
|||
;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: HTML-TEMPLATE; Base: 10 -*-
|
||||
;;; $Header: /usr/local/cvsrep/html-template/util.lisp,v 1.21 2015-05-21 20:59:59 edi Exp $
|
||||
|
||||
;;; Copyright (c) 2003-2007, Dr. Edmund Weitz. All rights reserved.
|
||||
|
||||
;;; Redistribution and use in source and binary forms, with or without
|
||||
;;; modification, are permitted provided that the following conditions
|
||||
;;; are met:
|
||||
|
||||
;;; * Redistributions of source code must retain the above copyright
|
||||
;;; notice, this list of conditions and the following disclaimer.
|
||||
|
||||
;;; * Redistributions in binary form must reproduce the above
|
||||
;;; copyright notice, this list of conditions and the following
|
||||
;;; disclaimer in the documentation and/or other materials
|
||||
;;; provided with the distribution.
|
||||
|
||||
;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED
|
||||
;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
|
||||
;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
|
||||
;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY
|
||||
;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
|
||||
;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
|
||||
;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
|
||||
;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
|
||||
;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
|
||||
;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
|
||||
;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
|
||||
|
||||
(in-package #:html-template)
|
||||
|
||||
(defun no-values (&rest rest)
|
||||
"A function which does not return any values. This is always the
|
||||
last function in a chain of template printer closures."
|
||||
(declare (ignore rest))
|
||||
(values))
|
||||
|
||||
(defun list-to-string (string-list)
|
||||
"Concatenates a list of strings to one string in reverse order. The
|
||||
list is destructively modified."
|
||||
;; note that we can't use APPLY with CONCATENATE here because of
|
||||
;; CALL-ARGUMENTS-LIMIT
|
||||
(let ((total-size 0))
|
||||
(dolist (string string-list)
|
||||
(incf total-size (length string)))
|
||||
(let ((result-string (make-string total-size
|
||||
#+:lispworks #+:lispworks
|
||||
:element-type 'lw:simple-char))
|
||||
(curr-pos 0))
|
||||
(dolist (string (nreverse string-list))
|
||||
(replace result-string string :start1 curr-pos)
|
||||
(incf curr-pos (length string)))
|
||||
result-string)))
|
||||
|
||||
(defun %read-char ()
|
||||
"Like READ-CHAR but updates the line and column counters."
|
||||
(let ((char (read-char)))
|
||||
(cond ((char= char #\Newline)
|
||||
(setf *current-column* 0)
|
||||
(incf *current-line*))
|
||||
(t (incf *current-column*)))
|
||||
char))
|
||||
|
||||
(defmacro whitespacep (char)
|
||||
"Checks whether CHAR is whitespace."
|
||||
`(find ,char
|
||||
'(#\Space #\Tab #\Newline #\Linefeed #\Return #\Page)))
|
||||
|
||||
(defun read-while (predicate &key (skip t) (eof-action t))
|
||||
"Reads characters from *STANDARD-INPUT* while PREDICATE returns a
|
||||
true value for each character. Returns the string which was read
|
||||
unless SKIP is true. On reading EOF an error is signaled if
|
||||
EOF-ACTION is T, NIL is silently returned if EOF-ACTION is NIL, or the
|
||||
function EOF-ACTION is called with one argument - the string read so
|
||||
far."
|
||||
(let ((collector (or skip
|
||||
(make-array 0
|
||||
:element-type 'character
|
||||
:fill-pointer t
|
||||
:adjustable t))))
|
||||
(handler-case
|
||||
(loop for c = (peek-char)
|
||||
while (funcall predicate c)
|
||||
do (cond (skip (%read-char))
|
||||
(t (vector-push-extend (%read-char) collector)))
|
||||
finally (return collector))
|
||||
(end-of-file ()
|
||||
(cond ((eq eof-action t)
|
||||
(signal-template-syntax-error "Unexpected EOF"))
|
||||
((null eof-action)
|
||||
nil)
|
||||
(t (funcall eof-action collector)))))))
|
||||
|
||||
(defun read-delimited-string (&key (eof-action t))
|
||||
"Reads and returns a string from *STANDARD-INPUT*. The string is
|
||||
either delimited by ' or \" in which case the delimiters aren't
|
||||
returned or it is assumed to extend to the next whitespace
|
||||
character. See READ-WHILE's docstring for EOF-ACTION."
|
||||
(handler-case
|
||||
(let* ((peek-char (peek-char))
|
||||
(delimiter (find peek-char '(#\' #\"))))
|
||||
(when delimiter
|
||||
(%read-char))
|
||||
(prog1
|
||||
(read-while (if delimiter
|
||||
(lambda (c) (char/= c delimiter))
|
||||
(lambda (c) (not (whitespacep c))))
|
||||
:skip nil
|
||||
:eof-action eof-action)
|
||||
(when delimiter
|
||||
(%read-char))))
|
||||
(end-of-file ()
|
||||
(cond ((eq eof-action t)
|
||||
(signal-template-syntax-error
|
||||
"Unexpected EOF while reading (delimited) string"))
|
||||
((null eof-action)
|
||||
nil)
|
||||
(t (funcall eof-action ""))))))
|
||||
|
||||
(defun skip-whitespace (&key assert (skip t) (eof-action t))
|
||||
"Read characters from *STANDARD-INPUT* as long as they are
|
||||
whitespace. Signals an error if the first character read isn't
|
||||
whitespace and ASSERT is true. Return the string which was read unless
|
||||
SKIP is true. See READ-WHILE's docstring for EOF-ACTION."
|
||||
(handler-case
|
||||
(progn
|
||||
(when assert
|
||||
(with-syntax-error-location ()
|
||||
(unless (whitespacep (peek-char))
|
||||
(signal-template-syntax-error "Whitespace expected but read ~S" (peek-char)))))
|
||||
(read-while (lambda (c)
|
||||
(whitespacep c))
|
||||
:skip skip
|
||||
:eof-action eof-action))
|
||||
(end-of-file ()
|
||||
(cond ((eq eof-action t)
|
||||
(signal-template-syntax-error "EOF while skipping whitespace"))
|
||||
((null eof-action)
|
||||
nil)
|
||||
(t (funcall eof-action ""))))))
|
||||
|
||||
(defun skip-trailing-whitespace ()
|
||||
"Reads and skips whitespace from *STANDARD-INPUT* until a #\Newline
|
||||
characters is seen if *IGNORE-EMPTY-LINES* is true. If there is no
|
||||
#\Newline before the first non-whitespace character the string read so
|
||||
far is returned \(wrapped in a list)."
|
||||
(cond (*ignore-empty-lines*
|
||||
(let ((string (read-while (lambda (c)
|
||||
(and (whitespacep c)
|
||||
(char/= #\Newline c)))
|
||||
:skip nil
|
||||
:eof-action nil)))
|
||||
(case (peek-char nil nil nil nil)
|
||||
((#\Newline)
|
||||
nil)
|
||||
(otherwise
|
||||
(list string)))))
|
||||
(t nil)))
|
||||
|
||||
(defun read-until (string &key (skip t) (eof-action t))
|
||||
"Reads characters from *STANDARD-INPUT* up to and including STRING.
|
||||
Returns the string which was read \(excluding STRING) unless SKIP is
|
||||
true. See READ-WHILE's docstring for EOF-ACTION."
|
||||
(let* ((length (length string))
|
||||
(offsets
|
||||
;; we first check whether some substring which starts
|
||||
;; STRING can be found again later in STRING - this is
|
||||
;; necessary because we only peek one character ahead
|
||||
(cond ((gethash string *find-string-hash*))
|
||||
(t (setf (gethash string *find-string-hash*)
|
||||
;; the resulting array of offsets is
|
||||
;; cached in *FIND-STRING-HASH* so we can
|
||||
;; use it again in case READ-UNTIL is
|
||||
;; called with the same STRING argument
|
||||
(loop with offsets = (make-array length
|
||||
:initial-element nil)
|
||||
for i from 1 below length
|
||||
;; check if STRING starting from 0
|
||||
;; has something in common with
|
||||
;; STRING starting from I
|
||||
for mismatch = (mismatch string string
|
||||
:start1 i :test #'char=)
|
||||
when (> mismatch i)
|
||||
;; if this is the case remember the
|
||||
;; length of the match plus the
|
||||
;; character which must follow in
|
||||
;; OFFSETS
|
||||
do (push (cons (char string (- mismatch i))
|
||||
(1+ (- mismatch i)))
|
||||
(svref offsets mismatch))
|
||||
finally (return offsets))))))
|
||||
(collector (or skip
|
||||
(make-array 0
|
||||
:element-type 'character
|
||||
:fill-pointer t
|
||||
:adjustable t))))
|
||||
(handler-case
|
||||
(loop for i = 0 then (cond (match (1+ i))
|
||||
;; if there is an offset (see above)
|
||||
;; we don't have to start from the
|
||||
;; beginning of STRING
|
||||
((cdr (assoc c (svref offsets i))))
|
||||
(t 0))
|
||||
for c = (peek-char)
|
||||
for match = (char= c (char string i))
|
||||
while (or (not match)
|
||||
(< (1+ i) length))
|
||||
do (cond (skip (%read-char))
|
||||
(t (vector-push-extend (%read-char) collector)))
|
||||
finally (%read-char)
|
||||
(unless skip
|
||||
;; decrement the fill pointer because collector now also
|
||||
;; contains STRING itself
|
||||
(decf (fill-pointer collector) (1- length)))
|
||||
(return collector))
|
||||
(end-of-file ()
|
||||
(cond ((eq eof-action t)
|
||||
(signal-template-syntax-error "Unexpected EOF"))
|
||||
((null eof-action)
|
||||
nil)
|
||||
(t (funcall eof-action collector)))))))
|
||||
|
||||
(defun skip-leading-whitespace (string)
|
||||
"Removes whitespace from the end of STRING up to and including a
|
||||
#\Newline. If there is no #\Newline before the first non-whitespace
|
||||
character is seen nothing is removed. STRING must have a fill
|
||||
pointer."
|
||||
(when *ignore-empty-lines*
|
||||
(let ((old-fill-pointer (fill-pointer string)))
|
||||
(loop for fill-pointer = (fill-pointer string)
|
||||
for char = (and (plusp fill-pointer)
|
||||
(char string (1- fill-pointer)))
|
||||
while (and char
|
||||
(whitespacep char)
|
||||
(char/= #\Newline char))
|
||||
do (decf (fill-pointer string)))
|
||||
(cond ((let ((fill-pointer (fill-pointer string)))
|
||||
(and (plusp fill-pointer)
|
||||
(char= #\Newline (char string (1- fill-pointer)))))
|
||||
(decf (fill-pointer string)))
|
||||
(t
|
||||
(setf (fill-pointer string)
|
||||
old-fill-pointer)))))
|
||||
string)
|
||||
|
||||
(defun read-tag-rest (&key read-attribute (intern t) (eof-action t))
|
||||
"Reads the rest of a template tag from *STANDARD-INPUT* after the
|
||||
name of the tag has been read. Reads and returns the tag's attribute
|
||||
if READ-ATTRIBUTE is true. Optionally also interns the attribute
|
||||
string if INTERN is true. See READ-WHILE's docstring for EOF-ACTION."
|
||||
(with-syntax-error-location ()
|
||||
(let (rest)
|
||||
(handler-case
|
||||
(let ((attribute (and read-attribute
|
||||
(progn
|
||||
(skip-whitespace :assert t)
|
||||
(let ((string (with-syntax-error-location ()
|
||||
(read-delimited-string :eof-action
|
||||
(lambda (collector)
|
||||
(declare (ignore collector))
|
||||
(signal-template-syntax-error
|
||||
"EOF while reading tag attribute"))))))
|
||||
(if intern
|
||||
(intern
|
||||
(funcall (if *upcase-attribute-strings*
|
||||
#'string-upcase
|
||||
#'identity)
|
||||
string)
|
||||
*template-symbol-package*)
|
||||
string))))))
|
||||
(skip-whitespace)
|
||||
(setq rest (read-until *template-end-marker*
|
||||
:skip nil
|
||||
:eof-action eof-action))
|
||||
(when (plusp (length rest))
|
||||
(signal-template-syntax-error "Expected ~S but read ~S"
|
||||
*template-end-marker*
|
||||
rest))
|
||||
attribute)
|
||||
(end-of-file ()
|
||||
(cond ((eq eof-action t)
|
||||
(signal-template-syntax-error "Unexpected EOF"))
|
||||
((null eof-action)
|
||||
nil)
|
||||
(t (funcall eof-action rest))))))))
|
||||
|
||||
(defun escape-string (string &key (test *escape-char-p*))
|
||||
(declare (optimize speed))
|
||||
"Escape all characters in STRING which pass TEST. This function is
|
||||
not guaranteed to return a fresh string. Note that you can pass NIL
|
||||
for STRING which'll just be returned."
|
||||
(let ((first-pos (position-if test string)))
|
||||
(if (not first-pos)
|
||||
;; nothing to do, just return STRING
|
||||
string
|
||||
(with-output-to-string (s)
|
||||
(loop with len = (length string)
|
||||
for old-pos = 0 then (1+ pos)
|
||||
for pos = first-pos
|
||||
then (position-if test string :start old-pos)
|
||||
;; now the characters from OLD-POS to (excluding) POS
|
||||
;; don't have to be escaped while the next character has to
|
||||
for char = (and pos (char string pos))
|
||||
while pos
|
||||
do (write-sequence string s :start old-pos :end pos)
|
||||
(case char
|
||||
((#\<)
|
||||
(write-sequence "<" s))
|
||||
((#\>)
|
||||
(write-sequence ">" s))
|
||||
((#\&)
|
||||
(write-sequence "&" s))
|
||||
((#\')
|
||||
(write-sequence "'" s))
|
||||
((#\")
|
||||
(write-sequence """ s))
|
||||
(otherwise
|
||||
(format s "&#~d;" (char-code char))))
|
||||
while (< (1+ pos) len)
|
||||
finally (unless pos
|
||||
(write-sequence string s :start old-pos)))))))
|
||||
|
||||
(defun escape-string-minimal (string)
|
||||
"Escape only #\<, #\>, and #\& in STRING."
|
||||
(escape-string string :test #'(lambda (char) (find char "<>&"))))
|
||||
|
||||
(defun escape-string-minimal-plus-quotes (string)
|
||||
"Like ESCAPE-STRING-MINIMAL but also escapes quotes."
|
||||
(escape-string string :test #'(lambda (char) (find char "<>&'\""))))
|
||||
|
||||
(defun escape-string-iso-8859-1 (string)
|
||||
"Escapes all characters in STRING which aren't defined in ISO-8859-1."
|
||||
(escape-string string :test #'(lambda (char)
|
||||
(or (find char "<>&'\"")
|
||||
(> (char-code char) 255)))))
|
||||
|
||||
(defun escape-string-all (string)
|
||||
"Escapes all characters in STRING which aren't in the 7-bit ASCII
|
||||
character set."
|
||||
(escape-string string :test #'(lambda (char)
|
||||
(or (find char "<>&'\"")
|
||||
(> (char-code char) 127)))))
|
||||
Loading…
Add table
Add a link
Reference in a new issue