r5312: *** empty log message ***

[lml2.git] / htmlgen.lisp

diff --git a/htmlgen.lisp b/htmlgen.lisp
index 570caefee715ba1d0d064c1bb809198a6bdb789b..6a3650d69c84ca434533bcf6ab7c08ae179ed88a 100644 (file)
--- a/htmlgen.lisp
+++ b/htmlgen.lisp
@@ -1,6 +1,6 @@
 ;; -*- mode: common-lisp; package: lml2 -*-
 ;;
-;; $Id: htmlgen.lisp,v 1.15 2003/07/15 19:25:28 kevin Exp $
+;; $Id: htmlgen.lisp,v 1.16 2003/07/15 21:49:36 kevin Exp $
 ;;
 ;; copyright (c) 1986-2000 Franz Inc, Berkeley, CA 
 ;; copyright (c) 2003 Kevin Rosenberg
@@ -12,6 +12,7 @@
 ;;    - 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
@@ -152,40 +153,51 @@
          (write-string  ,close *html-stream*)))
 
 
+(defun attribute-name-string (name)
+  (etypecase name
+    (symbol (string-downcase (symbol-name name)))
+    (string name)))
+
 (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
-      (: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))
+  (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"))
-       (push `(write-string ,(format nil " ~(~a~)" (first value))
-                           *html-stream*) res)
+       (mapcar (lambda (f) (push f res))
+              (write-attribute-name-forms (first value)))
        (push `(prin1-safe-http-string
-              (fformat nil ,(second value) ,@(cddr value)))
+              (format nil ,(second value) ,@(cddr value)))
             res))
       (:optional
        (let ((eval-if (gensym "EVAL-IF-")))
         (push `(let ((,eval-if ,(second value)))
                  (when ,eval-if
-                   (write-string
-                    ,(format nil " ~(~a~)" (first value))
-                    *html-stream*)
-                   (prin1-safe-http-string ,eval-if)))
+                    ,@(write-attribute-name-forms (first value))
+                    (prin1-safe-http-string ,eval-if)))
               res)))
       (:if
          (unless (and (listp value)
@@ -194,7 +206,7 @@
            (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*)
+                    ,@(write-attribute-name-forms (first value))
                     (prin1-safe-http-string 
                      (if ,eval-if
                          ,(third value)
@@ -205,14 +217,13 @@
                       (= (length value) 3))
            (error ":when must be given a list with 3 elements"))
        (push `(when ,(second value)
-                (write-string ,(format nil " ~(~a~)" (first value))
-                              *html-stream*)
+                ,@(write-attribute-name-forms (first value))
                 (prin1-safe-http-string ,(third value)))
              res))
       (t
-       (push `(write-string ,(format nil " ~(~a~)" name) *html-stream*)
-            res)
-       (push `(prin1-safe-http-string ,value) res)))))
+       (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
@@ -238,6 +249,7 @@
   (if args
       `(progn (write-string ,(format nil "<~a" string-code)
                            *html-stream*)
+
              ,@(process-attributes args)
              
              ,(unless has-inv `(write-string " /" *html-stream*))
@@ -305,8 +317,8 @@
 
 
 (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)))