;; -*- mode: common-lisp; package: lml2 -*-
;;
;; $Id: htmlgen.lisp,v 1.2 2003/06/23 20:08:06 kevin Exp $
;;
;; copyright (c) 1986-2000 Franz Inc, Berkeley, CA
;; copyright (c) 2003 Kevin Rosenberg
;;
;; Main changes from Allegro version:
;; - Support XHTML
;; - lowercase symbol names
;;
;; This code is free software; you can redistribute it and/or
;; modify it under the terms of the version 2.1 of
;; the GNU Lesser General Public License as published by
;; the Free Software Foundation, as clarified by the AllegroServe
;; prequel found in license-allegroserve.txt.
(in-package #:lml2)
;; html generation
(defstruct (html-process (:type list) (:constructor
make-html-process (key has-inverse
macro special
print
name-attr
)))
key ; keyword naming this tag
has-inverse ; t if the / form is used
macro ; the macro to define this
special ; if true then call this to process the keyword and return
; the macroexpansion
print ; function used to handle this in html-print
name-attr ; attribute symbols which can name this object for subst purposes
)
(defparameter *html-process-table*
(make-hash-table :test #'equal) ; #'eq is accurate but want to avoid rehashes
)
(defmacro html (&rest forms &environment env)
;; just emit html to the current stream
(process-html-forms forms env))
(defmacro html-out-stream-check (stream)
;; ensure that a real stream is passed to this function
`(let ((.str. ,stream))
(if* (not (streamp .str.))
then (error "html-stream must be passed a stream object, not ~s"
.str.))
.str.))
(defmacro html-stream (stream &rest forms)
;; set output stream and emit html
`(let ((*html-stream* (html-out-stream-check ,stream))) (html ,@forms)))
(defun process-html-forms (forms env)
(let (res)
(flet ((do-ent (ent args argsp body)
;; ent is an html-process object associated with the
;; html tag we're processing
;; args is the list of values after the tag in the form
;; ((:tag &rest args) ....)
;; argsp is true if this isn't a singleton tag (i.e. it has
;; a body) .. (:tag ...) or ((:tag ...) ...)
;; body is the body if any of the form
;;
(let (spec)
(if* (setq spec (html-process-special ent))
then ; do something different
(push (funcall spec ent args argsp body) res)
elseif (null argsp)
then ; singleton tag, just do the set
(push `(,(html-process-macro ent) :set) res)
nil
else (if* (equal args '(:unset))
then ; ((:tag :unset)) is a special case.
; that allows us to close off singleton tags
; printed earlier.
(push `(,(html-process-macro ent) :unset) res)
nil
else ; some args
(push `(,(html-process-macro ent) ,args
,(process-html-forms body env))
res)
nil)))))
(do* ((xforms forms (cdr xforms))
(form (car xforms) (car xforms)))
((null xforms))
(setq form (macroexpand form env))
(if* (atom form)
then (if* (keywordp form)
then (let ((ent (gethash form *html-process-table*)))
(if* (null ent)
then (error "unknown html keyword ~s"
form)
else (do-ent ent nil nil nil)))
elseif (stringp form)
then ; turn into a print of it
(push `(write-string ,form *html-stream*) res)
else (push form res))
else (let ((first (car form)))
(if* (keywordp first)
then ; (:xxx . body) form
(let ((ent (gethash first
*html-process-table*)))
(if* (null ent)
then (error "unknown html keyword ~s"
form)
else (do-ent ent nil t (cdr form))))
elseif (and (consp first) (keywordp (car first)))
then ; ((:xxx args ) . body)
(let ((ent (gethash (car first)
*html-process-table*)))
(if* (null ent)
then (error "unknown html keyword ~s"
form)
else (do-ent ent (cdr first) t (cdr form))))
else (push form res))))))
`(progn ,@(nreverse res))))
(defun html-atom-check (args open close body)
(if* (and args (atom args))
then (let ((ans (case args
(:set `(write-string ,open *html-stream*))
(:unset `(write-string ,close *html-stream*))
(t (error "illegal arg ~s to ~s" args open)))))
(if* (and ans body)
then (error "can't have a body form with this arg: ~s"
args)
else ans))))
(defun html-body-form (open close body)
;; used when args don't matter
`(progn (write-string ,open *html-stream*)
,@body
(write-string ,close *html-stream*)))
(defun html-body-key-form (string-code has-inv args body)
;; do what's needed to handle given keywords in the args
;; then do the body
(if* (and args (atom args))
then ; single arg
(return-from html-body-key-form
(case args
(:set (if* has-inv
then `(write-string ,(format nil "<~a>" string-code)
*html-stream*)
else `(write-string ,(format nil "<~a />" string-code)
*html-stream*)))
(:unset (if* has-inv
then `(write-string ,(format nil "" string-code)
*html-stream*)))
(t (error "illegal arg ~s to ~s" args string-code)))))
(if* (not (evenp (length args)))
then (warn "arg list ~s isn't even" args))
(if* args
then `(progn (write-string ,(format nil "<~a" string-code)
*html-stream*)
,@(do ((xx args (cddr xx))
(res))
((null xx)
(nreverse res))
(if* (eq :if* (car xx))
then ; insert following conditionally
(push `(if* ,(cadr xx)
then (write-string
,(format nil " ~(~a~)" (caddr xx))
*html-stream*)
(prin1-safe-http-string ,(cadddr xx)))
res)
(pop xx) (pop xx)
else
(push `(write-string
,(format nil " ~(~a~)" (car xx))
*html-stream*)
res)
(push `(prin1-safe-http-string ,(cadr xx)) res)))
,(unless has-inv `(write-string " /" *html-stream*))
(write-string ">" *html-stream*)
,@body
,(if* (and body has-inv)
then `(write-string ,(format nil "" string-code)
*html-stream*)))
else
(if* has-inv
then
`(progn (write-string ,(format nil "<~a>" string-code)
*html-stream*)
,@body
,(if* body
then `(write-string ,(format nil "" string-code)
*html-stream*)))
else
`(progn (write-string ,(format nil "<~a />" string-code)
*html-stream*)))))
(defun princ-http (val)
;; print the given value to the http stream using ~a
(format *html-stream* "~a" val))
(defun prin1-http (val)
;; print the given value to the http stream using ~s
(format *html-stream* "~s" val))
(defun princ-safe-http (val)
(emit-safe *html-stream* (format nil "~a" val)))
(defun prin1-safe-http (val)
(emit-safe *html-stream* (format nil "~s" val)))
(defun prin1-safe-http-string (val)
;; used only in a parameter value situation
;;
;; if the parameter value is the symbol with the empty print name
;; then turn this into a singleton object. Thus || is differnent
;; than "".
;;
;; print the contents inside a string double quotes (which should
;; not be turned into "'s
;; symbols are turned into their name
(if* (and (symbolp val)
(equal "" (symbol-name val)))
thenret ; do nothing
else (write-char #\= *html-stream*)
(if* (or (stringp val)
(and (symbolp val)
(setq val (string-downcase
(symbol-name val)))))
then (write-char #\" *html-stream*)
(emit-safe *html-stream* val)
(write-char #\" *html-stream*)
else (prin1-safe-http val))))
(defun emit-safe (stream string)
;; send the string to the http response stream watching out for
;; special html characters and encoding them appropriately
(do* ((i 0 (1+ i))
(start i)
(end (length string)))
((>= i end)
(if* (< start i)
then (write-sequence string
stream
:start start
:end i)))
(let ((ch (schar string i))
(cvt ))
(if* (eql ch #\<)
then (setq cvt "<")
elseif (eq ch #\>)
then (setq cvt ">")
elseif (eq ch #\&)
then (setq cvt "&")
elseif (eq ch #\")
then (setq cvt """))
(if* cvt
then ; must do a conversion, emit previous chars first
(if* (< start i)
then (write-sequence string
stream
:start start
:end i))
(write-string cvt stream)
(setq start (1+ i))))))
(defun html-print-list (list-of-forms stream &key unknown)
;; html print a list of forms
(dolist (x list-of-forms)
(html-print-subst x nil stream unknown)))
(defun html-print-list-subst (list-of-forms subst stream &key unknown)
;; html print a list of forms
(dolist (x list-of-forms)
(html-print-subst x subst stream unknown)))
(defun html-print (form stream &key unknown)
(html-print-subst form nil stream unknown))
(defun html-print-subst (form subst stream unknown)
;; Print the given lhtml form to the given stream
(assert (streamp stream))
(let* ((attrs)
(attr-name)
(name)
(possible-kwd (if* (atom form)
then form
elseif (consp (car form))
then (setq attrs (cdar form))
(caar form)
else (car form)))
print-handler
ent)
(if* (keywordp possible-kwd)
then (if* (null (setq ent (gethash possible-kwd *html-process-table*)))
then (if* unknown
then (return-from html-print-subst
(funcall unknown form stream))
else (error "unknown html tag: ~s" possible-kwd))
else ; see if we should subst
(if* (and subst
attrs
(setq attr-name (html-process-name-attr ent))
(setq name (getf attrs attr-name))
(setq attrs (html-find-value name subst)))
then
(return-from html-print-subst
(if* (functionp (cdr attrs))
then
(funcall (cdr attrs) stream)
else (html-print-subst
(cdr attrs)
subst
stream
unknown)))))
(setq print-handler
(html-process-print ent)))
(if* (atom form)
then (if* (keywordp form)
then (funcall print-handler ent :set nil nil nil nil stream)
elseif (stringp form)
then (write-string form stream)
else (princ form stream))
elseif ent
then (funcall print-handler
ent
:full
(if* (consp (car form)) then (cdr (car form)))
form
subst
unknown
stream)
else (error "Illegal form: ~s" form))))
(defun html-find-value (key subst)
; find the (key . value) object in the subst list.
; A subst list is an assoc list ((key . value) ....)
; but instead of a (key . value) cons you may have an assoc list
;
(let ((to-process nil)
(alist subst))
(loop
(do* ((entlist alist (cdr entlist))
(ent (car entlist) (car entlist)))
((null entlist) (setq alist nil))
(if* (consp (car ent))
then ; this is another alist
(if* (cdr entlist)
then (push (cdr entlist) to-process))
(setq alist ent)
(return) ; exit do*
elseif (equal key (car ent))
then (return-from html-find-value ent)))
(if* (null alist)
then ; we need to find a new alist to process
(if* to-process
then (setq alist (pop to-process))
else (return))))))
(defun html-standard-print (ent cmd args form subst unknown stream)
;; the print handler for the normal html operators
(ecase cmd
(:set ; just turn it on
(format stream "<~a>" (html-process-key ent)))
(:full ; set, do body and then unset
(let (iter)
(if* args
then (if* (and (setq iter (getf args :iter))
(setq iter (html-find-value iter subst)))
then ; remove the iter and pre
(setq args (copy-list args))
(remf args :iter)
(funcall (cdr iter)
(cons (cons (caar form)
args)
(cdr form))
subst
stream)
(return-from html-standard-print)
else
(format stream "<~a" (html-process-key ent))
(do ((xx args (cddr xx)))
((null xx))
; assume that the arg is already escaped
; since we read it
; from the parser
(format stream " ~a=\"~a\"" (car xx) (cadr xx)))
(format stream ">"))
else (format stream "<~a>" (html-process-key ent)))
(dolist (ff (cdr form))
(html-print-subst ff subst stream unknown)))
(if* (html-process-has-inverse ent)
then ; end the form
(format stream "" (html-process-key ent))))))
;; -- defining how html tags are handled. --
;;
;; most tags are handled in a standard way and the def-std-html
;; macro is used to define such tags
;;
;; Some tags need special treatment and def-special-html defines
;; how these are handled. The tags requiring special treatment
;; are the pseudo tags we added to control operations
;; in the html generator.
;;
;;
;; tags can be found in three ways:
;; :br - singleton, no attributes, no body
;; (:b "foo") - no attributes but with a body
;; ((:a href="foo") "balh") - attributes and body
;;
(defmacro def-special-html (kwd fcn print-fcn)
;; kwd - the tag we're defining behavior for.
;; fcn - function to compute the macroexpansion of a use of this
;; tag. args to fcn are:
;; ent - html-process object holding info on this tag
;; args - list of attribute-values following tag
;; argsp - true if there is a body in this use of the tag
;; body - list of body forms.
;; print-fcn - function to print an lhtml form with this tag
;; args to fcn are:
;; ent - html-process object holding info on this tag
;; cmd - one of :set, :unset, :full
;; args - list of attribute-value pairs
;; subst - subsitution list
;; unknown - function to call for unknown tags
;; stream - stream to write to
;;
`(setf (gethash ,kwd *html-process-table*)
(make-html-process ,kwd nil nil ,fcn ,print-fcn nil)))
(defmacro named-function (name &body body)
(declare (ignore name))
`(function ,@body))
(def-special-html :newline
(named-function html-newline-function
(lambda (ent args argsp body)
(declare (ignore ent args argsp))
(if* body
then (error "can't have a body with :newline -- body is ~s" body))
`(terpri *html-stream*)))
(named-function html-newline-print-function
(lambda (ent cmd args form subst unknown stream)
(declare (ignore args ent unknown subst))
(if* (eq cmd :set)
then (terpri stream)
else (error ":newline in an illegal place: ~s" form)))))
(def-special-html :princ
(named-function html-princ-function
(lambda (ent args argsp body)
(declare (ignore ent args argsp))
`(progn ,@(mapcar #'(lambda (bod)
`(princ-http ,bod))
body))))
(named-function html-princ-print-function
(lambda (ent cmd args form subst unknown stream)
(declare (ignore args ent unknown subst))
(assert (eql 2 (length form)))
(if* (eq cmd :full)
then (format stream "~a" (cadr form))
else (error ":princ must be given an argument")))))
(def-special-html :princ-safe
(named-function html-princ-safe-function
(lambda (ent args argsp body)
(declare (ignore ent args argsp))
`(progn ,@(mapcar #'(lambda (bod)
`(princ-safe-http ,bod))
body))))
(named-function html-princ-safe-print-function
(lambda (ent cmd args form subst unknown stream)
(declare (ignore args ent unknown subst))
(assert (eql 2 (length form)))
(if* (eq cmd :full)
then (emit-safe stream (format nil "~a" (cadr form)))
else (error ":princ-safe must be given an argument")))))
(def-special-html :prin1
(named-function html-prin1-function
(lambda (ent args argsp body)
(declare (ignore ent args argsp))
`(progn ,@(mapcar #'(lambda (bod)
`(prin1-http ,bod))
body))))
(named-function html-prin1-print-function
(lambda (ent cmd args form subst unknown stream)
(declare (ignore ent args unknown subst))
(assert (eql 2 (length form)))
(if* (eq cmd :full)
then (format stream "~s" (cadr form))
else (error ":prin1 must be given an argument")))))
(def-special-html :prin1-safe
(named-function html-prin1-safe-function
(lambda (ent args argsp body)
(declare (ignore ent args argsp))
`(progn ,@(mapcar #'(lambda (bod)
`(prin1-safe-http ,bod))
body))))
(named-function html-prin1-safe-print-function
(lambda (ent cmd args form subst unknown stream)
(declare (ignore args ent subst unknown))
(assert (eql 2 (length form)))
(if* (eq cmd :full)
then (emit-safe stream (format nil "~s" (cadr form)))
else (error ":prin1-safe must be given an argument")))))
(def-special-html :comment
(named-function html-comment-function
(lambda (ent args argsp body)
;; must use syntax
(declare (ignore ent args argsp))
`(progn (write-string "" *html-stream*))))
(named-function html-comment-print-function
(lambda (ent cmd args form subst unknown stream)
(declare (ignore ent cmd args subst unknown))
(format stream "" (cadr form)))))
(defmacro def-std-html (kwd has-inverse name-attrs)
(let ((mac-name (intern (format nil "~a-~a" :with-html kwd)))
(string-code (string-downcase (string kwd))))
`(progn (setf (gethash ,kwd *html-process-table*)
(make-html-process ,kwd ,has-inverse
',mac-name
nil
#'html-standard-print
',name-attrs))
(defmacro ,mac-name (args &rest body)
(html-body-key-form ,string-code ,has-inverse args body)))))
(def-std-html :a t nil)
(def-std-html :abbr t nil)
(def-std-html :acronym t nil)
(def-std-html :address t nil)
(def-std-html :applet t nil)
(def-std-html :area nil nil)
(def-std-html :b t nil)
(def-std-html :base nil nil)
(def-std-html :basefont nil nil)
(def-std-html :bdo t nil)
(def-std-html :bgsound nil nil)
(def-std-html :big t nil)
(def-std-html :blink t nil)
(def-std-html :blockquote t nil)
(def-std-html :body t nil)
(def-std-html :br nil nil)
(def-std-html :button nil nil)
(def-std-html :caption t nil)
(def-std-html :center t nil)
(def-std-html :cite t nil)
(def-std-html :code t nil)
(def-std-html :col nil nil)
(def-std-html :colgroup nil nil)
(def-std-html :dd t nil)
(def-std-html :del t nil)
(def-std-html :dfn t nil)
(def-std-html :dir t nil)
(def-std-html :div t nil)
(def-std-html :dl t nil)
(def-std-html :dt t nil)
(def-std-html :em t nil)
(def-std-html :embed t nil)
(def-std-html :fieldset t nil)
(def-std-html :font t nil)
(def-std-html :form t :name)
(def-std-html :frame t nil)
(def-std-html :frameset t nil)
(def-std-html :h1 t nil)
(def-std-html :h2 t nil)
(def-std-html :h3 t nil)
(def-std-html :h4 t nil)
(def-std-html :h5 t nil)
(def-std-html :h6 t nil)
(def-std-html :head t nil)
(def-std-html :hr nil nil)
(def-std-html :html t nil)
(def-std-html :i t nil)
(def-std-html :iframe t nil)
(def-std-html :ilayer t nil)
(def-std-html :img nil :id)
(def-std-html :input nil nil)
(def-std-html :ins t nil)
(def-std-html :isindex nil nil)
(def-std-html :kbd t nil)
(def-std-html :keygen nil nil)
(def-std-html :label t nil)
(def-std-html :layer t nil)
(def-std-html :legend t nil)
(def-std-html :li t nil)
(def-std-html :link nil nil)
(def-std-html :listing t nil)
(def-std-html :map t nil)
(def-std-html :marquee t nil)
(def-std-html :menu t nil)
(def-std-html :meta nil nil)
(def-std-html :multicol t nil)
(def-std-html :nobr t nil)
(def-std-html :noembed t nil)
(def-std-html :noframes t nil)
(def-std-html :noscript t nil)
(def-std-html :object t nil)
(def-std-html :ol t nil)
(def-std-html :optgroup t nil)
(def-std-html :option t nil)
(def-std-html :p t nil)
(def-std-html :param t nil)
(def-std-html :plaintext nil nil)
(def-std-html :pre t nil)
(def-std-html :q t nil)
(def-std-html :s t nil)
(def-std-html :samp t nil)
(def-std-html :script t nil)
(def-std-html :select t nil)
(def-std-html :server t nil)
(def-std-html :small t nil)
(def-std-html :spacer nil nil)
(def-std-html :span t :id)
(def-std-html :strike t nil)
(def-std-html :strong t nil)
(def-std-html :style t nil)
(def-std-html :sub t nil)
(def-std-html :sup t nil)
(def-std-html :table t :name)
(def-std-html :tbody t nil)
(def-std-html :td t nil)
(def-std-html :textarea t nil)
(def-std-html :tfoot t nil)
(def-std-html :th t nil)
(def-std-html :thead t nil)
(def-std-html :title t nil)
(def-std-html :tr t nil)
(def-std-html :tt t nil)
(def-std-html :u t nil)
(def-std-html :ul t nil)
(def-std-html :var t nil)
(def-std-html :wbr nil nil)
(def-std-html :xmp t nil)
;;; KMR Local Additions
(def-special-html :jscript
(named-function html-comment-function
(lambda (ent args argsp body)
;; must use syntax
(declare (ignore ent args argsp))
`(progn
(write-string "" *html-stream*))))
(named-function html-comment-print-function
(lambda (ent cmd args form subst unknown stream)
(declare (ignore ent cmd args subst unknown))
(format stream ""
(cadr form)))))