;;; -*- Mode: Lisp -*-
;;;
;;; $Header: /home/gene/library/website/docsrc/lht/RCS/lht.lisp,v 395.1 2008/04/20 17:25:47 gene Exp $
;;;
;;; Copyright (C) 2004  Gene Michael Stover.  All rights reserved.
;;; 
;;; This library is free software; you can redistribute it
;;; and/or modify it under the terms of version 2.1 of the GNU
;;; Lesser General Public License as published by the Free
;;; Software Foundation.
;;; 
;;; This library is distributed in the hope that it will be
;;; useful, but WITHOUT ANY WARRANTY; without even the implied
;;; warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
;;; PURPOSE.  See the GNU Lesser General Public License for more
;;; details.
;;; 
;;; You should have received a copy of the GNU Lesser General
;;; Public License along with this library; if not, write to the
;;; Free Software Foundation, Inc., 59 Temple Place, Suite 330,
;;; Boston, MA 02111-1307 USA
;;;

(defun slurp-stream-simple (strm)
  "Return a string containing the entire
contents of the stream."
  (let ((str (make-array 1024
                         :element-type 'character
                         :adjustable t
                         :fill-pointer 0)))
    (do ((ch (read-char strm nil strm)
	     (read-char strm nil strm)))
	((eq ch strm) str)
	(vector-push-extend ch str))))

(defun slurp-file-simple (pn)
  "Return a string containing the entire
contents of the file identified by the
pathname PN."
  (with-open-file (strm pn)
		  (slurp-stream-simple strm)))

(defconstant *newline-string* (format nil "~%"))

