X-Git-Url: http://git.kpe.io/?p=lml2.git;a=blobdiff_plain;f=htmlgen.lisp;h=6a3650d69c84ca434533bcf6ab7c08ae179ed88a;hp=570caefee715ba1d0d064c1bb809198a6bdb789b;hb=94bfd48aa3a7f2e358bc873f992796030319acd2;hpb=f0cbce21a435156d5472222d0dbcd5ce7843b219

diff --git a/htmlgen.lisp b/htmlgen.lisp
index 570caef..6a3650d 100644
--- 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)))