;; -*- mode: common-lisp; package: lml2 -*-
;;
-;; $Id: htmlgen.lisp,v 1.13 2003/07/15 04:28:56 kevin Exp $
+;; $Id: htmlgen.lisp,v 1.14 2003/07/15 16:52:23 kevin Exp $
;;
;; copyright (c) 1986-2000 Franz Inc, Berkeley, CA
;; copyright (c) 2003 Kevin Rosenberg
(write-string ,close *html-stream*)))
+(defun process-attributes (args)
+ (do* ((xx args (cddr xx))
+ (res)
+ (name (first xx) (first xx))
+ (value (second xx) (second xx)))
+ ((null xx)
+ (nreverse res))
+ (case name
+ (:if*
+ (push `(if* ,value
+ then (write-string ,(format nil " ~(~a~)" (third xx))
+ *html-stream*)
+ (prin1-safe-http-string ,(fourth xx)))
+ res)
+ (pop xx) (pop xx))
+ (:fformat
+ (unless (and (listp value)
+ (>= (length value) 2))
+ (error ":fformat must be given a list at least 2 elements"))
+ (push `(write-string
+ ,(format nil " ~(~a~)=\"" (first value))
+ *html-stream*) res)
+ (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"))
+ (push `(write-string ,(format nil " ~(~a~)" (first value))
+ *html-stream*) res)
+ (push `(prin1-safe-http-string
+ (fformat nil ,(second value) ,@(cddr value)))
+ res))
+ (:optional
+ (push `(when ,(second value)
+ (write-string
+ ,(format nil " ~(~a~)" (first value))
+ *html-stream*)
+ (prin1-safe-http-string ,(second value)))
+ 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-string ,(format nil " ~(~a~)" (first value)) *html-stream*)
+ (prin1-safe-http-string
+ (if ,eval-if
+ ,(third value)
+ ,(fourth value))))
+ res)))
+ (t
+ (push `(write-string ,(format nil " ~(~a~)" name) *html-stream*)
+ res)
+ (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
(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)
- elseif (eq :fformat (car xx))
- then
- ;; process :fformat
- (unless (and (listp (cadr xx))
- (>= (length (cadr xx)) 2))
- (error ":fformat must be given a list"))
- (push
- `(write-string
- ,(format nil " ~(~a~)=\"" (car (cadr xx)))
- *html-stream*)
- res)
- (push
- `(fformat *html-stream* ,(cadr (cadr xx))
- ,@(cddr (cadr xx)))
- res)
- (push '(write-char #\" *html-stream*) res)
- elseif (eq :optional (car xx))
- then
- (push
- `(when ,(cadr (cadr xx))
- (write-string
- ,(format nil " ~(~a~)=\"" (car (cadr xx)))
- *html-stream*)
- (fformat *html-stream* "~A\""
- ,(cadr (cadr xx))))
- res)
- 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 "</~a>" 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 "</~a>" 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 "</~a>" string-code)
+ *html-stream*)))
+ (if has-inv
+ `(progn (write-string ,(format nil "<~a>" string-code)
+ *html-stream*)
+ ,@body
+ ,(when body
+ `(write-string ,(format nil "</~a>" string-code)
+ *html-stream*)))
+ `(progn (write-string ,(format nil "<~a />" string-code)
+ *html-stream*)))))
(unless (and (symbolp 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))))
+ (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)
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)
+ (when cvt
+ ;; must do a conversion, emit previous chars first
- (setq start (1+ i))))))
+ (when (< start i)
+ (write-sequence string stream :start start :end i))
+ (write-string cvt stream)
+
+ (setq start (1+ i))))))
projects / lml2.git / commitdiff