;;; -*- 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) "") ((:repeat) "") ((:if :if-else) "") ((:unless :unless-else) "")))) ;; 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)))