160 lines
7.5 KiB
Common Lisp
160 lines
7.5 KiB
Common Lisp
;;; -*- 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*))
|