;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -*- 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 2003/01/09 22:37:38 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*
'((#\< . "<")
(#\> . ">")
(#\& . "&")))
(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)))))
||#