r5308: *** empty log message ***
authorKevin M. Rosenberg <kevin@rosenberg.net>
Tue, 15 Jul 2003 16:52:23 +0000 (16:52 +0000)
committerKevin M. Rosenberg <kevin@rosenberg.net>
Tue, 15 Jul 2003 16:52:23 +0000 (16:52 +0000)
htmlgen.lisp

index 711fcc6..07548e7 100644 (file)
@@ -1,6 +1,6 @@
 ;; -*- 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 "&amp;")
        elseif (eq ch #\")
         then (setq cvt "&quot;"))
-      (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))))))