Uses a custom compiler no longer using FORMAT, thus escaping ~A won't be
authorMatthew Mondor <mmondor@pulsar-zone.net>
Fri, 19 Aug 2011 03:34:39 +0000 (03:34 +0000)
committerMatthew Mondor <mmondor@pulsar-zone.net>
Fri, 19 Aug 2011 03:34:39 +0000 (03:34 +0000)
necessary.

mmsoftware/cl/test/html.lisp

index 2156923..6bc589f 100644 (file)
@@ -1,4 +1,4 @@
-;;;; $Id: html.lisp,v 1.8 2011/08/19 02:32:39 mmondor Exp $
+;;;; $Id: html.lisp,v 1.9 2011/08/19 03:34:39 mmondor Exp $
 ;;;;
 ;;;; Test HTML+code template compiler
 ;;;; Copyright (c) 2011, Matthew Mondor
@@ -6,9 +6,6 @@
 
 ;;;; XXX TODO XXX
 ;;;; - HTML-safe escaping of general content, including XHTML oddities
-;;;; - Possibly also FORMAT directives safe escaping, in case we use
-;;;;   format internally with ~A general-purpose placeholders for non-HTML
-;;;;   atoms
 
 
 (defparameter *html-mode* :xhtml)
       (reverse out))))
 
 ;;; Optimizes the tree produced by HTML-PARSE-R, concatenating strings.
-;;; Also replaces any non-string by ~A for use with FORMAT, and returns
-;;; as first value the format string, with as second value the list of
-;;; FORMAT arguments.
-;;; XXX A potential problem might be the number of arguments, as we have
-;;; to basically APPLY FORMAT...
 (defun html-coalesce (list)
-  (let ((fmt "")
-       (args '())
+  (let ((out '())
        (last nil))
     (mapc
      #'(lambda (i)
-        (cond ((stringp i)
-               (setf fmt (concatenate 'string fmt i)))
-              (t
-               (setf fmt (concatenate 'string fmt "~A"))
-               (push i args))))
+         (let ((s (stringp i)))
+              (if (and last s)
+                         (rplaca out (concatenate 'string (car out) i))
+                                (progn
+                                   (setf last s)
+                                    (push i out)))))
      list)
-    (values fmt (reverse args))))
+    (reverse out)))
 
 ;;; Utility macro to generate easily HTML from Common Lisp code.
-;;; The HTML is converted to a string at compile-time, and the non-HTML
-;;; Lisp code sections are evaluated and substituted at runtime.
-;;; Internally, FORMAT is used.
+;;; The HTML template is converted to a list of strings and objects
+;;; at compile-time, and the non-HTML Lisp code objects are evaluated
+;;; at run-time.
 ;;; Note that tags and attributes are represented using keyword symbols and
 ;;; that sublists represent content.  Tags are automatically closed unless
 ;;; the tag symbol begins with a '/'.  Likewise, attributes without a value
 ;;; Literal text should be strings (enclosed in double quotes), and CL
 ;;; atoms and lists may be used as placeholders for dynamic content,
 ;;; and may be placed either as attribute values or in general content.
-(defmacro do-html-format (stream tree)
-  (multiple-value-bind (fmt args)
-      (html-coalesce (html-parse-r tree))
-    (append `(format ,stream ,fmt) args)))
+(defmacro do-html (stream tree)
+  (let ((list (html-coalesce (html-parse-r tree)))
+       (s-stream (gensym)))
+    (if stream
+       `(let ((,s-stream ,stream))
+          ,@(mapcar #'(lambda (i)
+                        (if (stringp i)
+                            `(write-string ,i ,s-stream)
+                            `(format ,s-stream "~A" ,i)))
+                    list)
+          nil)
+       `(with-output-to-string (,s-stream)
+          ,@(mapcar #'(lambda (i)
+                        (if (stringp i)
+                            `(write-string ,i ,s-stream)
+                            `(format ,s-stream "~A" ,i)))
+                    list)))))
 
 ;;; Utility macro for sane and easy loops within HTML constructs.
 (defmacro do-html-loop ((&body loop-clause) &body body)
        (loop
          ,@loop-clause
          do
-           (do-html-format ,s-stream
+           (do-html ,s-stream
              ,@body)))))
 
 
 
 ;;; Tests
 
+#+test
 (defun http-reply (code message &optional description)
   (let ((title (format nil "~A - ~A" code message)))
-    (do-html-format t
+    (do-html t
       (:html (:head (:title title))
             (:body
              (:h1 title)
              (if description
-                 (do-html-format nil
+                 (do-html nil
                    (:p description))
                  "")
              (:small (format nil "~A/~A"
                              (lisp-implementation-type)
                              (lisp-implementation-version))))))))
 
+#+test
 (defun random-page (&key (trs 10) (tds 10) (rnd 1000))
-  (do-html-format t
+  (do-html t
     (:html (:head (:title "Random page"))
           (:body
            (:h1 "Random page")
                (do-html-loop (repeat tds)
                  (:td (random rnd))))))))))
 
+#+test
 (defun results-page (list)
-  (do-html-format t
+  (do-html t
     (:html (:head (:title "Results"))
           (:body
            (:h1 "Results")