1 ;; -*- mode: common-lisp; package: lml2 -*-
3 ;; $Id: htmlgen.lisp,v 1.7 2003/06/24 17:51:22 kevin Exp $
5 ;; copyright (c) 1986-2000 Franz Inc, Berkeley, CA
6 ;; copyright (c) 2003 Kevin Rosenberg
8 ;; Main changes from Allegro version:
9 ;; - Support XHTML end tags
10 ;; - lowercase symbol names for attributes
11 ;; - Add custom tags such as :jscript, :insert-file, :nbsp
13 ;; This code is free software; you can redistribute it and/or
14 ;; modify it under the terms of the version 2.1 of
15 ;; the GNU Lesser General Public License as published by
16 ;; the Free Software Foundation, as clarified by the LLGPL
22 (defstruct (html-process (:type list) (:constructor
23 make-html-process (key has-inverse
28 key ; keyword naming this tag
29 has-inverse ; t if the / form is used
30 macro ; the macro to define this
31 special ; if true then call this to process the keyword and return
33 print ; function used to handle this in html-print
34 name-attr ; attribute symbols which can name this object for subst purposes
38 (defparameter *html-process-table*
39 (make-hash-table :test #'equal) ; #'eq is accurate but want to avoid rehashes
42 (defmacro html (&rest forms &environment env)
43 ;; just emit html to the current stream
44 (process-html-forms forms env))
46 (defmacro html-out-stream-check (stream)
47 ;; ensure that a real stream is passed to this function
48 `(let ((.str. ,stream))
49 (if* (not (streamp .str.))
50 then (error "html-stream must be passed a stream object, not ~s"
55 (defmacro html-stream (stream &rest forms)
56 ;; set output stream and emit html
57 `(let ((*html-stream* (html-out-stream-check ,stream))) (html ,@forms)))
60 (defun process-html-forms (forms env)
62 (flet ((do-ent (ent args argsp body)
63 ;; ent is an html-process object associated with the
64 ;; html tag we're processing
65 ;; args is the list of values after the tag in the form
66 ;; ((:tag &rest args) ....)
67 ;; argsp is true if this isn't a singleton tag (i.e. it has
68 ;; a body) .. (:tag ...) or ((:tag ...) ...)
69 ;; body is the body if any of the form
72 (if* (setq spec (html-process-special ent))
73 then ; do something different
74 (push (funcall spec ent args argsp body) res)
76 then ; singleton tag, just do the set
77 (push `(,(html-process-macro ent) :set) res)
79 else (if* (equal args '(:unset))
80 then ; ((:tag :unset)) is a special case.
81 ; that allows us to close off singleton tags
83 (push `(,(html-process-macro ent) :unset) res)
86 (push `(,(html-process-macro ent) ,args
87 ,(process-html-forms body env))
93 (do* ((xforms forms (cdr xforms))
94 (form (car xforms) (car xforms)))
97 (setq form (macroexpand form env))
100 then (if* (keywordp form)
101 then (let ((ent (gethash form *html-process-table*)))
103 then (error "unknown html keyword ~s"
105 else (do-ent ent nil nil nil)))
106 elseif (stringp form)
107 then ; turn into a print of it
108 (push `(write-string ,form *html-stream*) res)
109 else (push form res))
110 else (let ((first (car form)))
111 (if* (keywordp first)
112 then ; (:xxx . body) form
113 (let ((ent (gethash first
114 *html-process-table*)))
116 then (error "unknown html keyword ~s"
118 else (do-ent ent nil t (cdr form))))
119 elseif (and (consp first) (keywordp (car first)))
120 then ; ((:xxx args ) . body)
121 (let ((ent (gethash (car first)
122 *html-process-table*)))
124 then (error "unknown html keyword ~s"
126 else (do-ent ent (cdr first) t (cdr form))))
127 else (push form res))))))
128 `(progn ,@(nreverse res))))
131 (defun html-atom-check (args open close body)
132 (if* (and args (atom args))
133 then (let ((ans (case args
134 (:set `(write-string ,open *html-stream*))
135 (:unset `(write-string ,close *html-stream*))
136 (t (error "illegal arg ~s to ~s" args open)))))
138 then (error "can't have a body form with this arg: ~s"
142 (defun html-body-form (open close body)
143 ;; used when args don't matter
144 `(progn (write-string ,open *html-stream*)
146 (write-string ,close *html-stream*)))
149 (defun html-body-key-form (string-code has-inv args body)
150 ;; do what's needed to handle given keywords in the args
152 (if* (and args (atom args))
154 (return-from html-body-key-form
157 then `(write-string ,(format nil "<~a>" string-code)
159 else `(write-string ,(format nil "<~a />" string-code)
162 then `(write-string ,(format nil "</~a>" string-code)
164 (t (error "illegal arg ~s to ~s" args string-code)))))
166 (if* (not (evenp (length args)))
167 then (warn "arg list ~s isn't even" args))
171 then `(progn (write-string ,(format nil "<~a" string-code)
173 ,@(do ((xx args (cddr xx))
177 (if* (eq :if* (car xx))
178 then ; insert following conditionally
179 (push `(if* ,(cadr xx)
181 ,(format nil " ~(~a~)" (caddr xx))
183 (prin1-safe-http-string ,(cadddr xx)))
189 ,(format nil " ~(~a~)" (car xx))
192 (push `(prin1-safe-http-string ,(cadr xx)) res)))
194 ,(unless has-inv `(write-string " /" *html-stream*))
195 (write-string ">" *html-stream*)
197 ,(if* (and body has-inv)
198 then `(write-string ,(format nil "</~a>" string-code)
203 `(progn (write-string ,(format nil "<~a>" string-code)
207 then `(write-string ,(format nil "</~a>" string-code)
210 `(progn (write-string ,(format nil "<~a />" string-code)
215 (defun princ-http (val)
216 ;; print the given value to the http stream using ~a
217 (format *html-stream* "~a" val))
219 (defun prin1-http (val)
220 ;; print the given value to the http stream using ~s
221 (format *html-stream* "~s" val))
224 (defun princ-safe-http (val)
225 (emit-safe *html-stream* (format nil "~a" val)))
227 (defun prin1-safe-http (val)
228 (emit-safe *html-stream* (format nil "~s" val)))
231 (defun prin1-safe-http-string (val)
232 ;; used only in a parameter value situation
234 ;; if the parameter value is the symbol with the empty print name
235 ;; then turn this into a singleton object. Thus || is differnent
238 ;; print the contents inside a string double quotes (which should
239 ;; not be turned into "'s
240 ;; symbols are turned into their name
241 (if* (and (symbolp val)
242 (equal "" (symbol-name val)))
244 else (write-char #\= *html-stream*)
245 (if* (or (stringp val)
247 (setq val (string-downcase
248 (symbol-name val)))))
249 then (write-char #\" *html-stream*)
250 (emit-safe *html-stream* val)
251 (write-char #\" *html-stream*)
252 else (prin1-safe-http val))))
256 (defun emit-safe (stream string)
257 ;; send the string to the http response stream watching out for
258 ;; special html characters and encoding them appropriately
261 (end (length string)))
264 then (write-sequence string
270 (let ((ch (schar string i))
273 then (setq cvt "<")
275 then (setq cvt ">")
277 then (setq cvt "&")
279 then (setq cvt """))
281 then ; must do a conversion, emit previous chars first
284 then (write-sequence string
288 (write-string cvt stream)
290 (setq start (1+ i))))))
294 (defun html-print-list (list-of-forms stream &key unknown)
295 ;; html print a list of forms
296 (dolist (x list-of-forms)
297 (html-print-subst x nil stream unknown)))
300 (defun html-print-list-subst (list-of-forms subst stream &key unknown)
301 ;; html print a list of forms
302 (dolist (x list-of-forms)
303 (html-print-subst x subst stream unknown)))
306 (defun html-print (form stream &key unknown)
307 (html-print-subst form nil stream unknown))
310 (defun html-print-subst (form subst stream unknown)
311 ;; Print the given lhtml form to the given stream
312 (assert (streamp stream))
318 (possible-kwd (if* (atom form)
320 elseif (consp (car form))
321 then (setq attrs (cdar form))
326 (if* (keywordp possible-kwd)
327 then (if* (null (setq ent (gethash possible-kwd *html-process-table*)))
329 then (return-from html-print-subst
330 (funcall unknown form stream))
331 else (error "unknown html tag: ~s" possible-kwd))
332 else ; see if we should subst
335 (setq attr-name (html-process-name-attr ent))
336 (setq name (getf attrs attr-name))
337 (setq attrs (html-find-value name subst)))
339 (return-from html-print-subst
340 (if* (functionp (cdr attrs))
342 (funcall (cdr attrs) stream)
343 else (html-print-subst
350 (html-process-print ent)))
352 then (if* (keywordp form)
353 then (funcall print-handler ent :set nil nil nil nil stream)
354 elseif (stringp form)
355 then (write-string form stream)
356 else (princ form stream))
358 then (funcall print-handler
361 (if* (consp (car form)) then (cdr (car form)))
366 else (error "Illegal form: ~s" form))))
369 (defun html-find-value (key subst)
370 ; find the (key . value) object in the subst list.
371 ; A subst list is an assoc list ((key . value) ....)
372 ; but instead of a (key . value) cons you may have an assoc list
374 (let ((to-process nil)
377 (do* ((entlist alist (cdr entlist))
378 (ent (car entlist) (car entlist)))
379 ((null entlist) (setq alist nil))
380 (if* (consp (car ent))
381 then ; this is another alist
383 then (push (cdr entlist) to-process))
386 elseif (equal key (car ent))
387 then (return-from html-find-value ent)))
390 then ; we need to find a new alist to process
393 then (setq alist (pop to-process))
396 (defun html-standard-print (ent cmd args form subst unknown stream)
397 ;; the print handler for the normal html operators
399 (:set ; just turn it on
400 (format stream "<~a>" (html-process-key ent)))
401 (:full ; set, do body and then unset
404 then (if* (and (setq iter (getf args :iter))
405 (setq iter (html-find-value iter subst)))
406 then ; remove the iter and pre
407 (setq args (copy-list args))
410 (cons (cons (caar form)
415 (return-from html-standard-print)
417 (format stream "<~a" (html-process-key ent))
418 (do ((xx args (cddr xx)))
420 ; assume that the arg is already escaped
423 (format stream " ~a=\"~a\"" (car xx) (cadr xx)))
425 else (format stream "<~a>" (html-process-key ent)))
426 (dolist (ff (cdr form))
427 (html-print-subst ff subst stream unknown)))
428 (if* (html-process-has-inverse ent)
430 (format stream "</~a>" (html-process-key ent))))))
439 ;; -- defining how html tags are handled. --
441 ;; most tags are handled in a standard way and the def-std-html
442 ;; macro is used to define such tags
444 ;; Some tags need special treatment and def-special-html defines
445 ;; how these are handled. The tags requiring special treatment
446 ;; are the pseudo tags we added to control operations
447 ;; in the html generator.
450 ;; tags can be found in three ways:
451 ;; :br - singleton, no attributes, no body
452 ;; (:b "foo") - no attributes but with a body
453 ;; ((:a href="foo") "balh") - attributes and body
458 (defmacro def-special-html (kwd fcn print-fcn)
459 ;; kwd - the tag we're defining behavior for.
460 ;; fcn - function to compute the macroexpansion of a use of this
461 ;; tag. args to fcn are:
462 ;; ent - html-process object holding info on this tag
463 ;; args - list of attribute-values following tag
464 ;; argsp - true if there is a body in this use of the tag
465 ;; body - list of body forms.
466 ;; print-fcn - function to print an lhtml form with this tag
468 ;; ent - html-process object holding info on this tag
469 ;; cmd - one of :set, :unset, :full
470 ;; args - list of attribute-value pairs
471 ;; subst - subsitution list
472 ;; unknown - function to call for unknown tags
473 ;; stream - stream to write to
475 `(setf (gethash ,kwd *html-process-table*)
476 (make-html-process ,kwd nil nil ,fcn ,print-fcn nil)))
479 (defmacro named-function (name &body body)
480 (declare (ignore name))
484 (def-special-html :newline
485 (named-function html-newline-function
486 (lambda (ent args argsp body)
487 (declare (ignore ent args argsp))
489 then (error "can't have a body with :newline -- body is ~s" body))
491 `(terpri *html-stream*)))
493 (named-function html-newline-print-function
494 (lambda (ent cmd args form subst unknown stream)
495 (declare (ignore args ent unknown subst))
498 else (error ":newline in an illegal place: ~s" form)))))
500 (def-special-html :princ
501 (named-function html-princ-function
502 (lambda (ent args argsp body)
503 (declare (ignore ent args argsp))
504 `(progn ,@(mapcar #'(lambda (bod)
508 (named-function html-princ-print-function
509 (lambda (ent cmd args form subst unknown stream)
510 (declare (ignore args ent unknown subst))
511 (assert (eql 2 (length form)))
513 then (format stream "~a" (cadr form))
514 else (error ":princ must be given an argument")))))
516 (def-special-html :princ-safe
517 (named-function html-princ-safe-function
518 (lambda (ent args argsp body)
519 (declare (ignore ent args argsp))
520 `(progn ,@(mapcar #'(lambda (bod)
521 `(princ-safe-http ,bod))
523 (named-function html-princ-safe-print-function
524 (lambda (ent cmd args form subst unknown stream)
525 (declare (ignore args ent unknown subst))
526 (assert (eql 2 (length form)))
528 then (emit-safe stream (format nil "~a" (cadr form)))
529 else (error ":princ-safe must be given an argument")))))
531 (def-special-html :prin1
532 (named-function html-prin1-function
533 (lambda (ent args argsp body)
534 (declare (ignore ent args argsp))
535 `(progn ,@(mapcar #'(lambda (bod)
538 (named-function html-prin1-print-function
539 (lambda (ent cmd args form subst unknown stream)
540 (declare (ignore ent args unknown subst))
541 (assert (eql 2 (length form)))
543 then (format stream "~s" (cadr form))
544 else (error ":prin1 must be given an argument")))))
546 (def-special-html :prin1-safe
547 (named-function html-prin1-safe-function
548 (lambda (ent args argsp body)
549 (declare (ignore ent args argsp))
550 `(progn ,@(mapcar #'(lambda (bod)
551 `(prin1-safe-http ,bod))
553 (named-function html-prin1-safe-print-function
554 (lambda (ent cmd args form subst unknown stream)
555 (declare (ignore args ent subst unknown))
556 (assert (eql 2 (length form)))
558 then (emit-safe stream (format nil "~s" (cadr form)))
559 else (error ":prin1-safe must be given an argument")))))
561 (def-special-html :comment
562 (named-function html-comment-function
563 (lambda (ent args argsp body)
564 ;; must use <!-- --> syntax
565 (declare (ignore ent args argsp))
566 `(progn (write-string "<!--" *html-stream*)
568 (write-string "-->" *html-stream*))))
569 (named-function html-comment-print-function
570 (lambda (ent cmd args form subst unknown stream)
571 (declare (ignore ent cmd args subst unknown))
572 (format stream "<!--~a-->" (cadr form)))))
576 (defmacro def-std-html (kwd has-inverse name-attrs)
577 (let ((mac-name (intern (format nil "~a-~a" :with-html kwd)))
578 (string-code (string-downcase (string kwd))))
579 `(progn (setf (gethash ,kwd *html-process-table*)
580 (make-html-process ,kwd ,has-inverse
583 #'html-standard-print
585 (defmacro ,mac-name (args &rest body)
586 (html-body-key-form ,string-code ,has-inverse args body)))))
590 (def-std-html :a t nil)
591 (def-std-html :abbr t nil)
592 (def-std-html :acronym t nil)
593 (def-std-html :address t nil)
594 (def-std-html :applet t nil)
595 (def-std-html :area nil nil)
597 (def-std-html :b t nil)
598 (def-std-html :base nil nil)
599 (def-std-html :basefont nil nil)
600 (def-std-html :bdo t nil)
601 (def-std-html :bgsound nil nil)
602 (def-std-html :big t nil)
603 (def-std-html :blink t nil)
604 (def-std-html :blockquote t nil)
605 (def-std-html :body t nil)
606 (def-std-html :br nil nil)
607 (def-std-html :button nil nil)
609 (def-std-html :caption t nil)
610 (def-std-html :center t nil)
611 (def-std-html :cite t nil)
612 (def-std-html :code t nil)
613 (def-std-html :col nil nil)
614 (def-std-html :colgroup nil nil)
616 (def-std-html :dd t nil)
617 (def-std-html :del t nil)
618 (def-std-html :dfn t nil)
619 (def-std-html :dir t nil)
620 (def-std-html :div t nil)
621 (def-std-html :dl t nil)
622 (def-std-html :dt t nil)
624 (def-std-html :em t nil)
625 (def-std-html :embed t nil)
627 (def-std-html :fieldset t nil)
628 (def-std-html :font t nil)
629 (def-std-html :form t :name)
630 (def-std-html :frame t nil)
631 (def-std-html :frameset t nil)
633 (def-std-html :h1 t nil)
634 (def-std-html :h2 t nil)
635 (def-std-html :h3 t nil)
636 (def-std-html :h4 t nil)
637 (def-std-html :h5 t nil)
638 (def-std-html :h6 t nil)
639 (def-std-html :head t nil)
640 (def-std-html :hr nil nil)
641 (def-std-html :html t nil)
643 (def-std-html :i t nil)
644 (def-std-html :iframe t nil)
645 (def-std-html :ilayer t nil)
646 (def-std-html :img nil :id)
647 (def-std-html :input nil nil)
648 (def-std-html :ins t nil)
649 (def-std-html :isindex nil nil)
651 (def-std-html :kbd t nil)
652 (def-std-html :keygen nil nil)
654 (def-std-html :label t nil)
655 (def-std-html :layer t nil)
656 (def-std-html :legend t nil)
657 (def-std-html :li t nil)
658 (def-std-html :link nil nil)
659 (def-std-html :listing t nil)
661 (def-std-html :map t nil)
662 (def-std-html :marquee t nil)
663 (def-std-html :menu t nil)
664 (def-std-html :meta nil nil)
665 (def-std-html :multicol t nil)
667 (def-std-html :nobr t nil)
668 (def-std-html :noembed t nil)
669 (def-std-html :noframes t nil)
670 (def-std-html :noscript t nil)
672 (def-std-html :object t nil)
673 (def-std-html :ol t nil)
674 (def-std-html :optgroup t nil)
675 (def-std-html :option t nil)
677 (def-std-html :p t nil)
678 (def-std-html :param t nil)
679 (def-std-html :plaintext nil nil)
680 (def-std-html :pre t nil)
682 (def-std-html :q t nil)
684 (def-std-html :s t nil)
685 (def-std-html :samp t nil)
686 (def-std-html :script t nil)
687 (def-std-html :select t nil)
688 (def-std-html :server t nil)
689 (def-std-html :small t nil)
690 (def-std-html :spacer nil nil)
691 (def-std-html :span t :id)
692 (def-std-html :strike t nil)
693 (def-std-html :strong t nil)
694 (def-std-html :style t nil)
695 (def-std-html :sub t nil)
696 (def-std-html :sup t nil)
698 (def-std-html :table t :name)
699 (def-std-html :tbody t nil)
700 (def-std-html :td t nil)
701 (def-std-html :textarea t nil)
702 (def-std-html :tfoot t nil)
703 (def-std-html :th t nil)
704 (def-std-html :thead t nil)
705 (def-std-html :title t nil)
706 (def-std-html :tr t nil)
707 (def-std-html :tt t nil)
709 (def-std-html :u t nil)
710 (def-std-html :ul t nil)
712 (def-std-html :var t nil)
714 (def-std-html :wbr nil nil)
716 (def-std-html :xmp t nil)
721 ;;; KMR Local Additions
723 (def-special-html :jscript
724 (named-function html-comment-function
725 (lambda (ent args argsp body)
726 ;; must use <!-- --> syntax
727 (declare (ignore ent args argsp))
729 (write-string "<script language=\"JavasSript\" type=\"text/javascript\">" *html-stream*)
730 (write-char #\newline *html-stream*)
731 (write-string "//![CDATA[" *html-stream*)
732 (write-char #\newline *html-stream*)
734 (write-char #\newline *html-stream*)
735 (write-string "//]]>" *html-stream*)
736 (write-char #\newline *html-stream*)
737 (write-string "</script>" *html-stream*))))
738 (named-function html-comment-print-function
739 (lambda (ent cmd args form subst unknown stream)
740 (declare (ignore ent cmd args subst unknown))
741 (format stream "<script language=\"JavaScript\" type=\"text/javascript\">~%//![CDATA[~%~A~%//]]>~%</script>"
744 (def-special-html :nbsp
745 (named-function html-nbsp-function
746 (lambda (ent args argsp body)
747 (declare (ignore ent args argsp))
749 (error "can't have a body with :nbsp -- body is ~s" body))
750 `(write-string " " *html-stream*)))
752 (named-function html-nbsp-print-function
753 (lambda (ent cmd args form subst unknown stream)
754 (declare (ignore args ent unknown subst))
756 then (write-string " " stream)
757 else (error ":nbsp in an illegal place: ~s" form)))))
759 (def-special-html :insert-file
760 (named-function html-nbsp-function
761 (lambda (ent args argsp body)
762 (declare (ignore ent args argsp))
764 (error "must have a body with :insert-file"))
765 `(lml-load-path (car ',body))))
767 (named-function html-nbsp-print-function
768 (lambda (ent cmd args form subst unknown stream)
769 (declare (ignore ent unknown subst stream args))
771 then (lml-load-path (cadr form))
772 else (error ":insert-file must be given an argument")))))