htout.lisp Unix DownloadWindows Download
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -*- Mode: Lisp -*- ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; File		     - htout.lisp
;; Description	     - trivial HTML output
;; Author	     - Tim Bradshaw (tfb at KINGSTON)
;; Created On	     - Fri May 12 05:51:11 2000
;; Last Modified On  - Tue Apr 24 18:55:22 2001
;; Last Modified By  - Tim Bradshaw (tfb at KINGSTON)
;; Update Count	     - 40
;; Status	     - Unknown
;; 
;; $Id: htout.lisp,v 1.1.1.1 2002/12/12 02:15:47 colin Exp $
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;;; Trivial HTML output.
;;;
;;; htout.lisp is copyright 1999-2000 by me, Tim Bradshaw, and may
;;; be used for any purpose whatsoever by anyone. It has no warranty
;;; whatsoever. I would appreciate acknowledgement if you use it in
;;; anger, and I would also very much appreciate any feedback or bug
;;; fixes.
;;;
;;; The latest version of this program is available from
;;; http://www.tfeb.org/lisp/hax.html
;;;
;;; This is fragile, but the right idea.
;;;
;;; the trick of distinguishing HTML elt names by begin keywords might
;;; want to be generalised somewhat (but it's a reasonable approach I
;;; think). It could obviously be infinitely generalised to XML but I
;;; don't want to bother with that.
;;;
;;; the listification of tags with attributes to get evaluation is a bit
;;; fragile -- ((:a href "foo") ...) breaks -- do we care?
;;;
;;; it might be cool to define compiler macros for some things to inline 
;;; more code?
;;;
;;; I'm not sure about all these shorthands.
;;;

