X-Git-Url: http://git.kpe.io/?p=lml2.git;a=blobdiff_plain;f=htmlgen.lisp;h=4fa517e3ad0179cb579ad8a04265341a713d97c2;hp=f77b6b6a344d94aef7256c16978cba53d7652d3b;hb=9c5e52ab7792dc7e57d02141c797d95b31b23039;hpb=5b4d4c25eef861d0602e327c556f3cfd788cb9be
diff --git a/htmlgen.lisp b/htmlgen.lisp
index f77b6b6..4fa517e 100644
--- a/htmlgen.lisp
+++ b/htmlgen.lisp
@@ -1,19 +1,22 @@
;; -*- mode: common-lisp; package: lml2 -*-
;;
-;; $Id: htmlgen.lisp,v 1.10 2003/06/25 21:24:09 kevin Exp $
+;; $Id$
;;
-;; copyright (c) 1986-2000 Franz Inc, Berkeley, CA
+;; copyright (c) 1986-2000 Franz Inc, Berkeley, CA
;; copyright (c) 2003 Kevin Rosenberg
;;
;; Main changes from Allegro version:
;; - Support XHTML end tags
;; - lowercase symbol names for attributes
-;; - Add custom tags such as :jscript, :insert-file, :nbsp
-;; - removal of if* macro -- partially complete
+;; - Add custom tags such as :jscript, :insert-file, :load-file, :nbsp
+;; - removal of if* macro
+;; - Add attribute conditions
+;; - Automatic conversion to strings for attribute values
+;; - Convert some comments to function doc strings
;;
;; 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 GNU Lesser General Public License as published by
;; the Free Software Foundation, as clarified by the LLGPL
@@ -21,14 +24,14 @@
(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
+ 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
@@ -36,13 +39,47 @@
)
-(defparameter *html-process-table*
+(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))
+ (post-process-html-forms
+ (process-html-forms forms env)))
+
+(defun post-process-html-forms (input-forms)
+ "KMR: Walk through forms and combine write-strings"
+ (let (res strs last-stream)
+ (flet ((flush-strings ()
+ (when strs
+ (push `(write-string ,strs ,last-stream) res)
+ (setq strs nil)
+ (setq last-stream nil))))
+ (do* ((forms input-forms (cdr forms))
+ (form (car forms) (car forms)))
+ ((null forms)
+ (flush-strings)
+ (nreverse res))
+ (cond
+ ((atom form)
+ (flush-strings)
+ (push form res))
+ ((and (eq (car form) 'cl:write-string)
+ (stringp (cadr form)))
+ (if strs
+ (if (eq last-stream (third form))
+ (setq strs (concatenate 'string strs (second form)))
+ (progn
+ (flush-strings)
+ (setq strs (second form))
+ (setq last-stream (third form))))
+ (progn
+ (setq strs (second form))
+ (setq last-stream (third form)))))
+ (t
+ (flush-strings)
+ (push (post-process-html-forms form) res)))))))
+
(defmacro html-out-stream-check (stream)
;; ensure that a real stream is passed to this function
@@ -61,151 +98,209 @@
(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)))))
-
-
+ ;; 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)
+ (cond
+ ((setq spec (html-process-special ent))
+ ;; do something different
+ (push (funcall spec ent args argsp body) res))
+ ((null argsp)
+ ;; singleton tag, just do the set
+ (push `(,(html-process-macro ent) :set) res)
+ nil)
+ (t
+ (cond ((equal args '(:unset))
+ ;; ((:tag :unset)) is a special case.
+ ;; that allows us to close off singleton tags
+ ;; printed earlier.
+ (push `(,(html-process-macro ent) :unset) res)
+ nil)
+ (t
+ ;; 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)
- (error "unknown html keyword ~s" form)
- (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)
- (error "unknown html keyword ~s" form)
- (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)
- (error "unknown html keyword ~s" form)
- (do-ent ent (cdr first) t (cdr form))))
- else (push form res))))))
+ (form (car xforms) (car xforms)))
+ ((null xforms))
+
+ (setq form (macroexpand form env))
+
+ (if (atom form)
+ (cond
+ ((keywordp form)
+ (let ((ent (gethash form *html-process-table*)))
+ (if (null ent)
+ (error "unknown html keyword ~s" form)
+ (do-ent ent nil nil nil))))
+ ((stringp form)
+ ;; turn into a print of it
+ (push `(write-string ,form *html-stream*) res))
+ (t
+ (push form res)))
+ (let ((first (car form)))
+ (cond
+ ((keywordp first)
+ ;; (:xxx . body) form
+ (let ((ent (gethash first
+ *html-process-table*)))
+ (if (null ent)
+ (error "unknown html keyword ~s" form)
+ (do-ent ent nil t (cdr form)))))
+ ((and (consp first) (keywordp (car first)))
+ ;; ((:xxx args ) . body)
+ (let ((ent (gethash (car first)
+ *html-process-table*)))
+ (if (null ent)
+ (error "unknown html keyword ~s" form)
+ (do-ent ent (cdr first) t (cdr form)))))
+ (t
+ (push form res)))))))
`(progn ,@(nreverse res))))
(defun html-atom-check (args open close body)
(when (and args (atom args))
(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)))))
+ (: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)
- (error "can't have a body form with this arg: ~s" args)
- ans))))
+ (error "can't have a body form with this arg: ~s" args)
+ 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*)))
-
+ ,@body
+ (write-string ,close *html-stream*)))
+
+
+(defun attribute-name-string (name)
+ (etypecase name
+ (symbol (string-downcase (symbol-name name)))
+ (string name)))
+
+(defun process-attributes (args)
+ (flet ((write-attribute-name-forms (name)
+ `((write-char #\space *html-stream*)
+ (write-string ,(attribute-name-string name)
+ *html-stream*)))
+ (write-separator-forms ()
+ '((write-char #\= *html-stream*)
+ (write-char #\" *html-stream*))))
+ (do* ((xx args (cddr xx))
+ (res)
+ (name (first xx) (first xx))
+ (value (second xx) (second xx)))
+ ((null xx)
+ (nreverse res))
+ (case name
+ (:fformat
+ (unless (and (listp value)
+ (>= (length value) 2))
+ (error ":fformat must be given a list at least 2 elements"))
+ (mapcar (lambda (f) (push f res))
+ (write-attribute-name-forms (first value)))
+ (mapcar (lambda (f) (push f res))
+ (write-separator-forms))
+ (push `(fformat *html-stream* ,(second value) ,@(cddr value))
+ res)
+ (push `(write-char #\" *html-stream*) res))
+ (:format
+ (unless (and (listp value) (>= (length value) 2))
+ (error ":format must be given a list at least 2 elements"))
+ (mapcar (lambda (f) (push f res))
+ (write-attribute-name-forms (first value)))
+ (push `(prin1-safe-http-string
+ (format nil ,(second value) ,@(cddr value)))
+ res))
+ (:optional
+ (let ((eval-if (gensym "EVAL-IF-")))
+ (push `(let ((,eval-if ,(second value)))
+ (when ,eval-if
+ ,@(write-attribute-name-forms (first value))
+ (prin1-safe-http-string ,eval-if)))
+ res)))
+ (:if
+ (unless (and (listp value)
+ (>= (length value) 3)
+ (<= (length value) 4))
+ (error ":if must be given a list with 3 and 4 elements"))
+ (let ((eval-if (gensym "EVAL-IF-")))
+ (push `(let ((,eval-if ,(second value)))
+ ,@(write-attribute-name-forms (first value))
+ (prin1-safe-http-string
+ (if ,eval-if
+ ,(third value)
+ ,(fourth value))))
+ res)))
+ (:when
+ (unless (and (listp value)
+ (= (length value) 3))
+ (error ":when must be given a list with 3 elements"))
+ (push `(when ,(second value)
+ ,@(write-attribute-name-forms (first value))
+ (prin1-safe-http-string ,(third value)))
+ res))
+ (t
+ (mapcar (lambda (f) (push f res))
+ (write-attribute-name-forms name))
+ (push `(prin1-safe-http-string ,value) res))))))
(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
(when (and args (atom args))
- ;; single arg
+ ;; single arg
(return-from html-body-key-form
(case args
- (:set (if has-inv
- `(write-string ,(format nil "<~a>" string-code)
- *html-stream*)
- `(write-string ,(format nil "<~a />" string-code)
- *html-stream*)))
- (:unset (when has-inv
- `(write-string ,(format nil "" string-code)
- *html-stream*)))
- (t (error "illegal arg ~s to ~s" args string-code)))))
-
+ (:set (if has-inv
+ `(write-string ,(format nil "<~a>" string-code)
+ *html-stream*)
+ `(write-string ,(format nil "<~a />" string-code)
+ *html-stream*)))
+ (:unset (when has-inv
+ `(write-string ,(format nil "" string-code)
+ *html-stream*)))
+ (t (error "illegal arg ~s to ~s" args string-code)))))
+
(unless (evenp (length args))
(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
- ,(when (and body has-inv)
- `(write-string ,(format nil "" string-code)
- *html-stream*)))
- else
- (if* has-inv
- then
- `(progn (write-string ,(format nil "<~a>" string-code)
- *html-stream*)
- ,@body
- ,(when body
- `(write-string ,(format nil "" string-code)
- *html-stream*)))
- else
- `(progn (write-string ,(format nil "<~a />" string-code)
- *html-stream*)))))
+
+
+ (if args
+ `(progn (write-string ,(format nil "<~a" string-code)
+ *html-stream*)
+
+ ,@(process-attributes args)
+
+ ,(unless has-inv `(write-string " /" *html-stream*))
+ (write-string ">" *html-stream*)
+ ,@body
+ ,(when (and body has-inv)
+ `(write-string ,(format nil "" string-code)
+ *html-stream*)))
+ (if has-inv
+ `(progn (write-string ,(format nil "<~a>" string-code)
+ *html-stream*)
+ ,@body
+ ,(when body
+ `(write-string ,(format nil "" string-code)
+ *html-stream*)))
+ `(progn (write-string ,(format nil "<~a />" string-code)
+ *html-stream*)))))
@@ -235,49 +330,50 @@
;; print the contents inside a string double quotes (which should
;; not be turned into "'s
;; symbols are turned into their name
+ ;;
+ ;; non-string and non-symbols are written to a string and quoted
+
(unless (and (symbolp val)
- (equal "" (symbol-name val)))
+ (equal "" (symbol-name val)))
(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))))
+ (when (not (or (stringp val)
+ (symbolp val)))
+ (setq val (write-to-string val)))
+ (if (or (stringp val)
+ (and (symbolp val)
+ (setq val (string-downcase
+ (symbol-name val)))))
+ (progn
+ (write-char #\" *html-stream*)
+ (emit-safe *html-stream* val)
+ (write-char #\" *html-stream*))
+ (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
+ "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)))
+ (start i)
+ (end (length string)))
((>= i end)
(when (< start i)
- (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
-
- (when (< start i)
- (write-sequence string stream :start start :end i))
- (write-string cvt stream)
-
- (setq start (1+ i))))))
-
-
+ (write-sequence string stream :start start :end i)))
+
+ (let* ((ch (schar string i))
+ (cvt (case ch
+ (#\< "<")
+ (#\> ">")
+ (#\& "&")
+ (#\" """))))
+ (when cvt
+ ;; must do a conversion, emit previous chars first
+ (when (< start i)
+ (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
@@ -298,88 +394,91 @@
(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
- (return-from html-print-subst
- (funcall unknown form stream))
- (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
- (when (consp (car form)) (cdr (car form)))
- form
- subst
- unknown
- stream)
- else (error "Illegal form: ~s" form))))
-
-
+ (attr-name)
+ (name)
+ (possible-kwd (cond
+ ((atom form) form)
+ ((consp (car form))
+ (setq attrs (cdar form))
+ (caar form))
+ (t (car form))))
+ print-handler
+ ent)
+ (when (keywordp possible-kwd)
+ (if (null (setq ent (gethash possible-kwd *html-process-table*)))
+ (if unknown
+ (return-from html-print-subst
+ (funcall unknown form stream))
+ (error "unknown html tag: ~s" possible-kwd))
+ ;; see if we should subst
+ (when (and subst
+ attrs
+ (setq attr-name (html-process-name-attr ent))
+ (setq name (getf attrs attr-name))
+ (setq attrs (html-find-value name subst)))
+ (return-from html-print-subst
+ (if (functionp (cdr attrs))
+ (funcall (cdr attrs) stream)
+ (html-print-subst
+ (cdr attrs)
+ subst
+ stream
+ unknown)))))
+
+ (setq print-handler
+ (html-process-print ent)))
+
+ (cond
+ ((atom form)
+ (cond
+ ((keywordp form)
+ (funcall print-handler ent :set nil nil nil nil stream))
+ ((stringp form)
+ (write-string form stream))
+ (t
+ (princ form stream))))
+ (ent
+ (funcall print-handler
+ ent
+ :full
+ (when (consp (car form)) (cdr (car form)))
+ form
+ subst
+ unknown
+ stream))
+ (t
+ (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))
+ (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
- (when (cdr entlist)
- (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
- (setq alist (pop to-process))
- (return))))))
+ (ent (car entlist) (car entlist)))
+ ((null entlist) (setq alist nil))
+ (cond
+ ((consp (car ent))
+ ;; this is another alist
+ (when (cdr entlist)
+ (push (cdr entlist) to-process))
+ (setq alist ent)
+ (return)) ; exit do*
+ ((equal key (car ent))
+ (return-from html-find-value ent))))
+
+ (when (null alist)
+ ;; we need to find a new alist to process
+ (if to-process
+ (setq alist (pop to-process))
+ (return))))))
(defun html-standard-print (ent cmd args form subst unknown stream)
;; the print handler for the normal html operators
@@ -388,42 +487,43 @@
(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)))
+ (if args
+ (cond
+ ((and (setq iter (getf args :iter))
+ (setq iter (html-find-value iter subst)))
+ ;; 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))
+ (t
+ (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 ">")))
+ (format stream "<~a>" (html-process-key ent)))
(dolist (ff (cdr form))
- (html-print-subst ff subst stream unknown)))
+ (html-print-subst ff subst stream unknown)))
(when (html-process-has-inverse ent)
;; 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
@@ -433,34 +533,34 @@
;; 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
+;; :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*)
+ ;; 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)))
@@ -468,91 +568,91 @@
(declare (ignore name))
`(function ,@body))
-
-(def-special-html :newline
+
+(def-special-html :newline
(named-function html-newline-function
(lambda (ent args argsp body)
- (declare (ignore ent args argsp))
- (when body
- (error "can't have a body with :newline -- body is ~s" body))
- `(terpri *html-stream*)))
-
+ (declare (ignore ent args argsp))
+ (when body
+ (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)
- (terpri stream)
- (error ":newline in an illegal place: ~s" form)))))
+ (terpri stream)
+ (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))))
-
+ (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)
- (format stream "~a" (cadr form))
- (error ":princ must be given an argument")))))
+ (format stream "~a" (cadr form))
+ (error ":princ must be given an argument")))))
-(def-special-html :princ-safe
+(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))))
+ (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)
- (emit-safe stream (format nil "~a" (cadr form)))
- (error ":princ-safe must be given an argument")))))
+ (emit-safe stream (format nil "~a" (cadr form)))
+ (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))))
+ (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)
- (format stream "~s" (cadr form))
- (error ":prin1 must be given an argument")))))
+ (format stream "~s" (cadr form))
+ (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))))
+ (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)
- (emit-safe stream (format nil "~s" (cadr form)))
- (error ":prin1-safe must be given an argument")))))
+ (emit-safe stream (format nil "~s" (cadr form)))
+ (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*))))
+ ;; 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))
@@ -562,17 +662,17 @@
(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))))
+ (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)))))
+ (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)
@@ -635,72 +735,72 @@
(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 :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 :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 :map t nil)
(def-std-html :marquee t nil)
-(def-std-html :menu t nil)
-(def-std-html :meta nil 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 :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 :object t nil)
+(def-std-html :ol t nil)
(def-std-html :optgroup t nil)
-(def-std-html :option t nil)
+(def-std-html :option t nil)
-(def-std-html :p t nil)
-(def-std-html :param 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 :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 :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 :u t nil)
+(def-std-html :ul t nil)
-(def-std-html :var t nil)
+(def-std-html :var t nil)
-(def-std-html :wbr nil nil)
+(def-std-html :wbr nil nil)
-(def-std-html :xmp t nil)
+(def-std-html :xmp t nil)
@@ -710,86 +810,111 @@
(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*))))
+ ;; must use syntax
+ (declare (ignore ent args argsp))
+ `(progn
+ #+ignore
+ (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)))))
+ (format stream ""
+ (cadr form)))))
-(def-special-html :nbsp
+(def-special-html :nbsp
(named-function html-nbsp-function
(lambda (ent args argsp body)
- (declare (ignore ent args argsp))
- (when body
- (error "can't have a body with :nbsp -- body is ~s" body))
- `(write-string " " *html-stream*)))
-
+ (declare (ignore ent args argsp))
+ (when body
+ (error "can't have a body with :nbsp -- body is ~s" body))
+ `(write-string " " *html-stream*)))
+
(named-function html-nbsp-print-function
(lambda (ent cmd args form subst unknown stream)
(declare (ignore args ent unknown subst))
(if (eq cmd :set)
- (write-string " " stream)
- (error ":nbsp in an illegal place: ~s" form)))))
+ (write-string " " stream)
+ (error ":nbsp in an illegal place: ~s" form)))))
-(def-special-html :insert-file
+
+(def-special-html :load-file
(named-function html-nbsp-function
(lambda (ent args argsp body)
- (declare (ignore ent args argsp))
- (unless body
- (error "must have a body with :insert-file"))
- `(progn ,@(mapcar #'(lambda (bod)
- `(lml-load-path ,bod))
- body))))
-
+ (declare (ignore ent args argsp))
+ (unless body
+ (error "must have a body with :load-file"))
+ `(progn ,@(mapcar #'(lambda (bod)
+ `(lml-load ,bod))
+ body))))
+
(named-function html-nbsp-print-function
(lambda (ent cmd args form subst unknown stream)
(declare (ignore ent unknown subst stream args))
(assert (eql 2 (length form)))
(if (eq cmd :full)
- (lml-load-path (cadr form))
- (error ":insert-file must be given an argument")))))
+ (lml-load (cadr form))
+ (error ":load-file must be given an argument")))))
+(def-special-html :insert-file
+ (named-function html-nbsp-function
+ (lambda (ent args argsp body)
+ (declare (ignore ent args argsp))
+ (unless body
+ (error "must have a body with :insert-file"))
+ `(progn ,@(mapcar #'(lambda (bod)
+ `(insert-file ,bod))
+ body))))
+
+ (named-function html-nbsp-print-function
+ (lambda (ent cmd args form subst unknown stream)
+ (declare (ignore ent unknown subst stream args))
+ (assert (eql 2 (length form)))
+ (if (eq cmd :full)
+ (insert-file (cadr form))
+ (error ":insert-file must be given an argument")))))
(def-special-html :write-string
(named-function html-write-string-function
(lambda (ent args argsp body)
- (declare (ignore ent args argsp))
- `(progn ,@(mapcar #'(lambda (bod)
- `(write-string ,bod *html-stream*))
- body))))
-
+ (declare (ignore ent args argsp))
+ (if (= (length body) 1)
+ `(write-string ,(car body) *html-stream*)
+ `(progn ,@(mapcar #'(lambda (bod)
+ `(write-string ,bod *html-stream*))
+ body)))))
+
(named-function html-write-string-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)
- (write-string (cadr form) stream)
- (error ":write-string must be given an argument")))))
+ (write-string (cadr form) stream)
+ (error ":write-string must be given an argument")))))
(def-special-html :write-char
(named-function html-write-char-function
(lambda (ent args argsp body)
- (declare (ignore ent args argsp))
- `(progn ,@(mapcar #'(lambda (bod)
- `(write-char ,bod *html-stream*))
- body))))
-
+ (declare (ignore ent args argsp))
+ `(progn ,@(mapcar #'(lambda (bod)
+ `(write-char ,bod *html-stream*))
+ body))))
+
(named-function html-write-char-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)
- (write-char (cadr form) stream)
- (error ":write-char must be given an argument")))))
+ (write-char (cadr form) stream)
+ (error ":write-char must be given an argument")))))
+
+
+