1 ;; -*- mode: common-lisp; package: lml2 -*-
3 ;; $Id: htmlgen.lisp,v 1.3 2003/06/24 01:12:17 kevin Exp $
5 ;; copyright (c) 1986-2000 Franz Inc, Berkeley, CA
6 ;; copyright (c) 2003 Kevin Rosenberg
8 ;; Main changes from Allegro version:
10 ;; - lowercase symbol names
12 ;; This code is free software; you can redistribute it and/or
13 ;; modify it under the terms of the version 2.1 of
14 ;; the GNU Lesser General Public License as published by
15 ;; the Free Software Foundation, as clarified by the AllegroServe
16 ;; prequel found in license-allegroserve.txt.
24 (defstruct (html-process (:type list) (:constructor
25 make-html-process (key has-inverse
30 key ; keyword naming this tag
31 has-inverse ; t if the / form is used
32 macro ; the macro to define this
33 special ; if true then call this to process the keyword and return
35 print ; function used to handle this in html-print
36 name-attr ; attribute symbols which can name this object for subst purposes
40 (defparameter *html-process-table*
41 (make-hash-table :test #'equal) ; #'eq is accurate but want to avoid rehashes
44 (defmacro html (&rest forms &environment env)
45 ;; just emit html to the current stream
46 (process-html-forms forms env))
48 (defmacro html-out-stream-check (stream)
49 ;; ensure that a real stream is passed to this function
50 `(let ((.str. ,stream))
51 (if* (not (streamp .str.))
52 then (error "html-stream must be passed a stream object, not ~s"
57 (defmacro html-stream (stream &rest forms)
58 ;; set output stream and emit html
59 `(let ((*html-stream* (html-out-stream-check ,stream))) (html ,@forms)))
62 (defun process-html-forms (forms env)
64 (flet ((do-ent (ent args argsp body)
65 ;; ent is an html-process object associated with the
66 ;; html tag we're processing
67 ;; args is the list of values after the tag in the form
68 ;; ((:tag &rest args) ....)
69 ;; argsp is true if this isn't a singleton tag (i.e. it has
70 ;; a body) .. (:tag ...) or ((:tag ...) ...)
71 ;; body is the body if any of the form
74 (if* (setq spec (html-process-special ent))
75 then ; do something different
76 (push (funcall spec ent args argsp body) res)
78 then ; singleton tag, just do the set
79 (push `(,(html-process-macro ent) :set) res)
81 else (if* (equal args '(:unset))
82 then ; ((:tag :unset)) is a special case.
83 ; that allows us to close off singleton tags
85 (push `(,(html-process-macro ent) :unset) res)
88 (push `(,(html-process-macro ent) ,args
89 ,(process-html-forms body env))
95 (do* ((xforms forms (cdr xforms))
96 (form (car xforms) (car xforms)))
99 (setq form (macroexpand form env))
102 then (if* (keywordp form)
103 then (let ((ent (gethash form *html-process-table*)))
105 then (error "unknown html keyword ~s"
107 else (do-ent ent nil nil nil)))
108 elseif (stringp form)
109 then ; turn into a print of it
110 (push `(write-string ,form *html-stream*) res)
111 else (push form res))
112 else (let ((first (car form)))
113 (if* (keywordp first)
114 then ; (:xxx . body) form
115 (let ((ent (gethash first
116 *html-process-table*)))
118 then (error "unknown html keyword ~s"
120 else (do-ent ent nil t (cdr form))))
121 elseif (and (consp first) (keywordp (car first)))
122 then ; ((:xxx args ) . body)
123 (let ((ent (gethash (car first)
124 *html-process-table*)))
126 then (error "unknown html keyword ~s"
128 else (do-ent ent (cdr first) t (cdr form))))
129 else (push form res))))))
130 `(progn ,@(nreverse res))))
133 (defun html-atom-check (args open close body)
134 (if* (and args (atom args))
135 then (let ((ans (case args
136 (:set `(write-string ,open *html-stream*))
137 (:unset `(write-string ,close *html-stream*))
138 (t (error "illegal arg ~s to ~s" args open)))))
140 then (error "can't have a body form with this arg: ~s"
144 (defun html-body-form (open close body)
145 ;; used when args don't matter
146 `(progn (write-string ,open *html-stream*)
148 (write-string ,close *html-stream*)))
151 (defun html-body-key-form (string-code has-inv args body)
152 ;; do what's needed to handle given keywords in the args
154 (if* (and args (atom args))
156 (return-from html-body-key-form
159 then `(write-string ,(format nil "<~a>" string-code)
161 else `(write-string ,(format nil "<~a />" string-code)
164 then `(write-string ,(format nil "</~a>" string-code)
166 (t (error "illegal arg ~s to ~s" args string-code)))))
168 (if* (not (evenp (length args)))
169 then (warn "arg list ~s isn't even" args))
173 then `(progn (write-string ,(format nil "<~a" string-code)
175 ,@(do ((xx args (cddr xx))
179 (if* (eq :if* (car xx))
180 then ; insert following conditionally
181 (push `(if* ,(cadr xx)
183 ,(format nil " ~(~a~)" (caddr xx))
185 (prin1-safe-http-string ,(cadddr xx)))
191 ,(format nil " ~(~a~)" (car xx))
194 (push `(prin1-safe-http-string ,(cadr xx)) res)))
196 ,(unless has-inv `(write-string " /" *html-stream*))
197 (write-string ">" *html-stream*)
199 ,(if* (and body has-inv)
200 then `(write-string ,(format nil "</~a>" string-code)
205 `(progn (write-string ,(format nil "<~a>" string-code)
209 then `(write-string ,(format nil "</~a>" string-code)
212 `(progn (write-string ,(format nil "<~a />" string-code)
217 (defun princ-http (val)
218 ;; print the given value to the http stream using ~a
219 (format *html-stream* "~a" val))
221 (defun prin1-http (val)
222 ;; print the given value to the http stream using ~s
223 (format *html-stream* "~s" val))
226 (defun princ-safe-http (val)
227 (emit-safe *html-stream* (format nil "~a" val)))
229 (defun prin1-safe-http (val)
230 (emit-safe *html-stream* (format nil "~s" val)))
233 (defun prin1-safe-http-string (val)
234 ;; used only in a parameter value situation
236 ;; if the parameter value is the symbol with the empty print name
237 ;; then turn this into a singleton object. Thus || is differnent
240 ;; print the contents inside a string double quotes (which should
241 ;; not be turned into "'s
242 ;; symbols are turned into their name
243 (if* (and (symbolp val)
244 (equal "" (symbol-name val)))
246 else (write-char #\= *html-stream*)
247 (if* (or (stringp val)
249 (setq val (string-downcase
250 (symbol-name val)))))
251 then (write-char #\" *html-stream*)
252 (emit-safe *html-stream* val)
253 (write-char #\" *html-stream*)
254 else (prin1-safe-http val))))
258 (defun emit-safe (stream string)
259 ;; send the string to the http response stream watching out for
260 ;; special html characters and encoding them appropriately
263 (end (length string)))
266 then (write-sequence string
272 (let ((ch (schar string i))
275 then (setq cvt "<")
277 then (setq cvt ">")
279 then (setq cvt "&")
281 then (setq cvt """))
283 then ; must do a conversion, emit previous chars first
286 then (write-sequence string
290 (write-string cvt stream)
292 (setq start (1+ i))))))
296 (defun html-print-list (list-of-forms stream &key unknown)
297 ;; html print a list of forms
298 (dolist (x list-of-forms)
299 (html-print-subst x nil stream unknown)))
302 (defun html-print-list-subst (list-of-forms subst stream &key unknown)
303 ;; html print a list of forms
304 (dolist (x list-of-forms)
305 (html-print-subst x subst stream unknown)))
308 (defun html-print (form stream &key unknown)
309 (html-print-subst form nil stream unknown))
312 (defun html-print-subst (form subst stream unknown)
313 ;; Print the given lhtml form to the given stream
314 (assert (streamp stream))
320 (possible-kwd (if* (atom form)
322 elseif (consp (car form))
323 then (setq attrs (cdar form))
328 (if* (keywordp possible-kwd)
329 then (if* (null (setq ent (gethash possible-kwd *html-process-table*)))
331 then (return-from html-print-subst
332 (funcall unknown form stream))
333 else (error "unknown html tag: ~s" possible-kwd))
334 else ; see if we should subst
337 (setq attr-name (html-process-name-attr ent))
338 (setq name (getf attrs attr-name))
339 (setq attrs (html-find-value name subst)))
341 (return-from html-print-subst
342 (if* (functionp (cdr attrs))
344 (funcall (cdr attrs) stream)
345 else (html-print-subst
352 (html-process-print ent)))
354 then (if* (keywordp form)
355 then (funcall print-handler ent :set nil nil nil nil stream)
356 elseif (stringp form)
357 then (write-string form stream)
358 else (princ form stream))
360 then (funcall print-handler
363 (if* (consp (car form)) then (cdr (car form)))
368 else (error "Illegal form: ~s" form))))
371 (defun html-find-value (key subst)
372 ; find the (key . value) object in the subst list.
373 ; A subst list is an assoc list ((key . value) ....)
374 ; but instead of a (key . value) cons you may have an assoc list
376 (let ((to-process nil)
379 (do* ((entlist alist (cdr entlist))
380 (ent (car entlist) (car entlist)))
381 ((null entlist) (setq alist nil))
382 (if* (consp (car ent))
383 then ; this is another alist
385 then (push (cdr entlist) to-process))
388 elseif (equal key (car ent))
389 then (return-from html-find-value ent)))
392 then ; we need to find a new alist to process
395 then (setq alist (pop to-process))
398 (defun html-standard-print (ent cmd args form subst unknown stream)
399 ;; the print handler for the normal html operators
401 (:set ; just turn it on
402 (format stream "<~a>" (html-process-key ent)))
403 (:full ; set, do body and then unset
406 then (if* (and (setq iter (getf args :iter))
407 (setq iter (html-find-value iter subst)))
408 then ; remove the iter and pre
409 (setq args (copy-list args))
412 (cons (cons (caar form)
417 (return-from html-standard-print)
419 (format stream "<~a" (html-process-key ent))
420 (do ((xx args (cddr xx)))
422 ; assume that the arg is already escaped
425 (format stream " ~a=\"~a\"" (car xx) (cadr xx)))
427 else (format stream "<~a>" (html-process-key ent)))
428 (dolist (ff (cdr form))
429 (html-print-subst ff subst stream unknown)))
430 (if* (html-process-has-inverse ent)
432 (format stream "</~a>" (html-process-key ent))))))
441 ;; -- defining how html tags are handled. --
443 ;; most tags are handled in a standard way and the def-std-html
444 ;; macro is used to define such tags
446 ;; Some tags need special treatment and def-special-html defines
447 ;; how these are handled. The tags requiring special treatment
448 ;; are the pseudo tags we added to control operations
449 ;; in the html generator.
452 ;; tags can be found in three ways:
453 ;; :br - singleton, no attributes, no body
454 ;; (:b "foo") - no attributes but with a body
455 ;; ((:a href="foo") "balh") - attributes and body
460 (defmacro def-special-html (kwd fcn print-fcn)
461 ;; kwd - the tag we're defining behavior for.
462 ;; fcn - function to compute the macroexpansion of a use of this
463 ;; tag. args to fcn are:
464 ;; ent - html-process object holding info on this tag
465 ;; args - list of attribute-values following tag
466 ;; argsp - true if there is a body in this use of the tag
467 ;; body - list of body forms.
468 ;; print-fcn - function to print an lhtml form with this tag
470 ;; ent - html-process object holding info on this tag
471 ;; cmd - one of :set, :unset, :full
472 ;; args - list of attribute-value pairs
473 ;; subst - subsitution list
474 ;; unknown - function to call for unknown tags
475 ;; stream - stream to write to
477 `(setf (gethash ,kwd *html-process-table*)
478 (make-html-process ,kwd nil nil ,fcn ,print-fcn nil)))
481 (defmacro named-function (name &body body)
482 (declare (ignore name))
486 (def-special-html :newline
487 (named-function html-newline-function
488 (lambda (ent args argsp body)
489 (declare (ignore ent args argsp))
491 then (error "can't have a body with :newline -- body is ~s" body))
493 `(terpri *html-stream*)))
495 (named-function html-newline-print-function
496 (lambda (ent cmd args form subst unknown stream)
497 (declare (ignore args ent unknown subst))
500 else (error ":newline in an illegal place: ~s" form)))))
502 (def-special-html :princ
503 (named-function html-princ-function
504 (lambda (ent args argsp body)
505 (declare (ignore ent args argsp))
506 `(progn ,@(mapcar #'(lambda (bod)
510 (named-function html-princ-print-function
511 (lambda (ent cmd args form subst unknown stream)
512 (declare (ignore args ent unknown subst))
513 (assert (eql 2 (length form)))
515 then (format stream "~a" (cadr form))
516 else (error ":princ must be given an argument")))))
518 (def-special-html :princ-safe
519 (named-function html-princ-safe-function
520 (lambda (ent args argsp body)
521 (declare (ignore ent args argsp))
522 `(progn ,@(mapcar #'(lambda (bod)
523 `(princ-safe-http ,bod))
525 (named-function html-princ-safe-print-function
526 (lambda (ent cmd args form subst unknown stream)
527 (declare (ignore args ent unknown subst))
528 (assert (eql 2 (length form)))
530 then (emit-safe stream (format nil "~a" (cadr form)))
531 else (error ":princ-safe must be given an argument")))))
533 (def-special-html :prin1
534 (named-function html-prin1-function
535 (lambda (ent args argsp body)
536 (declare (ignore ent args argsp))
537 `(progn ,@(mapcar #'(lambda (bod)
540 (named-function html-prin1-print-function
541 (lambda (ent cmd args form subst unknown stream)
542 (declare (ignore ent args unknown subst))
543 (assert (eql 2 (length form)))
545 then (format stream "~s" (cadr form))
546 else (error ":prin1 must be given an argument")))))
548 (def-special-html :prin1-safe
549 (named-function html-prin1-safe-function
550 (lambda (ent args argsp body)
551 (declare (ignore ent args argsp))
552 `(progn ,@(mapcar #'(lambda (bod)
553 `(prin1-safe-http ,bod))
555 (named-function html-prin1-safe-print-function
556 (lambda (ent cmd args form subst unknown stream)
557 (declare (ignore args ent subst unknown))
558 (assert (eql 2 (length form)))
560 then (emit-safe stream (format nil "~s" (cadr form)))
561 else (error ":prin1-safe must be given an argument")))))
563 (def-special-html :comment
564 (named-function html-comment-function
565 (lambda (ent args argsp body)
566 ;; must use <!-- --> syntax
567 (declare (ignore ent args argsp))
568 `(progn (write-string "<!--" *html-stream*)
570 (write-string "-->" *html-stream*))))
571 (named-function html-comment-print-function
572 (lambda (ent cmd args form subst unknown stream)
573 (declare (ignore ent cmd args subst unknown))
574 (format stream "<!--~a-->" (cadr form)))))
578 (defmacro def-std-html (kwd has-inverse name-attrs)
579 (let ((mac-name (intern (format nil "~a-~a" :with-html kwd)))
580 (string-code (string-downcase (string kwd))))
581 `(progn (setf (gethash ,kwd *html-process-table*)
582 (make-html-process ,kwd ,has-inverse
585 #'html-standard-print
587 (defmacro ,mac-name (args &rest body)
588 (html-body-key-form ,string-code ,has-inverse args body)))))
592 (def-std-html :a t nil)
593 (def-std-html :abbr t nil)
594 (def-std-html :acronym t nil)
595 (def-std-html :address t nil)
596 (def-std-html :applet t nil)
597 (def-std-html :area nil nil)
599 (def-std-html :b t nil)
600 (def-std-html :base nil nil)
601 (def-std-html :basefont nil nil)
602 (def-std-html :bdo t nil)
603 (def-std-html :bgsound nil nil)
604 (def-std-html :big t nil)
605 (def-std-html :blink t nil)
606 (def-std-html :blockquote t nil)
607 (def-std-html :body t nil)
608 (def-std-html :br nil nil)
609 (def-std-html :button nil nil)
611 (def-std-html :caption t nil)
612 (def-std-html :center t nil)
613 (def-std-html :cite t nil)
614 (def-std-html :code t nil)
615 (def-std-html :col nil nil)
616 (def-std-html :colgroup nil nil)
618 (def-std-html :dd t nil)
619 (def-std-html :del t nil)
620 (def-std-html :dfn t nil)
621 (def-std-html :dir t nil)
622 (def-std-html :div t nil)
623 (def-std-html :dl t nil)
624 (def-std-html :dt t nil)
626 (def-std-html :em t nil)
627 (def-std-html :embed t nil)
629 (def-std-html :fieldset t nil)
630 (def-std-html :font t nil)
631 (def-std-html :form t :name)
632 (def-std-html :frame t nil)
633 (def-std-html :frameset t nil)
635 (def-std-html :h1 t nil)
636 (def-std-html :h2 t nil)
637 (def-std-html :h3 t nil)
638 (def-std-html :h4 t nil)
639 (def-std-html :h5 t nil)
640 (def-std-html :h6 t nil)
641 (def-std-html :head t nil)
642 (def-std-html :hr nil nil)
643 (def-std-html :html t nil)
645 (def-std-html :i t nil)
646 (def-std-html :iframe t nil)
647 (def-std-html :ilayer t nil)
648 (def-std-html :img nil :id)
649 (def-std-html :input nil nil)
650 (def-std-html :ins t nil)
651 (def-std-html :isindex nil nil)
653 (def-std-html :kbd t nil)
654 (def-std-html :keygen nil nil)
656 (def-std-html :label t nil)
657 (def-std-html :layer t nil)
658 (def-std-html :legend t nil)
659 (def-std-html :li t nil)
660 (def-std-html :link nil nil)
661 (def-std-html :listing t nil)
663 (def-std-html :map t nil)
664 (def-std-html :marquee t nil)
665 (def-std-html :menu t nil)
666 (def-std-html :meta nil nil)
667 (def-std-html :multicol t nil)
669 (def-std-html :nobr t nil)
670 (def-std-html :noembed t nil)
671 (def-std-html :noframes t nil)
672 (def-std-html :noscript t nil)
674 (def-std-html :object t nil)
675 (def-std-html :ol t nil)
676 (def-std-html :optgroup t nil)
677 (def-std-html :option t nil)
679 (def-std-html :p t nil)
680 (def-std-html :param t nil)
681 (def-std-html :plaintext nil nil)
682 (def-std-html :pre t nil)
684 (def-std-html :q t nil)
686 (def-std-html :s t nil)
687 (def-std-html :samp t nil)
688 (def-std-html :script t nil)
689 (def-std-html :select t nil)
690 (def-std-html :server t nil)
691 (def-std-html :small t nil)
692 (def-std-html :spacer nil nil)
693 (def-std-html :span t :id)
694 (def-std-html :strike t nil)
695 (def-std-html :strong t nil)
696 (def-std-html :style t nil)
697 (def-std-html :sub t nil)
698 (def-std-html :sup t nil)
700 (def-std-html :table t :name)
701 (def-std-html :tbody t nil)
702 (def-std-html :td t nil)
703 (def-std-html :textarea t nil)
704 (def-std-html :tfoot t nil)
705 (def-std-html :th t nil)
706 (def-std-html :thead t nil)
707 (def-std-html :title t nil)
708 (def-std-html :tr t nil)
709 (def-std-html :tt t nil)
711 (def-std-html :u t nil)
712 (def-std-html :ul t nil)
714 (def-std-html :var t nil)
716 (def-std-html :wbr nil nil)
718 (def-std-html :xmp t nil)
723 ;;; KMR Local Additions
725 (def-special-html :jscript
726 (named-function html-comment-function
727 (lambda (ent args argsp body)
728 ;; must use <!-- --> syntax
729 (declare (ignore ent args argsp))
731 (write-string "<script language=\"JavasSript\" type=\"text/javascript\">" *html-stream*)
732 (write-char #\newline *html-stream*)
733 (write-string "//![CDATA[" *html-stream*)
734 (write-char #\newline *html-stream*)
736 (write-char #\newline *html-stream*)
737 (write-string "//]]>" *html-stream*)
738 (write-char #\newline *html-stream*)
739 (write-string "</script>" *html-stream*))))
740 (named-function html-comment-print-function
741 (lambda (ent cmd args form subst unknown stream)
742 (declare (ignore ent cmd args subst unknown))
743 (format stream "<script language=\"JavaScript\" type=\"text/javascript\">~%//![CDATA[~%~A~%//]]>~%</script>"
746 (def-special-html :nbsp
747 (named-function html-nbsp-function
748 (lambda (ent args argsp body)
749 (declare (ignore ent args argsp))
751 (error "can't have a body with :nbsp -- body is ~s" body))
752 `(write-string " " *html-stream*)))
754 (named-function html-nbsp-print-function
755 (lambda (ent cmd args form subst unknown stream)
756 (declare (ignore args ent unknown subst))
758 then (write-string " " stream)
759 else (error ":nbsp in an illegal place: ~s" form)))))