(defpackage :htout
  (:use :cl)
  (:export #:with-html-output		;basic macro, and shorthands:
	   #:htm			;reenter html mode
	   #:fmt			;format in html
	   #:esc			;escaped string
	   #:lfd			;linefeed in html
	   #:escape-string		;implement ESC, useful in itself
	   #:define-empty-tags))	;define a tag to have no content

(in-package :htout)

(defmacro with-html-output ((var &optional stream) &body html)
  ;; Generate HTML
  (let ((%constant-html-p% t))
    ;; This should probably use some variant on my dynamic state
    ;; access macro rather than explicit special declarations.
    (declare (special %constant-html-p%))
     (let ((expansion
	   `(let ((,var ,(or stream var)))
	      (macrolet ((htm (&body forms)
			   `(with-html-output (,',var) ,@forms))
			 (fmt (format-string &rest args)
			   `(format ,',var ,format-string ,@args))
			 (lfd (&optional (n 1))
			   (if (= n 1)
			       `(terpri ,',var)
			       `(loop repeat ,n
				    do
				      (terpri ,',var))))
			 (esc (string &optional map)
			   (let ((mname (make-symbol "MAP")))
			     `(let ((,mname ,map))
				(write-sequence 
				 (if ,mname
				     (escape-string ,string ,mname)
				     (escape-string ,string))
				 ,',var)))))
		,@(mapcar #'(lambda (f) (htmlify-form f var))
			  html)))))
      (if %constant-html-p%
	  `(let ((,var ,(or stream var)))
	     (write-sequence ,(eval `(with-output-to-string (,var)
				       ,expansion))
			     ,var)
	     ;; non-constant expansion returns NIL
	     nil)
	  expansion))))

(defvar *empty-table* 
    (make-hash-table))

(defun empty-tag-p (tag)
  (values (gethash tag *empty-table*)))

(defmacro define-empty-tags (&rest tags)
  `(loop for tag in ',tags
       do (setf (gethash tag *empty-table*) tag)
       finally (return ',tags)))

(define-empty-tags :br :hr)
  
(defgeneric htmlify-form (form stream-var)
  ;; Take a listy representation of HTML and produce code to write
  ;; into STREAM-VAR.  Methods on this GF should set the special
  ;; variable %CONSTANT-HTML-P% to NIL if they encounter possibly
  ;; non-compile-time-constant expressions.
  )

(defmethod htmlify-form ((form cons) stream-var)
  (let ((elt (first form)))
    (if (or (keywordp elt)
	    (and (consp elt)
		 (keywordp (first elt))))
	(let ((tag (if (consp elt) (first elt) elt))
	      (eltexpr (if (consp elt) `(list ,@elt) `(quote ,elt))))
	  (when (consp elt)
	    ;; if ELT is a cons then it may contain variables, as in
	    ;; ((:table :width n)), so try to hack that.
	    (unless (every #'constantp elt)
	      (locally
		  (declare (special %constant-html-p%))
		(setf %constant-html-p% nil))))
	  (if (empty-tag-p tag)
	      (progn 
		(when (rest form)
		  (warn "Ignoring body of empty tag ~S" tag))
		`(emit-tag ,eltexpr ,stream-var :type :empty))
	      `(progn
		 (emit-tag ,eltexpr ,stream-var :type :open)
		 ,@(mapcar #'(lambda (e) (htmlify-form e stream-var))
			   (rest form))
		 (emit-tag ',tag ,stream-var :type :close))))
	(locally
	    (declare (special %constant-html-p%))
	  (setf %constant-html-p% nil)
	  form))))

(defmethod htmlify-form ((form symbol) stream-var)
  (if (keywordp form)
      `(emit-tag ',form ,stream-var :type :empty)
      (locally
	  (declare (special %constant-html-p%))
	(setf %constant-html-p% nil)
	`(princ ,form ,stream-var))))

(defmethod htmlify-form ((form string) stream-var)
  `(write-sequence ,form ,stream-var))

(defmethod htmlify-form ((form character) stream-var)
  `(write-char ,form ,stream-var))

(defgeneric emit-tag (tag stream &key type))

(defmethod emit-tag ((tag symbol) stream &key (type ':open))
  (format stream (ecase type
		   ((:open :empty) "<~A>")
		   ((:close) "</~A>"))
	  (symbol-name tag)))

(defmethod emit-tag ((tag list) stream &key (type ':open))
  (ecase type
    ((:open :empty)
     (format stream "<~A" (symbol-name (first tag)))
     (loop for tail = (rest tag) then (cddr tail)
	 while tail
	 do
	   (if (second tail)
	       (format stream " ~A='~A'" 
		       (symbol-name (first tail))
		       (second tail))
	       (format stream " ~A" (symbol-name (first tail)))))
     (format stream ">"))
    ((:close)
     (format stream "</~A>" (symbol-name (first tag))))))


(defvar *html-escape-map*
    '((#\< . "&lt;")
      (#\> . "&gt;")
      (#\& . "&amp;")))

(defun escape-string (string &optional (map *html-escape-map*))
  ;; escape the characters in MAP in STRING.  This is an easy way of
  ;; doing it but I haven't thought abut making it efficient.
  (declare (type string string))
  (if (not (find-if #'(lambda (c)
			(assoc c map))
		    string))
      string
      (with-output-to-string (o)
	(loop for prev = 0 then (1+ found)
	    for found = (position-if #'(lambda (c)
					 (assoc c map))
				     string
				     :start prev)
	    while found
	    do
	      (write-sequence string o :start prev :end found)
	      (write-sequence (cdr (assoc (char string found) map)) o)
	    finally
	      (write-sequence string o :start prev :end (length string))))))


#||
(defun count-numbers (n w &optional (s *standard-output*))
  (with-html-output (s)
    (:html
     (:head (:title 
	     (fmt "Numbers from zero below ~R" n)))
     (:body
      (:h1  (fmt "Numbers from zero below ~R" n))
      ;; Forms beginning with non-keyword symbols are code to be evaluated.
      (lfd)
      (:p "Table border width "
	  (princ w s))
      ;; isolated keywords are empty tags.
      :br
      (lfd)
      ;; empty tags with attributes need this slightly crufty syntax, 
      ;; and also need to be defined as empty. 
      ((:hr :noshade))
      (:center
       ;; the values of atttributes are evaluated (in fact the whole 
       ;; attribute list is, but attribute names asre keywords).
       ((:table :border w
		:width "90%")
	(:tbody				;html 4, bah.
	 (:tr
	  ((:th :align :left) "English")
	  ((:th :align :right) "Arabic")
	  ((:th :align :right) "Roman"))
	 ;; you can leap into Lisp...
	 (dotimes (i n)
	   (let ((c (if (evenp i) "blue" "white")))
	     ;; ... and then back into HTML: the local HTML macro is shorthand
	     ;; for WITH-HTML-OUTPUT to the same stream.
	     (htm
	      ((:tr :bgcolor c)
	       ((:td :align :left)
		(fmt "~R" i))
	       ((:td :align :right)
		(fmt "~D" i))
	       ((:td :align :right)
		(if (zerop i)
		    (fmt "")
		    (fmt "~:@R" i))))
	      (lfd)))))))
       ((:hr :noshade))))))

(defun create-blank-page (s title)
  (with-html-output (s)
    (:html
     (:head
      (:title (esc title))
      (lfd))
     (:body
      (:h1 (esc title))
      (lfd)
      "<!-- Body here -->"
      (lfd)))))
||#