ian/dotfiles
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Loose changes

Browse source
This commit is contained in:
Ian Keane 2020-02-25 06:06:49 -05:00
parent 1cb167b597
commit 612c72bae1
57 changed files with 8904 additions and 80 deletions
Download patch file Download diff file Expand all files Collapse all files

71
sbcl/.quicklisp/dists/quicklisp/software/html-template-20171227-git/CHANGELOG Normal file
View file

@ -0,0 +1,71 @@
Version 0.9.2
2015-05-21
Fixed bug in READ-UNTIL (thanks to Michael Malis)
Fixed typo in documentation (thanks to Atif Haider)
Version 0.9.1
2007-11-16
Fixed bug in SKIP-LEADING-WHITESPACE (thanks to Chaitanya Gupta)
Version 0.9.0
2007-03-09
Hand down external format to included files (suggested by Igor Plekhov)
Version 0.8.0
2006-12-12
Added TMPL_CALL (thanks to Marijn Haverbeke)
Version 0.7.0
2006-09-30
Added TMPL_REPEAT
Version 0.6.0
2006-09-14
Changed default for *VALUE-ACCESS-FUNCTION*
Added *STRING-MODIFIER*
Added ESCAPE-xxx functions (from CL-WHO)
Fixed docs for hyperdoc support
General documentation enhancements
Fixed test.lisp w.r.t. *FORMAT-NON-STRINGS*
Version 0.5.0
2006-09-08
Added *FORMAT-NON-STRINGS*
Version 0.4.0
2006-04-03
Added TMPL_UNLESS (requested by Igor Plekhov)
Version 0.3.1
2005-08-05
Introduced *FORCE-DEFAULT*
Version 0.3.0
2005-07-03
Introduced *TEMPLATE-OUTPUT* so template printers don't interfer with *STANDARD-OUTPUT* (proposed by Norman Werner)
Small enhancements to docs
Version 0.2.0
2005-06-09
Added :DO-NOT-CACHE option to CREATE-TEMPLATE-PRINTER
Added clever DEFMETHOD trick by Peter Seibel
Fixed bug in READ-UNTIL which doesn't affect HTML-TEMPLATE
Better example in docs inspired by Bruce R. Lewis' critique on lisp-web
Mention asdf-install in docs
Added hyperdoc support
Added :HTML-TEMPLATE to *FEATURES*
Version 0.1.2
2003-07-15
Argh, typo in index.html... :(
Version 0.1.1
2003-07-15
Cleaner use of restarts thanks to James Anderson and Kent M. Pitman
Updated docs accordingly (removed stuff about OTHER-VALUE)
Removed ECL specific stuff (no longer necessary due to recent ECL fixes by Juan Jose Garcia Ripoll)
Corrected date of 0.1.0 release in CHANGELOG (don't laugh!)
Version 0.1.0
2003-07-15
Initial release

33
sbcl/.quicklisp/dists/quicklisp/software/html-template-20171227-git/INSTALLATION Normal file
View file

@ -0,0 +1,33 @@
Installation of HTML-TEMPLATE
1. Probably the easiest way is
(load "/path/to/html-template/load.lisp")
This should compile and load HTML-TEMPLATE on most Common Lisp
implementations.
2. With MK:DEFSYSTEM you can make a symlink from 'html-template.system'
to your central registry and then issue the command
(mk:compile-system "html-template")
Note that this relies on TRUENAME returning the original file a
symbolic link is pointing to. With AllegroCL 6.2 this will only
work if you've applied all patches with (SYS:UPDATE-ALLEGRO).
3. You can also use ASDF instead of MK:DEFSYSTEM in a similar way:
(asdf:operate 'asdf:compile-op :html-template)
(asdf:operate 'asdf:load-op :html-template)
After installing HTML-TEMPLATE you can LOAD the file "test.lisp" to
check if everything works as expected.
Complete documentation for HTML-TEMPLATE can be found in the 'doc'
directory.
HTML-TEMPLATE also supports Nikodemus Siivola's HYPERDOC, see
<http://common-lisp.net/project/hyperdoc/> and
<http://www.cliki.net/hyperdoc>.

21
sbcl/.quicklisp/dists/quicklisp/software/html-template-20171227-git/README.md Normal file
View file

@ -0,0 +1,21 @@
---------------------------------------------------
HTML-TEMPLATE - Use HTML templates from Common Lisp
---------------------------------------------------
HTML-TEMPLATE is a portable library for Common Lisp which can be used
to fill templates with arbitrary (string) values at runtime.
(Actually, it doesn't matter whether the result is HTML. It's just
very likely that this will be what the library is mostly used for.)
It is loosely modeled after the Perl module HTML::Template and
partially compatible with a its syntax, though both libraries contain
some extensions that the other does not support.
HTML-TEMPLATE translates templates into efficient closures which can
be re-used as often as needed. It uses an intelligent cache mechanism
so you can nevertheless update templates while your program is running
and have the changes take effect immediately.
Complete documentation for HTML-TEMPLATE can be found in the `docs`
directory or at the [project documentation
site](https://edicl.github.io/html-template/).

160
sbcl/.quicklisp/dists/quicklisp/software/html-template-20171227-git/api.lisp Normal file
View file

@ -0,0 +1,160 @@
;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: HTML-TEMPLATE; Base: 10 -*-
;;; $Header: /usr/local/cvsrep/html-template/api.lisp,v 1.22 2007-03-09 13:09:16 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)
(defgeneric create-template-printer (template
&key force
element-type
if-does-not-exist
external-format)
(:documentation "Creates a template printer from TEMPLATE which is
an open input stream, a string, or a pathname. If FORCE is true a
printer will be newly created no matter what the state of the cache
is. If FORCE is :DO-NOT-CACHE the newly created printer won't be
cached. Other keyword arguments will be given to WITH-OPEN-FILE.
Keyword arguments will only be accepted if TEMPLATE is a PATHNAME."))
(defmethod create-template-printer ((input-stream stream) &rest rest)
(when rest
(signal-template-invocation-error
"This method doesn't accept keyword arguments"))
(let ((*standard-input* input-stream))
(%create-template-printer-aux nil nil)))
(defmethod create-template-printer ((string string) &rest rest)
(when rest
(signal-template-invocation-error
"This method doesn't accept keyword arguments"))
(with-input-from-string (*standard-input* string)
(%create-template-printer-aux nil nil)))
(defmethod create-template-printer ((pathname pathname)
&key (force *force-default*)
(element-type #-:lispworks 'character
#+:lispworks 'lw:simple-char)
(if-does-not-exist :error)
(external-format *external-format*))
(let* ((merged-pathname (merge-pathnames pathname
*default-template-pathname*))
(file-write-date (or *no-cache-check*
(file-write-date merged-pathname))))
(destructuring-bind (hashed-printer . creation-date)
;; see if a printer for this pathname is in the cache
(or (gethash merged-pathname *printer-hash*)
'(nil . nil))
(when (and hashed-printer
;; and if we may use it
(not force)
;; and if it's not too old (or maybe we don't have to
;; check)
(or *no-cache-check*
(and file-write-date
(<= file-write-date creation-date))))
(return-from create-template-printer hashed-printer))
(let ((new-printer
;; push this pathname onto stack of included files (so
;; to say) to make sure a file can't include itself
;; recursively
(let ((*included-files* (cons merged-pathname
*included-files*))
(*external-format* external-format))
(with-open-file (*standard-input* merged-pathname
:direction :input
:if-does-not-exist if-does-not-exist
:element-type element-type
:external-format external-format)
(%create-template-printer-aux nil nil)))))
;; cache newly created printer (together with current time)
(unless (eq force :do-not-cache)
(setf (gethash merged-pathname *printer-hash*)
(cons new-printer (get-universal-time))))
;; optionally issue a warning
(when *warn-on-creation*
(warn "New template printer for ~S created" merged-pathname))
new-printer))))
(defgeneric fill-and-print-template (template/printer values
&key stream
&allow-other-keys)
(:documentation "Fills the template denoted by TEMPLATE/PRINTER with
VALUES and print it to STREAM. If TEMPLATE/PRINTER is a function uses
it as if it were a template printer, otherwise creates a printer \(or
pull one out of the cache) with CREATE-TEMPLATE-PRINTER. Optional
keyword arguments are given to CREATE-TEMPLATE printer and can only be
used if TEMPLATE/PRINTER is a pathname."))
(defmethod fill-and-print-template ((function function) values
&rest rest
&key (stream *default-template-output*))
(remf rest :stream)
(when rest
(signal-template-invocation-error
"This method doesn't accept keyword arguments other than STREAM"))
(let ((*template-output* stream))
(funcall function values)))
(defmethod fill-and-print-template ((string string) values
&rest rest
&key (stream *default-template-output*))
(remf rest :stream)
(when rest
(signal-template-invocation-error
"This method doesn't accept keyword arguments other than STREAM"))
(let ((*template-output* stream))
(funcall (create-template-printer string) values)))
(defmethod fill-and-print-template ((input-stream stream) values
&rest rest
&key (stream *default-template-output*))
(remf rest :stream)
(when rest
(signal-template-invocation-error
"This method doesn't accept keyword arguments other than STREAM"))
(let ((*template-output* stream))
(funcall (create-template-printer input-stream) values)))
(defmethod fill-and-print-template ((pathname pathname) values
&rest rest
&key (stream *default-template-output*))
(remf rest :stream)
(let ((*template-output* stream))
(funcall (apply #'create-template-printer pathname rest) values)))
(defun clear-template-cache ()
"Complete clears all template printers from the cache."
(clrhash *printer-hash*)
(values))
(defun delete-from-template-cache (pathname)
"Deletes the template printer denoted by PATHNAME from the
cache. Returns true if such a printer existed, false otherwise."
(remhash (merge-pathnames pathname
*default-template-pathname*)
*printer-hash*))

1472
sbcl/.quicklisp/dists/quicklisp/software/html-template-20171227-git/docs/index.html Normal file
View file

File diff suppressed because it is too large Load diff

106
sbcl/.quicklisp/dists/quicklisp/software/html-template-20171227-git/errors.lisp Normal file
View file

@ -0,0 +1,106 @@
;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: HTML-TEMPLATE-LISP; Base: 10 -*-
;;; $Header: /usr/local/cvsrep/html-template/errors.lisp,v 1.8 2007-01-01 23:49:16 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)
(defstruct syntax-error-location
"Structure to store parser locations consisting of a stream, a line
number, and a column number."
line col stream)
(defvar *syntax-error-location* (make-syntax-error-location)
"Used internally to remember the last position which made sense to
the parser.")
(define-condition template-error (simple-error)
()
(:documentation "All errors signaled by HTML-TEMPLATE are of
this type."))
(define-condition template-invocation-error (template-error)
()
(:documentation "Signaled when HTML-TEMPLATE functions are
invoked with wrong arguments."))
(define-condition template-missing-value-error (template-error)
()
(:documentation "Signaled when a TMPL_VAR printer is provided
with a NIL value and *CONVERT-NIL-TO-EMPTY-STRING* is false."))
(define-condition template-not-a-string-error (template-error)
((value :initarg :value
:reader template-not-a-string-error-value))
(:documentation "Signaled when a TMPL_VAR printer is provided
with a non-string value."))
(define-condition template-syntax-error (template-error)
((line :initarg :line
:reader template-syntax-error-line)
(col :initarg :col
:reader template-syntax-error-col)
(stream :initarg :stream
:reader template-syntax-error-stream))
(:default-initargs
:line (syntax-error-location-line *syntax-error-location*)
:col (syntax-error-location-col *syntax-error-location*)
:stream (syntax-error-location-stream *syntax-error-location*))
(:report (lambda (condition stream)
(format stream "~?~%[Line ~A, column ~A, stream ~A]"
(simple-condition-format-control condition)
(simple-condition-format-arguments condition)
(template-syntax-error-line condition)
(template-syntax-error-col condition)
(template-syntax-error-stream condition))))
(:documentation "Signaled when a syntax error occurs while
parsing a template."))
(defmacro signal-template-invocation-error (format-control &rest format-arguments)
`(error 'template-invocation-error
:format-control ,format-control
:format-arguments (list ,@format-arguments)))
(defmacro signal-template-missing-value-error (format-control &rest format-arguments)
`(error 'template-missing-value-error
:format-control ,format-control
:format-arguments (list ,@format-arguments)))
(defmacro signal-template-syntax-error (format-control &rest format-arguments)
`(error 'template-syntax-error
:format-control ,format-control
:format-arguments (list ,@format-arguments)))
(defmacro with-syntax-error-location ((&rest rest) &body body)
"This is wrapped around forms in order to remember a meaningful
position within the stream in case an error has to be signaled."
(declare (ignore rest))
`(let ((*syntax-error-location* (make-syntax-error-location
:line *current-line*
:col *current-column*
:stream *standard-input*)))
,@body))

38
sbcl/.quicklisp/dists/quicklisp/software/html-template-20171227-git/html-template.asd Normal file
View file

@ -0,0 +1,38 @@
;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*-
;;; $Header: /usr/local/cvsrep/html-template/html-template.asd,v 1.16 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.
(asdf:defsystem :html-template
:version "0.9.2"
:serial t
:components ((:file "packages")
(:file "specials")
(:file "errors")
(:file "util")
(:file "template")
(:file "api")))

44
sbcl/.quicklisp/dists/quicklisp/software/html-template-20171227-git/html-template.system Normal file
View file

@ -0,0 +1,44 @@
;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*-
;;; $Header: /usr/local/cvsrep/html-template/html-template.system,v 1.5 2007-01-01 23:49:16 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 #:cl-user)
(defparameter *html-template-base-directory*
(make-pathname :name nil :type nil :version nil
:defaults (parse-namestring *load-truename*)))
(mk:defsystem #:html-template
:source-pathname *html-template-base-directory*
:source-extension "lisp"
:components ((:file "packages")
(:file "specials" :depends-on ("packages"))
(:file "errors" :depends-on ("specials"))
(:file "util" :depends-on ("errors"))
(:file "template" :depends-on ("util"))
(:file "api" :depends-on ("template"))))

54
sbcl/.quicklisp/dists/quicklisp/software/html-template-20171227-git/load.lisp Normal file
View file

@ -0,0 +1,54 @@
;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*-
;;; $Header: /usr/local/cvsrep/html-template/load.lisp,v 1.7 2007-01-01 23:49:16 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 #:cl-user)
(let ((html-template-base-directory
(make-pathname :name nil :type nil :version nil
:defaults (parse-namestring *load-truename*)))
must-compile)
(with-compilation-unit ()
(loop for file in '("packages"
"specials"
"errors"
"util"
"template"
"api")
do (let ((pathname (make-pathname :name file :type "lisp" :version nil
:defaults html-template-base-directory)))
#-:cormanlisp
(let ((compiled-pathname (compile-file-pathname pathname)))
(unless (and (not must-compile)
(probe-file compiled-pathname)
(< (file-write-date pathname)
(file-write-date compiled-pathname)))
(setq must-compile t)
(compile-file pathname))
(setq pathname compiled-pathname))
(load pathname)))))

72
sbcl/.quicklisp/dists/quicklisp/software/html-template-20171227-git/packages.lisp Normal file
View file

@ -0,0 +1,72 @@
;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*-
;;; $Header: /usr/local/cvsrep/html-template/packages.lisp,v 1.19 2007-01-01 23:49:16 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 :cl-user)
(defpackage :html-template
(:nicknames :template)
(:use :cl)
(:export :*call-template-access-function*
:*call-values-access-function*
:*convert-nil-to-empty-string*
:*default-template-output*
:*default-template-pathname*
:*escape-char-p*
:*force-default*
:*format-non-strings*
:*ignore-empty-lines*
:*no-cache-check*
:*sequences-are-lists*
:*string-modifier*
:*template-end-marker*
:*template-start-marker*
:*template-symbol-package*
:*upcase-attribute-strings*
:*value-access-function*
:*warn-on-creation*
:clear-template-cache
:create-template-printer
:delete-from-template-cache
:escape-string
:escape-string-all
:escape-string-iso-8859-1
:escape-string-minimal
:escape-string-minimal-plus-quotes
:fill-and-print-template
:template-error
:template-invocation-error
:template-missing-value-error
:template-not-a-string-error
:template-not-a-string-error-value
:template-syntax-error
:template-syntax-error-col
:template-syntax-error-line
:template-syntax-error-stream))
(pushnew :html-template *features*)

151
sbcl/.quicklisp/dists/quicklisp/software/html-template-20171227-git/specials.lisp Normal file
View file

@ -0,0 +1,151 @@
;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: HTML-TEMPLATE; Base: 10 -*-
;;; $Header: /usr/local/cvsrep/html-template/specials.lisp,v 1.24 2007-03-09 13:09:16 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)
(defvar *find-string-hash* (make-hash-table :test #'equal)
"Hash tables used internally by READ-UNTIL to cache offset arrays.")
(defvar *template-start-marker* "<!--"
"The string template tags must start with")
(defvar *template-end-marker* "-->"
"The string template tags must end with")
(defvar *printer-hash* (make-hash-table :test #'equal)
"The cache for template printers.
Each entry is of the form (PRINTER . WRITE-DATE).")
(defvar *default-template-pathname* (make-pathname)
"Each pathname is merged with this value before it is used by
CREATE-TEMPLATE-PRINTER.")
(defvar *default-template-output* *standard-output*
"The output stream used by FILL-AND-PRINT-TEMPLATE when no STREAM
keyword was provided.")
(defvar *template-output* nil
"The output stream that's used internally.")
(defvar *convert-nil-to-empty-string* t
"Controls whether NIL values should resolve to empty strings or
raise an error.")
(defvar *format-non-strings* t
"Controls whether TMPL_VAR will accept values which aren't
strings and convert them using \(FORMAT NIL \"~A\" ...).")
(defvar *sequences-are-lists* t
"Controls whether TMPL_LOOP printers expect lists or vectors.")
(defvar *upcase-attribute-strings* t
"Controls whether attribute strings associated with template tags
are upcased before they are interned.")
(defvar *no-cache-check* nil
"Controls whether the FILE-WRITE-DATE check will be circumvented
when using FILL-AND-PRINT-TEMPLATE.")
(defvar *template-symbol-package* (find-package '#:keyword)
"The package symbols are interned into.")
(defvar *ignore-empty-lines* nil
"Controls whether template tags on their own lines produce empty
lines or not.")
(defvar *warn-on-creation* t
"Controls whether a warning should be signaled if a new template
printer is created from a pathname argument.")
(defvar *current-line* 1
"Internal line counter of the parser.")
(defvar *current-column* 0
"Internal column counter of the parser.")
(defvar *included-files* nil
"Internally used by CREATE-TEMPLATE-PRINTER-AUX to avoid infinite
TMPL_INCLUDE loops.")
(defvar *external-format* :default
"The external format used when opening files.")
(defvar *value-access-function*
(lambda (symbol values &optional in-loop-p)
(let ((result (getf values symbol)))
(cond ((and in-loop-p *sequences-are-lists*)
(loop for element in result
when (and element (listp element))
;; keep values from upper levels
collect (append element values)
else
collect element))
(t result))))
"The function which associates \(attribute) symbols with their
values.")
(defvar *call-template-access-function* #'car
"Accessor function for extracting the called template from a
TMPL_CALL form.")
(defvar *call-value-access-function* #'cdr
"Accessor function for extracting the values from a TMPL_CALL
form.")
(defvar *force-default* nil
"The default value for the FORCE keyword argument to
CREATE-TEMPLATE-PRINTER.")
(defvar *string-modifier* 'escape-string-iso-8859-1
"The function which is applied to strings which replace
TMPL_VAR tags. Use #'CL:IDENTITY if you don't want to change the
strings.")
(defparameter *escape-char-p*
#'(lambda (char)
(or (find char "<>&'\"")
(> (char-code char) 127)))
"Used by ESCAPE-STRING to test whether a character should be escaped.")
;; stuff for Nikodemus Siivola's HYPERDOC
;; see <http://common-lisp.net/project/hyperdoc/>
;; and <http://www.cliki.net/hyperdoc>
;; also used by LW-ADD-ONS
(defvar *hyperdoc-base-uri* "http://weitz.de/html-template/")
(let ((exported-symbols-alist
(loop for symbol being the external-symbols of :html-template
collect (cons symbol
(concatenate 'string
"#"
(string-downcase symbol))))))
(defun hyperdoc-lookup (symbol type)
(declare (ignore type))
(cdr (assoc symbol
exported-symbols-alist
:test #'eq))))

474
sbcl/.quicklisp/dists/quicklisp/software/html-template-20171227-git/template.lisp Normal file
View file

@ -0,0 +1,474 @@
;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: HTML-TEMPLATE; Base: 10 -*-
;;; $Header: /usr/local/cvsrep/html-template/template.lisp,v 1.24 2007-01-01 23:49:16 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)
(defmacro with-use-value-restart ((symbol) error-form)
"Provide a USE-VALUE restart for ERROR-FORM in case the value
associated with SYMBOL isn't to our liking."
`(restart-case
,error-form
(use-value (other-value)
:report (lambda (stream)
(format stream
"Use another value for symbol ~S: "
,symbol))
:interactive (lambda ()
(format t
"Enter another value for symbol ~S: "
,symbol)
(multiple-value-list (eval (read))))
other-value)))
;; indentation for LispWorks editor
#+:lispworks
(editor:setup-indent "with-use-value-restart" 1 2 4)
(defun create-simple-printer (string-list &optional (next-fn #'no-values))
"Used internally to create template printers for strings which don't
include template tags. NEXT-FN is the next function to be called in
the chain of closures. STRING-LIST is a list of strings in reverse
order to be printed first."
(let ((string (list-to-string string-list)))
(lambda (values)
(write-string string *template-output*)
(funcall next-fn values))))
(defun create-var-printer (string-list symbol next-fn)
"Used internally to create template printers for TMPL_VAR. SYMBOL is
the symbol associated with the tag. NEXT-FN is the next function to be
called in the chain of closures. STRING-LIST is a list of strings in
reverse order to be printed first."
(let ((string (list-to-string string-list)))
(lambda (values)
(write-string string *template-output*)
(let* ((value (funcall *value-access-function* symbol values))
(string (typecase value
(null
(if *convert-nil-to-empty-string*
""
(with-use-value-restart (symbol)
(signal-template-missing-value-error
"Value for symbol ~S is NIL"
symbol))))
(string value)
(otherwise
(cond (*format-non-strings* (format nil "~A" value))
(t (with-use-value-restart (symbol)
(error 'template-not-a-string-error
:value value
:format-control "Value ~S for symbol ~S is not a string"
:format-arguments (list value symbol)))))))))
(write-string (funcall *string-modifier* string) *template-output*))
(funcall next-fn values))))
(defun create-include-printer (string-list pathname next-fn)
"Used internally to create template printers for TMPL_INCLUDE.
PATHNAME is the pathname associated with the tag. NEXT-FN is the next
function to be called in the chain of closures. STRING-LIST is a list
of strings in reverse order to be printed first."
(let ((string (list-to-string string-list)))
(lambda (values)
(write-string string *template-output*)
(funcall (car (gethash pathname *printer-hash*)) values)
(funcall next-fn values))))
(defun create-if-printer (string-list symbol if-fn else-fn next-fn unlessp)
"Used internally to create template printers for TMPL_IF and
TMPL_UNLESS tags. SYMBOL is the symbol associated with the tag. IF-FN
is the printer for the IF branch, ELSE-FN is the printer for the ELSE
branch. NEXT-FN is the next function to be called in the chain of
closures. STRING-LIST is a list of strings in reverse order to be
printed first. If UNLESSP is true, IF-FN and ELSE-FN are switched."
(let ((string (list-to-string string-list)))
(when unlessp
(rotatef if-fn else-fn))
(lambda (values)
(write-string string *template-output*)
(if (funcall *value-access-function* symbol values)
(funcall if-fn values)
(funcall else-fn values))
(funcall next-fn values))))
(defun create-loop-printer (string-list symbol body-fn next-fn)
"Used internally to create template printers for TMPL_LOOP
tags. SYMBOL is the symbol associated with the tag. BODY-FN is the
template printer for the body of the loop. NEXT-FN is the next
function to be called in the chain of closures. STRING-LIST is a list
of strings in reverse order to be printed first."
(let ((string (list-to-string string-list)))
(cond (*sequences-are-lists*
(lambda (values)
(write-string string *template-output*)
(dolist (value (funcall *value-access-function*
symbol values t))
(funcall body-fn value))
(funcall next-fn values)))
(t
(lambda (values)
(write-string string *template-output*)
(loop for value across (funcall *value-access-function*
symbol values t)
do (funcall body-fn value))
(funcall next-fn values))))))
(defun create-repeat-printer (string-list symbol body-fn next-fn)
"Used internally to create template printers for TMPL_REPEAT
tags. SYMBOL is the symbol associated with the tag. BODY-FN is the
template printer for the body of the loop. NEXT-FN is the next
function to be called in the chain of closures. STRING-LIST is a list
of strings in reverse order to be printed first."
(let ((string (list-to-string string-list)))
(lambda (values)
(write-string string *template-output*)
(let ((factor (funcall *value-access-function* symbol values)))
(when (and (integerp factor) (plusp factor))
(loop repeat factor
do (funcall body-fn values))))
(funcall next-fn values))))
(defun create-call-printer (string-list symbol next-fn)
"Used internally to create template printers for TMPL_CALL tags.
SYMBOL is the symbol associated with the tag. BODY-FN is the template
printer for the body of the loop. NEXT-FN is the next function to be
called in the chain of closures. STRING-LIST is a list of strings in
reverse order to be printed first."
(let ((string (list-to-string string-list)))
(cond (*sequences-are-lists*
(lambda (values)
(write-string string *template-output*)
(dolist (call (funcall *value-access-function*
symbol values t))
(fill-and-print-template
(funcall *call-template-access-function* call)
(funcall *call-value-access-function* call)
:stream *template-output*))
(funcall next-fn values)))
(t
(lambda (values)
(write-string string *template-output*)
(loop for call across (funcall *value-access-function*
symbol values t)
do (fill-and-print-template
(funcall *call-template-access-function* call)
(funcall *call-value-access-function* call)
:stream *template-output*))
(funcall next-fn values))))))
(defun create-template-printer-aux (string-stack end-token)
"Reads from *STANDARD-INPUT* and returns a template printer from
what it reads. When this function is entered the stream pointer must
not be inside a template tag. STRING-STACK is a list of strings (in
reverse order) read so far which haven't been used to build a template
printer. END-TOKEN is either NIL or one of :LOOP, :REPEAT, :IF,
:IF-ELSE, or :UNLESS-ELSE denoting that we expect certain tags to
close open TMPL_LOOP, TMPL_REPEAT, TMPL_IF, or TMPL_UNLESS tags. This
function returns a second value which is true if, after reading
TMPL_IF or TMPL_UNLESS, a corresponding TMPL_ELSE was seen."
(let* ((string
;; read text up to the next template start marker
(read-until *template-start-marker*
;; don't skip it, return it
:skip nil
:eof-action (lambda (collector)
(when end-token
;; make sure we don't accept
;; EOF if there are still tags
;; waiting to be closed
(signal-template-syntax-error
"Unexpected EOF, ~A tag is missing"
(case end-token
((:loop) "<!-- /TMPL_LOOP -->")
((:repeat) "<!-- /TMPL_REPEAT -->")
((:if :if-else) "<!-- /TMPL_IF -->")
((:unless :unless-else) "<!-- /TMPL_UNLESS -->"))))
;; otherwise (EOF before another
;; start marker was seen) just
;; return a template printer
;; which unconditionally prints
;; the rest of the stream
(return-from create-template-printer-aux
(create-simple-printer
(cons collector string-stack))))))
(whitespace
;; skip whitespace but keep it in case this turns out not
;; to be a template tag
(skip-whitespace :skip nil))
(token
;; read what could be a template token's name
(with-syntax-error-location ()
(read-while (lambda (c)
(or (alpha-char-p c)
(char= c #\_)
(char= c #\/)))
:skip nil
:eof-action (lambda (collector)
(declare (ignore collector))
;; complain about tags which
;; haven't been closed
(signal-template-syntax-error
"EOF while inside of tag starting with ~S"
*template-start-marker*))))))
(cond ((string-equal token "TMPL_INCLUDE")
;; TMPL_INCLUDE tag - first read the pathname which has to
;; follow and merge it with *DEFAULT-TEMPLATE-PATHNAME*
(let* ((pathname (read-tag-rest :read-attribute t :intern nil))
(merged-pathname
(merge-pathnames pathname
*default-template-pathname*)))
(when (member merged-pathname *included-files*
:test #'equal)
;; raise an error if this file has been included
;; before - infinite recursion ahead!
(with-syntax-error-location ()
(signal-template-syntax-error
"Infinite recursion - file ~S includes itself"
merged-pathname)))
;; otherwise create (and cache) a template printer
(create-template-printer merged-pathname)
(multiple-value-bind (next-fn else-follows)
;; first we recursively create the template printer
;; for the rest of the stream
(create-template-printer-aux (skip-trailing-whitespace)
end-token)
;; then we combine it with the strings before the tag
;; to create a template printer for TMPL_INCLUDE
(values
(create-include-printer (cons (skip-leading-whitespace string)
string-stack)
merged-pathname
next-fn)
else-follows))))
((string-equal token "TMPL_VAR")
;; TMPL_VAR tag - first read the symbol which has to
;; follow and intern it
(let ((symbol (read-tag-rest :read-attribute t)))
(multiple-value-bind (next-fn else-follows)
;; first we recursively create the template printer
;; for the rest of the stream
(create-template-printer-aux nil end-token)
(values
;; then we combine it with the strings before the tag
;; to create a template printer for TMPL_VAR - note
;; that we don't skip leading and trailing whitespace
;; here
(create-var-printer (cons string string-stack)
symbol
next-fn)
else-follows))))
((or (string-equal token "TMPL_LOOP")
(string-equal token "TMPL_REPEAT"))
;; TMPL_LOOP or TMPL_REPEAT tag - first read the symbol
;; which has to follow and intern it
(let* ((kind (if (string-equal token "TMPL_LOOP") :loop :repeat))
(symbol (read-tag-rest :read-attribute t))
;; then read the stream up to the corresponding
;; end tag and create a template printer for the
;; loop body
(body-fn (with-syntax-error-location ()
(create-template-printer-aux
(skip-trailing-whitespace)
;; this argument denotes that we expect
;; to see /TMPL_LOOP or /TMPL_REPEAT and
;; want to stop there
kind))))
(multiple-value-bind (next-fn else-follows)
;; now we recursively create the template printer
;; for the rest of the stream
(create-template-printer-aux (skip-trailing-whitespace)
end-token)
(values
;; then we combine it with the strings before the tag
;; and the body printer to create a template printer
;; for TMPL_LOOP
(funcall (case kind
(:loop #'create-loop-printer)
(:repeat #'create-repeat-printer))
(cons (skip-leading-whitespace string)
string-stack)
symbol
body-fn
next-fn)
else-follows))))
((string-equal token "TMPL_CALL")
;; TMPL_CALL tag - first read the symbol which has to
;; follow and intern it
(let ((symbol (read-tag-rest :read-attribute t)))
(multiple-value-bind (next-fn else-follows)
;; recursively create the template printer for the
;; rest of the stream
(create-template-printer-aux (skip-trailing-whitespace)
end-token)
;; create the printer that will output the strings
;; before this tag and call the templates stored under
;; SYMBOL
(values (funcall #'create-call-printer
(cons (skip-leading-whitespace string)
string-stack)
symbol
next-fn)
else-follows))))
((string-equal token "/TMPL_LOOP")
(unless (eq end-token :loop)
;; check if we expected /TMPL_LOOP here, i.e. if an open
;; TMPL_LOOP was pending
(with-syntax-error-location ()
(signal-template-syntax-error "Unexpected /TMPL_LOOP")))
;; read the rest of the tag but ignore it - no attributes
;; expected
(read-tag-rest)
;; just create a simple template printer for strings -
;; this is the end of some TMPL_LOOP body
(create-simple-printer (cons (skip-leading-whitespace string)
string-stack)))
((string-equal token "/TMPL_REPEAT")
(unless (eq end-token :repeat)
;; check if we expected /TMPL_REPEAT here, i.e. if an open
;; TMPL_REPEAT was pending
(with-syntax-error-location ()
(signal-template-syntax-error "Unexpected /TMPL_REPEAT")))
;; read the rest of the tag but ignore it - no attributes
;; expected
(read-tag-rest)
;; just create a simple template printer for strings -
;; this is the end of some TMPL_REPEAT body
(create-simple-printer (cons (skip-leading-whitespace string)
string-stack)))
((or (string-equal token "TMPL_IF")
(string-equal token "TMPL_UNLESS"))
;; TMPL_IF or TMPL_UNLESS tag - first read the symbol
;; which has to follow and intern it
(let ((symbol (read-tag-rest :read-attribute t))
(unlessp (string-equal token "TMPL_UNLESS")))
(multiple-value-bind (if-fn else-follows)
(with-syntax-error-location ()
;; then read the stream up to the corresponding
;; TMPL_ELSE, /TMPL_IF, or /TMPL_UNLESS and create
;; a template printer for the "if" (or "unless") part
(create-template-printer-aux
(skip-trailing-whitespace)
;; this argument denotes that we expect to see
;; TMPL_ELSE _or_ one of /TMPL_IF, /TMPL_UNLESS and,
;; in the second case, want to stop there
(if unlessp :unless-else :if-else)))
(let ((else-fn (if else-follows
;; if we encountered TMPL_ELSE read
;; the stream up to the corresponding
;; /TMPL_IF or /TMPL_UNLESS and
;; create a template printer for the "else" part
(with-syntax-error-location ()
(create-template-printer-aux
(skip-trailing-whitespace)
;; this argument denotes that we
;; expect to see /TMPL_IF or /TMPL_UNLESS
;; (but not TMPL_ELSE) and want to stop
;; there
(if unlessp :unless :if)))
;; use a dummy printer for the "else"
;; part if we didn't see TMPL_ELSE
#'no-values)))
(multiple-value-bind (next-fn else-follows)
;; now we recursively create the template printer
;; for the rest of the stream
(create-template-printer-aux (skip-trailing-whitespace)
end-token)
(values
;; then we combine it with the strings before the
;; tag and the "if" and "else" parts to create a
;; template printer for TMPL_IF or TMPL_UNLESS
(create-if-printer (cons (skip-leading-whitespace string)
string-stack)
symbol
if-fn
else-fn
next-fn
unlessp)
else-follows))))))
((string-equal token "TMPL_ELSE")
(unless (member end-token '(:if-else :unless-else))
;; check if we expected /TMPL_ELSE here, i.e. if an open
;; TMPL_IF or TMPL_UNLESS was pending and we haven't
;; seen TMPL_ELSE before
(with-syntax-error-location ()
(signal-template-syntax-error "Unexpected TMPL_ELSE")))
;; read the rest of the tag but ignore it - no attributes
;; expected
(read-tag-rest)
;; just create a simple template printer for strings -
;; this is the end of some "if" part
(values
(create-simple-printer (cons (skip-leading-whitespace string)
string-stack))
;; return a true second value to denote that we've seen
;; TMPL_ELSE
t))
((string-equal token "/TMPL_IF")
(unless (or (eq end-token :if) (eq end-token :if-else))
;; check if we expected /TMPL_IF here, i.e. if an open
;; TMPL_IF was pending
(with-syntax-error-location ()
(signal-template-syntax-error "Unexpected /TMPL_IF")))
;; read the rest of the tag but ignore it - no attributes
;; expected
(read-tag-rest)
;; just create a simple template printer for strings -
;; this is the end of some "if" or "else" part
(create-simple-printer (cons (skip-leading-whitespace string)
string-stack)))
((string-equal token "/TMPL_UNLESS")
(unless (or (eq end-token :unless) (eq end-token :unless-else))
;; check if we expected /TMPL_UNLESS here, i.e. if an open
;; TMPL_UNLESS was pending
(with-syntax-error-location ()
(signal-template-syntax-error "Unexpected /TMPL_UNLESS")))
;; read the rest of the tag but ignore it - no attributes
;; expected
(read-tag-rest)
;; just create a simple template printer for strings -
;; this is the end of some "unless" or "else" part
(create-simple-printer (cons (skip-leading-whitespace string)
string-stack)))
(t
;; we couldn't identify a valid tag, so we treat
;; everything we've read so far as a literal string and
;; carry on - if we're lucky our CL implementation will
;; optimize this tail call into an iterative loop
(create-template-printer-aux
(cons token
(cons whitespace
(cons *template-start-marker*
(cons string string-stack))))
end-token)))))
(defun %create-template-printer-aux (&rest args)
"Wrapper for CREATE-TEMPLATE-PRINTER-AUX to initialize
*CURRENT-COLUMN* and *CURRENT-LINE*."
(let ((*current-column* 0)
(*current-line* 1))
(apply #'create-template-printer-aux args)))

291
sbcl/.quicklisp/dists/quicklisp/software/html-template-20171227-git/test.lisp Normal file
View file

@ -0,0 +1,291 @@
;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: HTML-TEMPLATE-TEST; Base: 10 -*-
;;; $Header: /usr/local/cvsrep/html-template/test.lisp,v 1.13 2007-01-01 23:49:16 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 #:cl-user)
#-:cormanlisp
(defpackage #:html-template-test
(:use #:cl #:html-template))
#+:cormanlisp
(defpackage "HTML-TEMPLATE-TEST"
(:use "CL" "HTML-TEMPLATE"))
(in-package #:html-template-test)
(format t "~&Please wait a couple of seconds.")
(force-output)
(defvar tmp-dir #p"/tmp/")
(defmacro failedp (&body body)
`(handler-case
(progn ,@body nil)
(condition () t)))
(defmacro warnedp (&body body)
`(handler-case
(progn ,@body nil)
(warning () t)))
(defmacro test (result &rest args)
(cond (result
`(assert (string= ,result
(with-output-to-string (*default-template-output*)
(fill-and-print-template ,@args)))))
(`(assert (failedp (fill-and-print-template ,@args))))))
(test "abc" "<!-- TMPL_VAR foo -->" '(:foo "abc"))
(test "abc" "<!-- tmpl_var foo -->" '(:foo "abc"))
(test "<!-- tmpl_vaar foo -->" "<!-- tmpl_vaar foo -->" '(:foo "abc"))
(test "xabcy" "x<!-- TMPL_VAR foo -->y" '(:foo "abc"))
(test "" "<!-- TMPL_VAR foo -->" nil)
(test "" "<!-- TMPL_VAR foo -->" '(foo "abc"))
(test "" "<!-- TMPL_VAR foo -->" '(:bar "abc"))
(test "abc" "<!-- TMPL_VAR 'foo' -->" '(:foo "abc"))
(test "abc" "<!-- TMPL_VAR \"foo\" -->" '(:foo "abc"))
(test nil "<!-- TMPL_VAR foo-->" '(:foo "abc"))
(test "" "<!-- TMPL_IF foo -->abc<!-- /TMPL_IF -->" nil)
(test "" "<!-- TMPL_IF foo -->abc<!-- /TMPL_IF -->" '(:foo nil))
(test "abc" "<!-- TMPL_IF foo -->abc<!-- /TMPL_IF -->" '(:foo t))
(test "abc" "<!-- TMPL_IF foo -->abc<!-- /TMPL_IF -->" '(:foo t :bar 42))
(test nil "<!-- TMPL_IF foo -->abc<!-- /TMPL_IF foo -->" nil)
(test nil "<!-- TMPL_IF -->abc<!-- /TMPL_IF -->" nil)
(test "def" "<!-- TMPL_IF foo -->abc<!-- TMPL_ELSE-->def<!-- /TMPL_IF -->" nil)
(test nil "<!-- TMPL_IF foo -->abc<!-- TMPL_ELSE-->def<!-- /TMPL_UNLESS -->" nil)
(test "def" "<!-- TMPL_IF foo -->abc<!-- TMPL_ELSE-->def<!-- /TMPL_IF -->" '(:foo nil))
(test "abc" "<!-- TMPL_IF foo -->abc<!-- TMPL_ELSE-->def<!-- /TMPL_IF -->" '(:foo t))
(test "abc" "<!-- TMPL_UNLESS foo -->abc<!-- TMPL_ELSE-->def<!-- /TMPL_UNLESS -->" '(:foo nil))
(test "def" "<!-- TMPL_UNLESS foo -->abc<!-- TMPL_ELSE-->def<!-- /TMPL_UNLESS -->" '(:foo t))
(test nil "<!-- TMPL_UNLESS foo -->abc<!-- TMPL_ELSE-->def<!-- /TMPL_IF -->" '(:foo t))
(test "abc" "<!-- TMPL_IF foo --><!-- TMPL_VAR foo --><!-- TMPL_ELSE-->def<!-- /TMPL_IF -->" '(:foo "abc"))
(test "def" "<!-- TMPL_IF foo --><!-- TMPL_VAR foo --><!-- TMPL_ELSE-->def<!-- /TMPL_IF -->" '(:foo nil))
(test "abcabcabc" "<!-- TMPL_IF foo --><!-- TMPL_VAR foo -->abc<!-- TMPL_VAR foo --><!-- TMPL_ELSE-->def<!-- /TMPL_IF -->" '(:foo "abc"))
(test "defdefdef" "<!-- TMPL_IF foo --><!-- TMPL_VAR foo -->abc<!-- TMPL_VAR foo --><!-- TMPL_ELSE--><!-- TMPL_VAR bar -->def<!-- TMPL_VAR bar --><!-- /TMPL_IF -->" '(:bar "def"))
(test "[]" "[<!-- TMPL_LOOP foo -->[x]<!-- /TMPL_LOOP -->]" '(:foo nil))
(test "[xxx]" "[<!-- TMPL_REPEAT foo -->x<!-- /TMPL_REPEAT -->]" '(:foo 3))
(test "[]" "[<!-- TMPL_REPEAT foo -->x<!-- /TMPL_REPEAT -->]" '(:foo 0))
(test "[]" "[<!-- TMPL_REPEAT foo -->x<!-- /TMPL_REPEAT -->]" '(:foo "foo"))
(test nil "[<!-- TMPL_REPEAT foo -->x<!-- /TMPL_LOOP -->]" '(:foo 3))
(test nil "[<!-- TMPL_LOOP foo -->x<!-- /TMPL_REPEAT -->]" '(:foo 3))
(test "[[x][x][x]]" "[<!-- TMPL_LOOP foo -->[x]<!-- /TMPL_LOOP -->]" '(:foo (1 2 3)))
(test "[[1][2][3]]" "[<!-- TMPL_LOOP foo -->[<!-- TMPL_VAR bar -->]<!-- /TMPL_LOOP -->]" '(:foo ((:bar "1") (:bar "2") (:bar "3"))))
(test "[[][][]]" "[<!-- TMPL_LOOP foo -->[<!-- TMPL_VAR bar -->]<!-- /TMPL_LOOP -->]" '(:foo (() () ())))
(test "[[1][2][3]]" "[<!-- TMPL_LOOP foo -->[<!-- TMPL_VAR bar -->]<!-- /TMPL_LOOP -->]" '(:foo ((:bar "1") (:bar "2") (:bar "3"))))
(test "[[1][][3]]" "[<!-- TMPL_LOOP foo -->[<!-- TMPL_VAR bar -->]<!-- /TMPL_LOOP -->]" '(:foo ((:bar "1") () (:bar "3"))))
(test "[[1][2][3]]" "[<!-- TMPL_LOOP foo -->[<!-- TMPL_IF 'bar' --><!-- TMPL_VAR bar --><!-- TMPL_ELSE-->2<!-- /TMPL_IF -->]<!-- /TMPL_LOOP -->]" '(:foo ((:bar "1") () (:bar "3"))))
(test "[[123][456][789]]" "[<!-- TMPL_LOOP 'foo' -->[<!-- TMPL_LOOP 'bar' --><!-- TMPL_VAR 'bar' --><!-- /TMPL_LOOP -->]<!-- /TMPL_LOOP -->]" '(:foo ((:bar ((:bar "1") (:bar "2") (:bar "3")))
(:bar ((:bar "4") (:bar "5") (:bar "6")))
(:bar ((:bar "7") (:bar "8") (:bar "9"))))))
(test "[[123][baz][789]]" "[<!-- TMPL_LOOP 'foo' -->[<!-- TMPL_IF baz --><!-- TMPL_LOOP 'baz' --><!-- TMPL_VAR 'bar' --><!-- /TMPL_LOOP --><!-- TMPL_ELSE -->baz<!-- /TMPL_IF -->]<!-- /TMPL_LOOP -->]" '(:foo ((:baz ((:bar "1") (:bar "2") (:bar "3")))
()
(:baz ((:bar "7") (:bar "8") (:bar "9"))))))
(test nil "<!-- TMPL_ELSE -->" nil)
(test "<!-- /TMPL_ELSE -->" "<!-- /TMPL_ELSE -->" nil)
(test nil "<!-- /TMPL_IF -->" nil)
(test nil "<!-- /TMPL_UNLESS -->" nil)
(test nil "<!-- /TMPL_LOOP -->" nil)
(test nil "<!-- TMPL_IF foo --><!-- TMPL_ELSE -->" nil)
(test nil "<!-- TMPL_UNLESS foo --><!-- TMPL_ELSE -->" nil)
(test nil "<!-- TMPL_LOOP foo --><!-- TMPL_ELSE -->" nil)
(test nil "<!-- TMPL_LOOP foo --><!-- TMPL_ELSE --><!-- /TMPL_LOOP -->" nil)
(test nil "<!-- TMPL_IF bar --><!-- TMPL_LOOP foo --><!-- TMPL_ELSE --><!-- /TMPL_LOOP -->" nil)
(test nil "<!-- TMPL_IF foo --><!-- TMPL_IF bar -->1<!-- TMPL_ELSE -->2<!-- /TMPL_IF --><!-- TMPL_ELSE --><!-- TMPL_IF baz -->3<!-- TMPL_ELSE -->4<!-- /TMPL_IF -->" nil)
(test "1" "<!-- TMPL_IF foo --><!-- TMPL_IF bar -->1<!-- TMPL_ELSE -->2<!-- /TMPL_IF --><!-- TMPL_ELSE --><!-- TMPL_IF baz -->3<!-- TMPL_ELSE -->4<!-- /TMPL_IF --><!-- /TMPL_IF -->" '(:foo t :bar t))
(test "2" "<!-- TMPL_IF foo --><!-- TMPL_IF bar -->1<!-- TMPL_ELSE -->2<!-- /TMPL_IF --><!-- TMPL_ELSE --><!-- TMPL_IF baz -->3<!-- TMPL_ELSE -->4<!-- /TMPL_IF --><!-- /TMPL_IF -->" '(:foo t :bar nil))
(test "3" "<!-- TMPL_IF foo --><!-- TMPL_IF bar -->1<!-- TMPL_ELSE -->2<!-- /TMPL_IF --><!-- TMPL_ELSE --><!-- TMPL_IF baz -->3<!-- TMPL_ELSE -->4<!-- /TMPL_IF --><!-- /TMPL_IF -->" '(:foo nil :baz t))
(test "4" "<!-- TMPL_IF foo --><!-- TMPL_IF bar -->1<!-- TMPL_ELSE -->2<!-- /TMPL_IF --><!-- TMPL_ELSE --><!-- TMPL_IF baz -->3<!-- TMPL_ELSE -->4<!-- /TMPL_IF --><!-- /TMPL_IF -->" '(:foo nil :baz nil))
(test "X" "<!-- TMPL_CALL foo -->" '(:foo (("X"))))
(test "QUUX" "<!-- TMPL_VAR baz --><!-- TMPL_CALL foo -->" '(:baz "Q"
:foo (("<!-- TMPL_VAR bar -->" :bar "U")
("<!-- TMPL_VAR bar -->X" :bar "U"))))
(test "" "<!-- TMPL_IF foo --><!-- TMPL_CALL bar --><!-- /TMPL_IF -->" '(:foo (("---"))))
(test nil "<!-- TMPL_CALL foo -->" '(:foo 57))
(let ((temp-name (make-pathname :name (format nil "template-test-~A" (random 1000000))
:defaults tmp-dir)))
(with-open-file (stream temp-name :direction :output :if-exists :error)
(write-string "<!-- TMPL_VAR foo -->" stream))
(let ((*warn-on-creation* nil))
(test "abc" temp-name '(:foo "abc")))
(with-open-file (stream temp-name :direction :input)
(test "def" stream '(:foo "def")))
(with-open-file (stream temp-name :direction :input)
(let ((tp (create-template-printer stream)))
(test "ghi" tp '(:foo "ghi"))))
(let ((tp (create-template-printer temp-name)))
(test "jkl" tp '(:foo "jkl")))
(let ((tp (create-template-printer "<!-- TMPL_VAR foo -->")))
(test "mno" tp '(:foo "mno")))
(delete-file temp-name)
;; sleep because of FILE-WRITE-DATE
(sleep 2)
(with-open-file (stream temp-name :direction :output :if-exists :error)
(write-string "<!-- TMPL_VAR bar -->" stream))
(assert (warnedp (create-template-printer temp-name)))
(assert (not (warnedp (create-template-printer temp-name))))
(assert (warnedp (create-template-printer temp-name :force t)))
(delete-from-template-cache temp-name)
(assert (warnedp (create-template-printer temp-name)))
(clear-template-cache)
(assert (warnedp (create-template-printer temp-name)))
(delete-file temp-name))
(let ((*template-start-marker* "<")
(*template-end-marker* ">"))
(test "The quick <brown> fox" "The <TMPL_VAR 'speed'> <brown> fox"
'(:speed "quick")))
(let* ((random-string (format nil "template-test-~A" (random 1000000)))
(temp-name (merge-pathnames random-string tmp-dir))
(*default-template-pathname* tmp-dir))
(with-open-file (stream temp-name :direction :output :if-exists :error)
(write-string "The <!-- TMPL_VAR speed --> brown fox" stream))
(let ((*warn-on-creation* nil))
(test "The very fast brown fox"
(make-pathname :name random-string)
'(:speed "very fast")))
(delete-file temp-name)
;; sleep because of FILE-WRITE-DATE
(sleep 2)
(with-open-file (stream temp-name :direction :output :if-exists :error)
(write-string "The <!-- TMPL_VAR speed --> brown fox" stream))
(let ((*warn-on-creation* nil))
(test "The very fast brown fox"
(format nil "<!-- TMPL_INCLUDE '~A' -->" random-string)
'(:speed "very fast")))
(delete-file temp-name))
(let* ((random-string (format nil "template-test-~A" (random 1000000)))
(temp-name (merge-pathnames random-string tmp-dir))
(random-string-2 (format nil "template-test-2-~A" (random 1000000)))
(temp-name-2 (merge-pathnames random-string-2 tmp-dir))
(*default-template-pathname* tmp-dir))
(with-open-file (stream temp-name :direction :output :if-exists :error)
(format stream "<!-- TMPL_INCLUDE '~A' -->" random-string-2))
(with-open-file (stream temp-name-2 :direction :output :if-exists :error)
(format stream "<!-- TMPL_INCLUDE '~A' -->" random-string))
(test nil (format nil "<!-- TMPL_INCLUDE '~A' -->" random-string) nil)
(delete-file temp-name)
(delete-file temp-name-2))
(assert (string= "The slow brown fox"
(with-output-to-string (stream)
(let ((*default-template-output* stream))
(fill-and-print-template "The <!-- TMPL_VAR speed --> brown fox"
'(:speed "slow"))))))
(let* ((tp (create-template-printer "The <!-- TMPL_VAR speed --> brown fox"))
(*convert-nil-to-empty-string* nil))
(with-output-to-string (*default-template-output*)
(test nil tp '(:foo "bar"))))
(let ((tp (create-template-printer "The <!-- TMPL_VAR speed --> brown fox")))
(handler-bind
((template-missing-value-error (lambda (condition)
(declare (ignore condition))
(use-value "slow"))))
(let ((*convert-nil-to-empty-string* nil))
(test "The slow brown fox" tp '(:foo "bar")))))
(let ((*sequences-are-lists* nil))
(test "[1][2][3]"
"<!-- TMPL_LOOP vector -->[<!-- TMPL_VAR item -->]<!-- /TMPL_LOOP -->"
'(:vector #((:item "1")
(:item "2")
(:item "3"))))
(test "QUUX" "<!-- TMPL_VAR baz --><!-- TMPL_CALL foo -->"
'(:baz "Q"
:foo #(("<!-- TMPL_VAR bar -->" :bar "U")
("<!-- TMPL_VAR bar -->X" :bar "U")))))
(let ((*upcase-attribute-strings* nil))
(test "The slow brown fox"
"The <!-- TMPL_VAR speed --> brown fox"
'(:speed "quick" :|speed| "slow")))
(let ((*template-symbol-package* *package*))
(test "The slow brown fox"
"The <!-- TMPL_VAR speed --> brown fox"
'(:speed "quick" speed "slow")))
(let ((tp (create-template-printer "The <!-- TMPL_VAR speed --> brown fox"))
(*value-access-function* #'gethash)
(hash (make-hash-table :test #'eq)))
(setf (gethash :speed hash) "fast")
(test "The fast brown fox" tp hash))
(let ((values (list :row-loop
(loop for row in '((1 2 3 4) (2 3 4 5) (3 4 5 6))
collect (list :col-loop
(loop for col in row
collect (list :item
(format nil "~A" col)))))))
(template "<table>
<!-- TMPL_LOOP row-loop -->
<tr>
<!-- TMPL_LOOP col-loop -->
<td><!-- TMPL_VAR item --></td>
<!-- /TMPL_LOOP -->
</tr>
<!-- /TMPL_LOOP -->
</table>")
(result "<table>
<tr>
<td>1</td>
<td>2</td>
<td>3</td>
<td>4</td>
</tr>
<tr>
<td>2</td>
<td>3</td>
<td>4</td>
<td>5</td>
</tr>
<tr>
<td>3</td>
<td>4</td>
<td>5</td>
<td>6</td>
</tr>
</table>")
(*ignore-empty-lines* t))
(test result template values))
(let ((tp (create-template-printer "A square has <!-- TMPL_VAR number --> corners"))
(*format-non-strings* nil))
(handler-bind
((template-not-a-string-error (lambda (condition)
(use-value
(format nil "~R"
(template-not-a-string-error-value condition))))))
(test "A square has four corners" tp '(:number 4))))
(format t "~&All tests passed...")

342
sbcl/.quicklisp/dists/quicklisp/software/html-template-20171227-git/util.lisp Normal file
View file

@ -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 "&lt;" s))
((#\>)
(write-sequence "&gt;" s))
((#\&)
(write-sequence "&amp;" s))
((#\')
(write-sequence "&#039;" s))
((#\")
(write-sequence "&quot;" 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)))))