+;; -*- mode: common-lisp; package: lml2 -*-
+;;
+;; $Id: htmlgen.lisp,v 1.1 2003/06/20 04:12:29 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 "</~a>" 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 "</~a>" 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 "</~a>" 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 "</~a>" (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*)
+ (html ,@body)
+ (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 "<!--~a-->" (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 "<script language=\"JavasSript\" type=\"text/javascript\">"
+ *html-stream*)
+ (html ,@body)
+ (write-string "</script>" *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 "<script language=\"JavaScript\" type=\"text/javascript\">~A</script>"
+ (cadr form)))))