;;; -*- 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*))