(defun xread-line (strm)
  "Returns a string containing the next line in the file
with the end-of-line character(s).  On end-of-file,
returns STRM."
  (let ((x (read-line strm nil strm)))
    (cond ((eq x strm) x)
          (t (concatenate 'string x *newline-string*)))))

(defun strcatlst (lst)
  "Concatenate the strings in a list of strings.  Return a
new string.  Neither the list nor the strings in it are
modified.  A more clever name for this function would have
been STRING-REDUCE."
  (reduce #'(lambda (x y) (concatenate 'string x y)) lst))

(defun slurp-stream-faster (strm)
  "Slurp the contents of the stream.  Return them in a
string.  This turned out to be slower than the 'simple'
version."
  (do ((lst () (cons line lst))
       (line (xread-line strm) (xread-line strm)))
      ((eq line strm)
       ;; I tried apply #'concatenate 'string blah blah, but got a
       ;; stack overflow in clisp.  So I wrote a function to do the
       ;; concatenation.
       (strcatlst (nreverse lst)))))

(defun slurp-file-faster (pn)
  "This turned out to be slower than the 'simple' version."
  (with-open-file (strm pn)
    (slurp-stream-faster strm)))

(defun slurp-file (pn)
  "Return a string containing the entire contents of the file 
identified by the pathname PN."
  (slurp-file-simple pn))

(defun string-replace-all-simple (old new big)
  "Replace all occurences of OLD string with NEW string in BIG string."
  (do ((oldlen (length old))
       (i (search old big) (search old big)))
      ((null i) big)
      (setq big
            (concatenate 'string
              (subseq big 0 i)
              new
              (subseq big (+ i oldlen))))))

(defun string-replace-all-faster (old new big)
  "Replace all occurences of OLD string with NEW
string in BIG string."
  (do ((newlen (length new))
       (oldlen (length old))
       (i (search old big)
          (search old big :start2 (+ i newlen))))
      ((null i) big)
      (setq big
            (concatenate 'string
              (subseq big 0 i)
              new
              (subseq big (+ i oldlen))))))

(defun string-replace-all (old new big)
  (string-replace-all-faster old new big))

;; (defun convert-template (template)
;;   "Evaluates to a closure that evaluates the
;; HTML template.  The template is a string containing
;; HTML & embedded Lisp.
;;   This function uses EVAL, which usually indicates
;; it should be a macro, but even as a macro, I
;; couldn't figure out how to make it work except when
;; the template is a string constant.  I hesitatingly
;; suggest that convert-template must be a function
;; thta uses EVAL."
;;   (eval
;;    (first
;;     (multiple-value-list
;;      (read-from-string
;;       (let ((form (concatenate
;;        'string
;;        "#'(lambda (strm) (princ \""
;;        (string-replace-all
;; 	"<lisp>"
;; 	"\" strm) "
;; 	(string-replace-all
;; 	 "</lisp>"
;; 	 " (princ \""
;; 	 (string-replace-all "\"" "\\\"" template)))
;;        "\" strm) strm)")))
;; 	(format t "~&form is ~S" form)
;; 	form))))))

(defun split-template-into-pairs (template)
  (let* ((lisp-tag "<lisp>")
	 (lisp-len (length lisp-tag))
	 (slash-tag "</lisp>")
	 (slash-len (length slash-tag)))
    (do ((s                           0                       (+ j slash-len))
	 (i (search  lisp-tag template)
	    (search  lisp-tag template :start2 (+ j slash-len)))
	 (j (search slash-tag template)
	    (search slash-tag template :start2 (+ j slash-len)))
	 (lst () (cons
		  (cons (subseq template s i)
			(subseq template (+ i lisp-len) j))
		  lst)))
	((null i) (nreverse
		   (cons (cons (subseq template s) "")
			 lst))))))

(defun convert-template (template)
  "Evaluates to a closure that evaluates the
HTML template.  The template is a string containing
HTML & embedded Lisp.
  This function uses EVAL, which usually indicates
it should be a macro, but even as a macro, I
couldn't figure out how to make it work except when
the template is a string constant.  I hesitatingly
suggest that convert-template must be a function
thta uses EVAL."
  ;; Convert the contents of the template string.
  ;; Sections outside of <lisp></lisp> must have
  ;; their double-quote characters escaped.  Within
  ;; <lisp></lisp> must remain unchanged.
  (eval
   (first
    (multiple-value-list
     (read-from-string
      (strcatlst
       (cons "#'(lambda (strm) "
	     (append 
	      (mapcar
	       #'(lambda (pr)
		   ;; CAR of PR is an HTML string.  It's double-quote
		   ;; characters must be escaped.
		   ;; CDR of PR is embedded Lisp in a string.  Must not
		   ;; be changed.  CDR migt be empty (NIL).
		   (format nil "~%(princ ~S)~%~A" (car pr) (cdr pr)))
	       (split-template-into-pairs template))
	      (list "strm)")))))))))

(defmacro call-template (template &optional (strm t))
  "Evaluate the HTML template.  The template is a string
containing HTML & embedded Lisp.  STRM is a stream to
which the template's output should be sent.  It must be
a stream or T, which is a synonym for standard output.
STRM defaults to T."
  `(funcall (convert-template ,template)
	    (if (eq ,strm t)
		*standard-output*
	      ,strm)))

(defun load-template (pn &optional (strm t))
  "Call an HTML template that is in a file.  PN is the
pathname of the file."
  (call-template (slurp-file pn) strm))

(defun time-fn (fn &optional (count 1))
  (let ((start (get-internal-real-time))
	end tick second)
    (loop for i from 1 to count do (funcall fn))
    (setq end (get-internal-real-time)
	  tick (- end start)
	  second (/ tick 1.0 internal-time-units-per-second count))
    second))

(defun timetable (lst-pairs &optional (count 1))
  (format t "~:{~&~2D  ~10A  ~,2E~}"
	  (let ((i 0))
	    (mapcar #'(lambda (pr)
			(list (incf i)
			      (if (consp pr)
				  (cdr pr)
				"")
			      (time-fn (if (consp pr)
					  (car pr)
					pr)
				      count)))
		    lst-pairs))))

;;; --- end of file ---