From 22a45b79c0f32b1ef64031caa7ab50e73c121f58 Mon Sep 17 00:00:00 2001 From: Edi Weitz Date: Mon, 9 Mar 2009 21:59:07 +0000 Subject: Dev version git-svn-id: svn://bknr.net/svn/trunk/thirdparty/cl-who@4336 4281704c-cde7-0310-8518-8e2dc76b1ff0 --- CHANGELOG | 12 ++ cl-who.asd | 18 ++- doc/index.html | 109 ++++++++-------- packages.lisp | 6 +- specials.lisp | 22 ++-- test/packages.lisp | 34 +++++ test/simple | 240 ++++++++++++++++++++++++++++++++++ test/tests.lisp | 150 ++++++++++++++++++++++ util.lisp | 230 +++++++++++++++++++++++++++++++++ who.lisp | 370 ++++++++++++++--------------------------------------- 10 files changed, 839 insertions(+), 352 deletions(-) create mode 100644 test/packages.lisp create mode 100644 test/simple create mode 100644 test/tests.lisp create mode 100644 util.lisp diff --git a/CHANGELOG b/CHANGELOG index 34aef45..5cd4524 100644 --- a/CHANGELOG +++ b/CHANGELOG @@ -1,3 +1,15 @@ +Version 1.0.0 +2009-0x-xx +Refactored internals and made STR etc. local macros +Added test suite + todo: repla s-h-texp with walk in docs +Removed deprecated ESCAPE-STRING-ISO-8859 function +Removed SHOW-HTML-EXPANSION + +Version 0.11.1 +2008-03-28 +Replaced T with t to be friendly to AllegroCL's "modern" mode (thanks to John Maraist) + Version 0.11.0 2007-08-24 Replaces *DOWNCASE-TAGS-P* with *DOWNCASE-TOKENS-P* (thanks to Osei Poku) diff --git a/cl-who.asd b/cl-who.asd index 814fc5a..a1432e7 100644 --- a/cl-who.asd +++ b/cl-who.asd @@ -1,7 +1,7 @@ ;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*- -;;; $Header: /usr/local/cvsrep/cl-who/cl-who.asd,v 1.18 2007/08/24 08:01:37 edi Exp $ +;;; $Header: /usr/local/cvsrep/cl-who/cl-who.asd,v 1.24 2009/01/26 11:10:49 edi Exp $ -;;; Copyright (c) 2003-2007, Dr. Edmund Weitz. All rights reserved. +;;; Copyright (c) 2003-2009, Dr. Edmund Weitz. All rights reserved. ;;; Redistribution and use in source and binary forms, with or without ;;; modification, are permitted provided that the following conditions @@ -28,8 +28,20 @@ ;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. (asdf:defsystem :cl-who - :version "0.11.0" + :version "0.11.1" :serial t :components ((:file "packages") (:file "specials") + (:file "util") (:file "who"))) + +(defsystem :cl-who-test + :depends-on (:cl-who :flexi-streams) + :components ((:module "test" + :serial t + :components ((:file "packages") + (:file "tests"))))) + +(defmethod perform ((o test-op) (c (eql (find-system :cl-who)))) + (operate 'load-op :cl-who-test) + (funcall (intern (symbol-name :run-all-tests) (find-package :cl-who-test)))) diff --git a/doc/index.html b/doc/index.html index 62a5bfd..91c9ec6 100644 --- a/doc/index.html +++ b/doc/index.html @@ -48,7 +48,7 @@ href="http://weitz.de/html-template/">HTML-TEMPLATE. I wrote this one in 2002 although at least Tim Bradshaw's htout and AllegroServe's -HTML generation facilities by John Foderaro of Franz Inc. where +HTML generation facilities by John Foderaro of Franz Inc. were readily available. Actually, I don't remember why I had to write my own library - maybe just because it was fun and didn't take very long. The syntax was obviously inspired by htout although it is slightly @@ -60,8 +60,7 @@ CL-WHO macros will usually be a sequence of WRITE-STRING forms for constant parts of the output interspersed with arbitrary code inserted by the user of the macro. CL-WHO will make sure that there aren't two adjacent WRITE-STRING forms with -constant strings - see -examples below. CL-WHO's output is +constant strings. CL-WHO's output is either XHTML (default) or 'plain' (SGML) HTML — depending on what you've set HTML-MODE to.

@@ -74,7 +73,7 @@ It comes with a BSD-style license so you can basically do with it whatever you want.

-CL-WHO is used by clutu, ERGO, and Heike Stephan. +CL-WHO is for example used by clutu and Heike Stephan.

Download shortcut: http://weitz.de/files/cl-who.tar.gz. @@ -90,7 +89,6 @@ CL-WHO is used by clutu, with-html-output

  • with-html-output-to-string -
  • show-html-expansion
  • *attribute-quote-char*
  • *prologue*
  • *html-empty-tag-aware-p* @@ -106,7 +104,6 @@ CL-WHO is used by clutu, *escape-char-p*
  • escape-string-minimal
  • escape-string-minimal-plus-quotes -
  • escape-string-iso-8859
  • escape-string-iso-8859-1
  • escape-string-all
  • escape-char-minimal @@ -146,7 +143,7 @@ together with the Lisp code generated by CL-WHO and the resulting HTML output. 
    -;; Code generated by CL-WHO
+;; code generated by CL-WHO (simplified)
 
 (let ((*http-stream* *http-stream*))
   (progn
@@ -185,7 +182,7 @@ together with the Lisp code generated by CL-WHO and the resulting HTML output.
 
 
 
    -;; Code generated by CL-WHO
+;; code generated by CL-WHO (simplified)
 
 (let ((*http-stream* *http-stream*))
   (progn
@@ -226,7 +223,7 @@ together with the Lisp code generated by CL-WHO and the resulting HTML output.
 
 
 
    -;; Code generated by CL-WHO
+;; code generated by CL-WHO (simplified)
 
 (let ((*http-stream* *http-stream*))
   (progn
@@ -256,9 +253,9 @@ together with the Lisp code generated by CL-WHO and the resulting HTML output.
 
 CL-WHO together with this documentation can be downloaded from http://weitz.de/files/cl-who.tar.gz. The
-current version is 0.11.0.
+current version is 0.2.0.
 
    
-The preferred method to compile and load Hunchentoot is via ASDF.
+The preferred method to compile and load CL-WHO is via ASDF.
 
    
 If you're on Debian you can
 probably use
@@ -274,6 +271,12 @@ Luís Oliveira maintains a darcs
 repository of CL-WHO
 at http://common-lisp.net/~loliveira/ediware/.
+
    
+You can run a test suite which tests some (but
+not all) aspects of the library with
+
    +(asdf:oos 'asdf:test-op :cl-who)
+
    
 
 
     
    Support and mailing lists
    
 
@@ -343,7 +346,7 @@ is transformed into an (X)HTML tag of the same (usually 
    (:table :border 3) => (write-string "<table border='3' />" s)
    
 
-         
  • If it is any other form it will be left as is and later evaluated at run time and printed with If it is any other form it will be left as is and later evaluated at run time and printed like with PRINC unless the value is T or NIL which will be treated as above. (It is the application developer's job to provide the correct printer control variables.)
 
   
    ;; simplified example, see function CHECKBOX below
@@ -403,11 +406,10 @@ CHECKBOX
 
 
    :hr => (write-string "<hr />" s)
    
 
-  
  • A form which is neither a string nor a keyword nor a list beginning with a keyword will be left as is except for the following substitutions:
+  
  • A form which is neither a string nor a keyword nor a list beginning with a keyword will be left as is except for the following local macros:
     
      
-      
    • Forms that look like (str form1 form*) will be substituted with
-	  (let ((result form1)) (when result (princ result s))). 
      
-	  (Note that all forms behind form1 are ignored.)
+      
    • Forms that look like (str form) will be substituted with
+	  (let ((result form)) (when result (princ result s))).
 
 
      (loop for i below 10 do (str i)) => 
 (loop for i below 10 do
@@ -417,10 +419,10 @@ CHECKBOX
       
    • Forms that look like (fmt form*) will be substituted with (format s form*).
 
 
      (loop for i below 10 do (fmt "~R" i)) => (loop for i below 10 do (format s "~R" i))
      
-      
    • Forms that look like (esc form1 form*) will be substituted with
-	  (let ((result form1)) (when result (write-string (escape-string result s)))).
+      
    • Forms that look like (esc form) will be substituted with
+	  (let ((result form)) (when result (write-string (escape-string result s)))).
 
-      
    • If a form looks like (htm form*) then each of the forms will be subject to the transformation rules we're just describing.
+      
    • If a form looks like (htm form*) then each of the forms will be subject to the transformation rules we're just describing, i.e. this is the body is wrapped with another invocation of WITH-HTML-OUTPUT.
 
 
      (loop for i below 100 do (htm (:b "foo") :br))
     => (loop for i below 100 do (progn (write-string "<b>foo</b><br />" s)))
      
@@ -438,8 +440,35 @@ CL-WHO exports the following symbols:
 

      [Macro]
 
      with-html-output (var &optional stream &key prologue indent) declaration* form* => result*
 
-

      
-This is the main macro of CL-WHO. It will transform its body by the transformation rules described in Syntax and Semantics such that the output generated is sent to the stream denoted by var and stream. var must be a symbol. If stream is NIL it is assumed that var is already bound to a stream, if stream is not NIL var will be bound to the form stream which will be evaluated at run time. prologue should be a string (or NIL for the empty string which is the default) which is guaranteed to be the first thing sent to the stream from within the body of this macro. If prologue is T the prologue string is the value of *PROLOGUE*. CL-WHO will usually try not to insert any unnecessary whitespace in order to save bandwidth. However, if indent is true line breaks will be inserted and nested tags will be intended properly. The value of indent - if it is an integer - will be taken as the initial indentation. If it is not an integer it is assumed to mean 0. The results are the values returned by the forms.
+

       This is the main macro of CL-WHO. It will transform
+its body by the transformation rules described
+in Syntax and Semantics such that the
+output generated is sent to the stream denoted
+by var
+and stream. var must be a
+symbol. If stream is NIL it is
+assumed that var is already bound to a stream,
+if stream is
+not NIL var will be bound to the
+form stream which will be evaluated at run
+time. prologue should be a string
+(or NIL for the empty string which is the default) which
+is guaranteed to be the first thing sent to the stream from within the
+body of this macro. If prologue is T
+the prologue string is the value
+of *PROLOGUE*. CL-WHO will
+usually try not to insert any unnecessary whitespace in order to save
+bandwidth. However, if indent is true
+line breaks will be inserted and nested tags will be indented
+properly. The value of indent - if it is an
+integer - will be taken as the initial indentation. If it is not an
+integer it is assumed to mean 0. (But note that
+indentation might change the semantics of the generated HTML.  This is
+for example the case for the PRE
+and TEXTAREA tags, and in certain situations additional
+whitespace might also change the layout of tables.)
+The results are the values returned by
+the forms.
 
      
 Note that the keyword arguments prologue and indent are used at macro expansion time.
 
@@ -473,7 +502,7 @@ Note that the keyword arguments prologue and indent
 This is just a thin wrapper around WITH-HTML-OUTPUT. Indeed, the wrapper is so thin that the best explanation probably is to show its definition:
 
       (defmacro with-html-output-to-string ((var &optional string-form
-                                           &key (element-type 'character)
+                                           &key (element-type ''character)
                                                 prologue
                                                 indent)
                                       &body body)
@@ -486,34 +515,6 @@ into Lisp code which creates the corresponding HTML as a string."
 Note that the results of this macro are determined by the behaviour of WITH-OUTPUT-TO-STRING.
 
      
 
-

      [Macro]
-
      show-html-expansion (var &optional stream &key prologue indent) declaration* form* =>  <no values>
-
-

      
-This macro is intended for debugging purposes. It'll print to *STANDARD-OUTPUT* the code which would have been generated by WITH-HTML-OUTPUT had it been invoked with the same arguments.
-
-
      -* (show-html-expansion (s)
-    (:html
-     (:body :bgcolor "white"
-      (:table
-       (:tr
-        (dotimes (i 5)
-          (htm (:td :align "left"
-                (str i)))))))))
-(LET ((S S))
-  (PROGN
-    (WRITE-STRING
-      "<html><body bgcolor='white'><table><tr>" S)
-    (DOTIMES (I 5)
-      (PROGN
-        (WRITE-STRING "<td align='left'>" S)
-        (PRINC I S)
-        (WRITE-STRING "</td>" S)))
-    (WRITE-STRING "</tr></table></body></html>" S)))
-
      
-
      
-
 

      [Special variable]
 
      *attribute-quote-char*
 
@@ -629,8 +630,6 @@ This is the default for the test keyword argument to [Function]
 
      escape-string-iso-8859-1 string => escaped-string
 
      [Function]
-
      escape-string-iso-8859 string => escaped-string
-
      [Function]
 
      escape-string-all string => escaped-string
 
      [Function]
 
      escape-char-minimal character => escaped-string
@@ -661,10 +660,6 @@ functions are defined in a way similar to this one:
                                   (or (find char "<>&'\"")
                                       (> (char-code char) 255)))))
 
-(defun escape-string-iso-8859 (string)
-  "Identical to ESCAPE-STRING-ISO-8859-1.  Kept for backward compatibility."
-  (escape-string-iso-8859-1 string))
-
 (defun escape-string-all (string)
   "Escapes all characters in STRING which aren't in the 7-bit ASCII
 character set."
@@ -800,7 +795,7 @@ Thanks to Stefan Scholl for the 'old school' patch.  Thanks to Mac
 Chan for several useful additions.
 
 
      
-$Header: /usr/local/cvsrep/cl-who/doc/index.html,v 1.58 2007/08/24 08:01:40 edi Exp $
+$Header: /usr/local/cvsrep/cl-who/doc/index.html,v 1.68 2009/03/09 21:54:11 edi Exp $
 
      BACK TO MY HOMEPAGE
 
 
diff --git a/packages.lisp b/packages.lisp
index 1d9bdec..89d56de 100644
--- a/packages.lisp
+++ b/packages.lisp
@@ -1,7 +1,7 @@
 ;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*-
-;;; $Header: /usr/local/cvsrep/cl-who/packages.lisp,v 1.17 2007/08/24 08:01:37 edi Exp $
+;;; $Header: /usr/local/cvsrep/cl-who/packages.lisp,v 1.21 2009/01/26 11:10:49 edi Exp $
 
-;;; Copyright (c) 2003-2007, Dr. Edmund Weitz. All rights reserved.
+;;; Copyright (c) 2003-2009, Dr. Edmund Weitz. All rights reserved.
 
 ;;; Redistribution and use in source and binary forms, with or without
 ;;; modification, are permitted provided that the following conditions
@@ -50,14 +50,12 @@
            :escape-char-minimal-plus-quotes
            :escape-string
            :escape-string-all
-           :escape-string-iso-8859
            :escape-string-iso-8859-1
            :escape-string-minimal
            :escape-string-minimal-plus-quotes
            :fmt
            :htm
            :html-mode
-           :show-html-expansion
            :str
            :with-html-output
            :with-html-output-to-string))
diff --git a/specials.lisp b/specials.lisp
index 2df1adb..71aad3c 100755
--- a/specials.lisp
+++ b/specials.lisp
@@ -1,7 +1,7 @@
 ;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package:CL-WHO; Base: 10 -*-
-;;; $Header: /usr/local/cvsrep/cl-who/specials.lisp,v 1.2 2007/08/24 08:01:37 edi Exp $
+;;; $Header: /usr/local/cvsrep/cl-who/specials.lisp,v 1.6 2009/01/26 11:10:49 edi Exp $
 
-;;; Copyright (c) 2003-2007, Dr. Edmund Weitz. All rights reserved.
+;;; Copyright (c) 2003-2009, Dr. Edmund Weitz. All rights reserved.
 
 ;;; Redistribution and use in source and binary forms, with or without
 ;;; modification, are permitted provided that the following conditions
@@ -40,13 +40,13 @@
   "This is the first line that'll be printed if the :PROLOGUE keyword
 argument is T")
 
-(defparameter *escape-char-p*
-  #'(lambda (char)
-      (or (find char "<>&'\"")
-          (> (char-code char) 127)))
+(defvar *escape-char-p*
+  (lambda (char)
+    (or (find char "<>&'\"")
+        (> (char-code char) 127)))
   "Used by ESCAPE-STRING to test whether a character should be escaped.")
 
-(defparameter *indent* nil
+(defvar *indent* nil
   "Whether to insert line breaks and indent. Also controls amount of
 indentation dynamically.")
 
@@ -58,13 +58,13 @@ indentation dynamically.")
 not be automatically converted to lowercase.  This is useful when one
 needs to output case sensitive XML.")
 
-(defparameter *attribute-quote-char* #\'
+(defvar *attribute-quote-char* #\'
   "Quote character for attributes.")
 
-(defparameter *empty-tag-end* " />"
+(defvar *empty-tag-end* " />"
   "End of an empty tag.  Default is XML style.")
 
-(defparameter *html-empty-tags*
+(defvar *html-empty-tags*
   '(:area
     :atop
     :audioscope
@@ -96,7 +96,7 @@ needs to output case sensitive XML.")
   "The list of HTML tags that should be output as empty tags.
 See *HTML-EMPTY-TAG-AWARE-P*.")
 
-(defvar *html-empty-tag-aware-p* T
+(defvar *html-empty-tag-aware-p* t
   "Set this to NIL to if you want to use CL-WHO as a strict XML
 generator.  Otherwise, CL-WHO will only write empty tags listed
 in *HTML-EMPTY-TAGS* as  \(XHTML mode) or  \(SGML
diff --git a/test/packages.lisp b/test/packages.lisp
new file mode 100644
index 0000000..b41a38e
--- /dev/null
+++ b/test/packages.lisp
@@ -0,0 +1,34 @@
+;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*-
+;;; $Header: /usr/local/cvsrep/cl-who/test/packages.lisp,v 1.3 2009/01/26 11:10:52 edi Exp $
+
+;;; Copyright (c) 2008-2009, Dr. Edmund Weitz. All rights reserved.
+
+;;; Redistribution and use in source and binary forms, with or without
+;;; modification, are permitted provided that the following conditions
+;;; are met:
+
+;;;   * Redistributions of source code must retain the above copyright
+;;;     notice, this list of conditions and the following disclaimer.
+
+;;;   * Redistributions in binary form must reproduce the above
+;;;     copyright notice, this list of conditions and the following
+;;;     disclaimer in the documentation and/or other materials
+;;;     provided with the distribution.
+
+;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED
+;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
+;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+;;; ARE DISCLAIMED.  IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY
+;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
+;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
+;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
+;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
+;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
+;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
+;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+
+(in-package :cl-user)
+
+(defpackage :cl-who-test
+  (:use :cl :cl-who)
+  (:export :run-all-tests))
\ No newline at end of file
diff --git a/test/simple b/test/simple
new file mode 100644
index 0000000..128c62b
--- /dev/null
+++ b/test/simple
@@ -0,0 +1,240 @@
+;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-WHO-TEST; Base: 10 -*-
+;;; $Header: /usr/local/cvsrep/cl-who/test/simple,v 1.4 2009/01/26 11:10:52 edi Exp $
+
+;;; some simple tests for CL-WHO - entered manually and to be read
+;;; in the CL-WHO-TEST package; all forms are expected to return a
+;;; true value on success when EVALuated
+
+(string= (with-output-to-string (out)
+           (with-html-output (out)
+             (loop for (link . title) in '(("http://zappa.com/" . "Frank Zappa")
+                                           ("http://marcusmiller.com/" . "Marcus Miller")
+                                           ("http://www.milesdavis.com/" . "Miles Davis"))
+                   do (htm (:a :href link
+                            (:b (str title)))
+                           :br))))
+         "Frank Zappa
      Marcus Miller
      Miles Davis
      ")
+
+(string= (with-output-to-string (out)
+           (with-html-output (out nil)
+             (loop for (link . title) in '(("http://zappa.com/" . "Frank Zappa")
+                                           ("http://marcusmiller.com/" . "Marcus Miller")
+                                           ("http://www.milesdavis.com/" . "Miles Davis"))
+                   do (htm (:a :href link
+                            (:b (str title)))
+                           :br))))
+         "Frank Zappa
      Marcus Miller
      Miles Davis
      ")
+
+(string= (with-output-to-string (foo)
+           (with-html-output (out foo)
+             (loop for (link . title) in '(("http://zappa.com/" . "Frank Zappa")
+                                           ("http://marcusmiller.com/" . "Marcus Miller")
+                                           ("http://www.milesdavis.com/" . "Miles Davis"))
+                   do (htm (:a :href link
+                            (:b (str title)))
+                           :br))))
+         "Frank Zappa
      Marcus Miller
      Miles Davis
      ")
+
+(string= (with-html-output-to-string (out)
+           (loop for (link . title) in '(("http://zappa.com/" . "Frank Zappa")
+                                         ("http://marcusmiller.com/" . "Marcus Miller")
+                                         ("http://www.milesdavis.com/" . "Miles Davis"))
+                 do (htm (:a :href link
+                          (:b (str title)))
+                         :br)))
+         "Frank Zappa
      Marcus Miller
      Miles Davis
      ")
+
+(string= (with-html-output-to-string (out nil)
+           (loop for (link . title) in '(("http://zappa.com/" . "Frank Zappa")
+                                         ("http://marcusmiller.com/" . "Marcus Miller")
+                                         ("http://www.milesdavis.com/" . "Miles Davis"))
+                 do (htm (:a :href link
+                          (:b (str title)))
+                         :br)))
+         "Frank Zappa
      Marcus Miller
      Miles Davis
      ")
+
+(string= (with-html-output-to-string (out nil :prologue nil)
+           (loop for (link . title) in '(("http://zappa.com/" . "Frank Zappa")
+                                         ("http://marcusmiller.com/" . "Marcus Miller")
+                                         ("http://www.milesdavis.com/" . "Miles Davis"))
+                 do (htm (:a :href link
+                          (:b (str title)))
+                         :br)))
+         "Frank Zappa
      Marcus Miller
      Miles Davis
      ")
+
+(eq (array-element-type
+     (with-html-output-to-string (out nil :element-type 'base-char)
+       (:br)))
+    'base-char)
+
+(string= (let ((*attribute-quote-char* #\"))
+           (with-html-output-to-string (out)
+             (loop for (link . title) in '(("http://zappa.com/" . "Frank Zappa")
+                                           ("http://marcusmiller.com/" . "Marcus Miller")
+                                           ("http://www.milesdavis.com/" . "Miles Davis"))
+                   do (htm (:a :href link
+                            (:b (str title)))
+                           :br))))
+         "Frank Zappa
      Marcus Miller
      Miles Davis
      ")
+
+(string= (with-html-output-to-string (out nil :prologue t)
+           (loop for (link . title) in '(("http://zappa.com/" . "Frank Zappa")
+                                         ("http://marcusmiller.com/" . "Marcus Miller")
+                                         ("http://www.milesdavis.com/" . "Miles Davis"))
+                 do (htm (:a :href link
+                          (:b (str title)))
+                         :br)))
+         "
+Frank Zappa
      Marcus Miller
      Miles Davis
      ")
+
+(string= (with-html-output-to-string
+             (out nil :prologue "")
+           (:apply (:factorial) (:cn "3")))
+         "
+3")
+
+(string= (let ((*prologue* ""))
+           (with-html-output-to-string (out nil :prologue t)
+             (:apply (:factorial) (:cn "3"))))
+         "
+3")
+
+(string= (with-html-output-to-string (out nil :indent t)
+           (loop for (link . title) in '(("http://zappa.com/" . "Frank Zappa")
+                                         ("http://marcusmiller.com/" . "Marcus Miller")
+                                         ("http://www.milesdavis.com/" . "Miles Davis"))
+                 do (htm (:a :href link
+                          (:b (str title)))
+                         :br)))
+         "
+
+  Frank Zappa
+  
+
+
      
+
+  Marcus Miller
+  
+
+
      
+
+  Miles Davis
+  
+
+
      ")
+
+(string= (with-html-output-to-string (out nil :indent 0)
+           (loop for (link . title) in '(("http://zappa.com/" . "Frank Zappa")
+                                         ("http://marcusmiller.com/" . "Marcus Miller")
+                                         ("http://www.milesdavis.com/" . "Miles Davis"))
+                 do (htm (:a :href link
+                          (:b (str title)))
+                         :br)))
+         "
+
+  Frank Zappa
+  
+
+
      
+
+  Marcus Miller
+  
+
+
      
+
+  Miles Davis
+  
+
+
      ")
+
+(string= (with-html-output-to-string (out nil :indent 3)
+           (loop for (link . title) in '(("http://zappa.com/" . "Frank Zappa")
+                                         ("http://marcusmiller.com/" . "Marcus Miller")
+                                         ("http://www.milesdavis.com/" . "Miles Davis"))
+                 do (htm (:a :href link
+                          (:b (str title)))
+                         :br)))
+         "
+   
+     Frank Zappa
+     
+   
+   
      
+   
+     Marcus Miller
+     
+   
+   
      
+   
+     Miles Davis
+     
+   
+   
      ")
+
+(string= (with-html-output-to-string (out)
+           (:table :border 0 :cellpadding 4
+            (loop for i below 25 by 5
+                  do (htm
+                      (:tr :align "right"
+                       (loop for j from i below (+ i 5)
+                             do (htm
+                                 (:td :bgcolor (if (oddp j)
+                                                 "pink"
+                                                 "green")
+                                  (fmt "~@R" (1+ j))))))))))
+         "
      IIIIIIIVV
      VIVIIVIIIIXX
      XIXIIXIIIXIVXV
      XVIXVIIXVIIIXIXXX
      XXIXXIIXXIIIXXIVXXV
      ")
+
+(string= (with-html-output-to-string (out)
+           (:h4 "Look at the character entities generated by this example")
+           (loop for i from 0
+                 for string in '("Fête" "Sørensen" "naïve" "Hühner" "Straße")
+                 do (htm
+                     (:p :style (conc "background-color:" (case (mod i 3)
+                                                            ((0) "red")
+                                                            ((1) "orange")
+                                                            ((2) "blue")))
+                      (htm (esc string))))))
+         "
      Look at the character entities generated by this example
      Fête
      Sørensen
      naïve
      Hühner
      Straße
      ")
+
+(flet ((checkbox (stream name checked &optional value)
+         (with-html-output (stream)
+           (:input :type "checkbox" :name name :checked checked :value value))))
+  (and (string= (with-output-to-string (s) (checkbox s "foo" t))
+                "")
+       (string= (with-output-to-string (s) (checkbox s "foo" nil))
+                "")
+       (string= (with-output-to-string (s) (checkbox s "foo" nil "bar"))
+                "")
+       (string= (with-output-to-string (s) (checkbox s "foo" t "bar"))         
+                "")))
+
+(string= (with-html-output-to-string (out)
+           (:p))
+         "
      ")
+
+(string= (let ((*html-empty-tag-aware-p* nil))
+           (with-html-output-to-string (out)
+             (:p)))
+         "
      ")
+
+(string= (let ((*html-empty-tag-aware-p* t)
+               (*html-empty-tags* '(:p)))
+           (with-html-output-to-string (out)
+             (:p)))
+         "
      ")
+
+(string= (with-html-output-to-string (out)
+           (:|Foo| :bar 42))
+         "")
+
+(string= (let ((*downcase-tokens-p* nil))
+           (with-html-output-to-string (out)
+             (:|Foo| :bar 42)))
+         "")
+
+(string= (let* ((list (list (make-string-output-stream) (make-string-output-stream)))
+                (stream (first list)))
+           (with-html-output (var (pop list))
+             (progn (htm (:br))))
+           (get-output-stream-string stream))
+         "
      ")
\ No newline at end of file
diff --git a/test/tests.lisp b/test/tests.lisp
new file mode 100644
index 0000000..44ea411
--- /dev/null
+++ b/test/tests.lisp
@@ -0,0 +1,150 @@
+;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package:CL-WHO-TEST; Base: 10 -*-
+;;; $Header: /usr/local/cvsrep/cl-who/test/tests.lisp,v 1.5 2009/01/26 11:10:52 edi Exp $
+
+;;; Copyright (c) 2008-2009, Dr. Edmund Weitz. All rights reserved.
+
+;;; Redistribution and use in source and binary forms, with or without
+;;; modification, are permitted provided that the following conditions
+;;; are met:
+
+;;;   * Redistributions of source code must retain the above copyright
+;;;     notice, this list of conditions and the following disclaimer.
+
+;;;   * Redistributions in binary form must reproduce the above
+;;;     copyright notice, this list of conditions and the following
+;;;     disclaimer in the documentation and/or other materials
+;;;     provided with the distribution.
+
+;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED
+;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
+;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+;;; ARE DISCLAIMED.  IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY
+;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
+;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
+;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
+;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
+;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
+;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
+;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+
+(in-package :cl-who-test)
+
+(defvar *initial-settings*
+  (list #\'
+        t
+        (lambda (char)
+          (or (find char "<>&'\"")
+              (> (char-code char) 127)))
+        t
+        '(:area
+          :atop
+          :audioscope
+          :base
+          :basefont
+          :br
+          :choose
+          :col
+          :frame
+          :hr
+          :img
+          :input
+          :isindex
+          :keygen
+          :left
+          :limittext
+          :link
+          :meta
+          :nextid
+          :of
+          :over
+          :param
+          :range   
+          :right
+          :spacer
+          :spot
+          :tab
+          :wbr)
+        ""))
+
+(defvar *this-file* (load-time-value
+                     (or #.*compile-file-pathname* *load-pathname*))
+  "The location of this source file.")
+
+(defmacro do-tests ((name &optional show-progress-p) &body body)
+  "Helper macro which repeatedly executes BODY until the code in body
+calls the function DONE.  It is assumed that each invocation of BODY
+will be the execution of one test which returns NIL in case of success
+and list of string describing errors otherwise.
+
+The macro prints a simple progress indicator \(one dots for ten tests)
+to *STANDARD-OUTPUT* unless SHOW-PROGRESS-P is NIL and returns a true
+value iff all tests succeeded.  Errors in BODY are caught and reported
+\(and counted as failures)."
+  `(let ((successp t)
+         (testcount 1))
+     (block test-block
+       (flet ((done ()
+                (return-from test-block successp)))
+         (format t "~&Test: ~A~%" ,name)
+         (loop
+          (when (and ,show-progress-p (zerop (mod testcount 1)))
+            (format t ".")
+            (when (zerop (mod testcount 10))
+              (terpri))
+            (force-output))
+          (let ((errors
+                 (handler-case
+                     (progn ,@body)
+                   (error (msg)
+                     (list (format nil "~&got an unexpected error: ~A" msg))))))
+            (setq successp (and successp (null errors)))
+            (when errors
+              (format t "~&~4@A:~{~&   ~A~}~%" testcount errors))
+            (incf testcount)))))
+     successp))
+
+(defun simple-tests (&key (file-name
+                           (make-pathname :name "simple"
+                                          :type nil :version nil
+                                          :defaults *this-file*))
+                          (external-format '(:latin-1 :eol-style :lf))
+                          verbose)
+  "Loops through all the forms in the file FILE-NAME and executes each
+of them using EVAL.  It is assumed that each FORM specifies a test
+which returns a true value iff it succeeds.  Prints each test form to
+*STANDARD-OUTPUT* if VERBOSE is true and shows a simple progress
+indicator otherwise.  EXTERNAL-FORMAT is the FLEXI-STREAMS external
+format which is used to read the file.  Returns a true value iff all
+tests succeeded."
+  (with-open-file (binary-stream file-name :element-type 'flex:octet)
+    (let ((stream (flex:make-flexi-stream binary-stream :external-format external-format))
+          (*package* (find-package :cl-who-test))
+          (html-mode (html-mode)))
+      (unwind-protect
+          (destructuring-bind (*attribute-quote-char*
+                               *downcase-tokens-p*
+                               *escape-char-p*
+                               *html-empty-tag-aware-p*
+                               *html-empty-tags*
+                               *prologue*)
+              *initial-settings*
+            (setf (html-mode) :xml)
+            (do-tests ((format nil "Simple tests from file ~S" (file-namestring file-name))
+                       (not verbose))
+              (let ((form (or (read stream nil) (done))))
+                (when verbose
+                  (format t "~&~S" form))
+                (cond ((eval form) nil)
+                      (t (list (format nil "~S returned NIL" form)))))))
+        (setf (html-mode) html-mode)))))
+
+(defun run-all-tests (&key verbose)
+  "Runs all tests for CL-WHO and returns a true value iff all tests
+succeeded.  VERBOSE is interpreted by the individual test suites."
+  (let ((successp t))
+    (macrolet ((run-test-suite (&body body)
+                 `(unless (progn ,@body)
+                    (setq successp nil))))
+      (run-test-suite (simple-tests :verbose verbose)))
+    (format t "~2&~:[Some tests failed~;All tests passed~]." successp)
+    successp))
\ No newline at end of file
diff --git a/util.lisp b/util.lisp
new file mode 100644
index 0000000..aee8efe
--- /dev/null
+++ b/util.lisp
@@ -0,0 +1,230 @@
+;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package:CL-WHO; Base: 10 -*-
+;;; $Header: /usr/local/cvsrep/cl-who/util.lisp,v 1.4 2009/01/26 11:10:49 edi Exp $
+
+;;; Copyright (c) 2003-2009, Dr. Edmund Weitz. All rights reserved.
+
+;;; Redistribution and use in source and binary forms, with or without
+;;; modification, are permitted provided that the following conditions
+;;; are met:
+
+;;;   * Redistributions of source code must retain the above copyright
+;;;     notice, this list of conditions and the following disclaimer.
+
+;;;   * Redistributions in binary form must reproduce the above
+;;;     copyright notice, this list of conditions and the following
+;;;     disclaimer in the documentation and/or other materials
+;;;     provided with the distribution.
+
+;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED
+;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
+;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+;;; ARE DISCLAIMED.  IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY
+;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
+;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
+;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
+;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
+;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
+;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
+;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+
+(in-package :cl-who)
+
+#+:lispworks
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (import 'lw:with-unique-names))
+
+#-:lispworks
+(defmacro with-unique-names ((&rest bindings) &body body)
+  "Syntax: WITH-UNIQUE-NAMES ( { var | (var x) }* ) declaration* form*
+
+Executes a series of forms with each VAR bound to a fresh,
+uninterned symbol. The uninterned symbol is as if returned by a call
+to GENSYM with the string denoted by X - or, if X is not supplied, the
+string denoted by VAR - as argument.
+
+The variable bindings created are lexical unless special declarations
+are specified. The scopes of the name bindings and declarations do not
+include the Xs.
+
+The forms are evaluated in order, and the values of all but the last
+are discarded \(that is, the body is an implicit PROGN)."
+  ;; reference implementation posted to comp.lang.lisp as
+  ;;  by Vebjorn Ljosa - see also
+  ;; 
+  `(let ,(mapcar #'(lambda (binding)
+                     (check-type binding (or cons symbol))
+                     (if (consp binding)
+                       (destructuring-bind (var x) binding
+                         (check-type var symbol)
+                         `(,var (gensym ,(etypecase x
+                                          (symbol (symbol-name x))
+                                          (character (string x))
+                                          (string x)))))
+                       `(,binding (gensym ,(symbol-name binding)))))
+                 bindings)
+         ,@body))
+
+#+:lispworks
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (setf (macro-function 'with-rebinding)
+          (macro-function 'lw:rebinding)))
+
+#-:lispworks
+(defmacro with-rebinding (bindings &body body)
+  "WITH-REBINDING ( { var | (var prefix) }* ) form*
+
+Evaluates a series of forms in the lexical environment that is
+formed by adding the binding of each VAR to a fresh, uninterned
+symbol, and the binding of that fresh, uninterned symbol to VAR's
+original value, i.e., its value in the current lexical environment.
+
+The uninterned symbol is created as if by a call to GENSYM with the
+string denoted by PREFIX - or, if PREFIX is not supplied, the string
+denoted by VAR - as argument.
+
+The forms are evaluated in order, and the values of all but the last
+are discarded \(that is, the body is an implicit PROGN)."
+  ;; reference implementation posted to comp.lang.lisp as
+  ;;  by Vebjorn Ljosa - see also
+  ;; 
+  (loop for binding in bindings
+        for var = (if (consp binding) (car binding) binding)
+        for name = (gensym)
+        collect `(,name ,var) into renames
+        collect ``(,,var ,,name) into temps
+        finally (return `(let ,renames
+                          (with-unique-names ,bindings
+                            `(let (,,@temps)
+                              ,,@body))))))
+
+;; TODO...
+#+(or)
+(defun apply-to-tree (function test tree)
+  (declare (optimize speed space))
+  (declare (type function function test))
+  "Applies FUNCTION recursively to all elements of the tree TREE \(not
+only leaves) which pass TEST."
+  (cond
+    ((funcall test tree)
+      (funcall function tree))
+    ((consp tree)
+      (cons
+       (apply-to-tree function test (car tree))
+       (apply-to-tree function test (cdr tree))))
+    (t tree)))
+
+(defmacro n-spaces (n)
+  "A string with N spaces - used by indentation."
+  `(make-array ,n
+               :element-type 'base-char
+               :displaced-to +spaces+
+               :displaced-index-offset 0))
+
+(declaim (inline escape-char))
+(defun escape-char (char &key (test *escape-char-p*))
+  (declare (optimize speed))
+  "Returns an escaped version of the character CHAR if CHAR satisfies
+the predicate TEST.  Always returns a string."
+  (if (funcall test char)
+    (case char
+      (#\< "<")
+      (#\> ">")
+      (#\& "&")
+      (#\' "'")
+      (#\" """)
+      (t (format nil (if (eq *html-mode* :xml) "&#x~x;" "&#~d;")
+                 (char-code char))))
+    (make-string 1 :initial-element char)))
+
+(defun escape-string (string &key (test *escape-char-p*))
+  (declare (optimize speed))
+  "Escape all characters in STRING which pass TEST. This function is
+not guaranteed to return a fresh string.  Note that you can pass NIL
+for STRING which'll just be returned."
+  (let ((first-pos (position-if test string))
+        (format-string (if (eq *html-mode* :xml) "&#x~x;" "&#~d;")))
+    (if (not first-pos)
+      ;; nothing to do, just return STRING
+      string
+      (with-output-to-string (s)
+        (loop with len = (length string)
+              for old-pos = 0 then (1+ pos)
+              for pos = first-pos
+                  then (position-if test string :start old-pos)
+              ;; now the characters from OLD-POS to (excluding) POS
+              ;; don't have to be escaped while the next character has to
+              for char = (and pos (char string pos))
+              while pos
+              do (write-sequence string s :start old-pos :end pos)
+                 (case char
+                   ((#\<)
+                     (write-sequence "<" s))
+                   ((#\>)
+                     (write-sequence ">" s))
+                   ((#\&)
+                     (write-sequence "&" s))
+                   ((#\')
+                     (write-sequence "'" s))
+                   ((#\")
+                     (write-sequence """ s))
+                   (otherwise
+                     (format s format-string (char-code char))))
+              while (< (1+ pos) len)
+              finally (unless pos
+                        (write-sequence string s :start old-pos)))))))
+
+(defun minimal-escape-char-p (char)
+  "Helper function for the ESCAPE-FOO-MINIMAL functions to determine
+whether CHAR must be escaped."
+  (find char "<>&"))
+
+(defun escape-char-minimal (char)
+  "Escapes only #\<, #\>, and #\& characters."
+  (escape-char char :test #'minimal-escape-char-p))
+
+(defun escape-string-minimal (string)
+  "Escapes only #\<, #\>, and #\& in STRING."
+  (escape-string string :test #'minimal-escape-char-p))
+
+(defun minimal-plus-quotes-escape-char-p (char)
+  "Helper function for the ESCAPE-FOO-MINIMAL-PLUS-QUOTES functions to
+determine whether CHAR must be escaped."
+  (find char "<>&'\""))
+
+(defun escape-char-minimal-plus-quotes (char)
+  "Like ESCAPE-CHAR-MINIMAL but also escapes quotes."
+  (escape-char char :test #'minimal-plus-quotes-escape-char-p))
+
+(defun escape-string-minimal-plus-quotes (string)
+  "Like ESCAPE-STRING-MINIMAL but also escapes quotes."
+  (escape-string string :test #'minimal-plus-quotes-escape-char-p))
+
+(defun iso-8859-1-escape-char-p (char)
+  "Helper function for the ESCAPE-FOO-ISO-8859-1 functions to
+determine whether CHAR must be escaped."
+  (or (find char "<>&'\"")
+      (> (char-code char) 255)))
+
+(defun escape-char-iso-8859-1 (char)
+  "Escapes characters that aren't defined in ISO-8859-9."
+  (escape-char char :test #'iso-8859-1-escape-char-p))
+
+(defun escape-string-iso-8859-1 (string)
+  "Escapes all characters in STRING which aren't defined in ISO-8859-1."
+  (escape-string string :test #'iso-8859-1-escape-char-p))
+
+(defun non-7bit-ascii-escape-char-p (char)
+  "Helper function for the ESCAPE-FOO-ISO-8859-1 functions to
+determine whether CHAR must be escaped."
+  (or (find char "<>&'\"")
+      (> (char-code char) 127)))
+
+(defun escape-char-all (char)
+  "Escapes characters which aren't in the 7-bit ASCII character set."
+  (escape-char char :test #'non-7bit-ascii-escape-char-p))
+
+(defun escape-string-all (string)
+  "Escapes all characters in STRING which aren't in the 7-bit ASCII
+character set."
+  (escape-string string :test #'non-7bit-ascii-escape-char-p))
+
diff --git a/who.lisp b/who.lisp
index f154427..39ce788 100644
--- a/who.lisp
+++ b/who.lisp
@@ -1,7 +1,7 @@
 ;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package:CL-WHO; Base: 10 -*-
-;;; $Header: /usr/local/cvsrep/cl-who/who.lisp,v 1.35 2007/08/24 08:01:37 edi Exp $
+;;; $Header: /usr/local/cvsrep/cl-who/who.lisp,v 1.42 2009/01/26 11:10:49 edi Exp $
 
-;;; Copyright (c) 2003-2007, Dr. Edmund Weitz. All rights reserved.
+;;; Copyright (c) 2003-2009, Dr. Edmund Weitz. All rights reserved.
 
 ;;; Redistribution and use in source and binary forms, with or without
 ;;; modification, are permitted provided that the following conditions
@@ -29,15 +29,8 @@
 
 (in-package :cl-who)
 
-(defmacro n-spaces (n)
-  "A string with N spaces - used by indentation."
-  `(make-array ,n
-               :element-type 'base-char
-               :displaced-to +spaces+
-               :displaced-index-offset 0))
-
 (defun html-mode ()
-  "Returns the current HTML mode. :SGML for (SGML-)HTML and
+  "Returns the current HTML mode. :SGML for \(SGML-)HTML and
 :XML for XHTML."
   *html-mode*)
 
@@ -54,100 +47,6 @@
            *empty-tag-end* " />"
            *prologue* ""))))
 
-(declaim (inline escape-char))
-(defun escape-char (char &key (test *escape-char-p*))
-  (declare (optimize speed))
-  "Returns an escaped version of the character CHAR if CHAR satisfies
-the predicate TEST.  Always returns a string."
-  (if (funcall test char)
-    (case char
-      (#\< "<")
-      (#\> ">")
-      (#\& "&")
-      (#\' "'")
-      (#\" """)
-      (t (format nil (if (eq *html-mode* :xml) "&#x~x;" "&#~d;")
-                 (char-code char))))
-    (make-string 1 :initial-element char)))
-
-(defun escape-string (string &key (test *escape-char-p*))
-  (declare (optimize speed))
-  "Escape all characters in STRING which pass TEST. This function is
-not guaranteed to return a fresh string.  Note that you can pass NIL
-for STRING which'll just be returned."
-  (let ((first-pos (position-if test string))
-        (format-string (if (eq *html-mode* :xml) "&#x~x;" "&#~d;")))
-    (if (not first-pos)
-      ;; nothing to do, just return STRING
-      string
-      (with-output-to-string (s)
-        (loop with len = (length string)
-              for old-pos = 0 then (1+ pos)
-              for pos = first-pos
-                  then (position-if test string :start old-pos)
-              ;; now the characters from OLD-POS to (excluding) POS
-              ;; don't have to be escaped while the next character has to
-              for char = (and pos (char string pos))
-              while pos
-              do (write-sequence string s :start old-pos :end pos)
-                 (case char
-                   ((#\<)
-                     (write-sequence "<" s))
-                   ((#\>)
-                     (write-sequence ">" s))
-                   ((#\&)
-                     (write-sequence "&" s))
-                   ((#\')
-                     (write-sequence "'" s))
-                   ((#\")
-                     (write-sequence """ s))
-                   (otherwise
-                     (format s format-string (char-code char))))
-              while (< (1+ pos) len)
-              finally (unless pos
-                        (write-sequence string s :start old-pos)))))))
-
-(flet ((minimal-escape-char-p (char) (find char "<>&")))
-  (defun escape-char-minimal (char)
-    "Escapes only #\<, #\>, and #\& characters."
-    (escape-char char :test #'minimal-escape-char-p))
-  (defun escape-string-minimal (string)
-    "Escapes only #\<, #\>, and #\& in STRING."
-    (escape-string string :test #'minimal-escape-char-p)))
-
-(flet ((minimal-plus-quotes-escape-char-p (char) (find char "<>&'\"")))
-  (defun escape-char-minimal-plus-quotes (char)
-    "Like ESCAPE-CHAR-MINIMAL but also escapes quotes."
-    (escape-char char :test #'minimal-plus-quotes-escape-char-p))
-  (defun escape-string-minimal-plus-quotes (string)
-    "Like ESCAPE-STRING-MINIMAL but also escapes quotes."
-    (escape-string string :test #'minimal-plus-quotes-escape-char-p)))
-
-(flet ((iso-8859-1-escape-char-p (char)
-         (or (find char "<>&'\"")
-             (> (char-code char) 255))))
-  (defun escape-char-iso-8859-1 (char)
-    "Escapes characters that aren't defined in ISO-8859-9."
-    (escape-char char :test #'iso-8859-1-escape-char-p))
-  (defun escape-string-iso-8859-1 (string)
-    "Escapes all characters in STRING which aren't defined in ISO-8859-1."
-    (escape-string string :test #'iso-8859-1-escape-char-p)))
-
-(defun escape-string-iso-8859 (string)
-  "Identical to ESCAPE-STRING-8859-1.  Kept for backward compatibility."
-  (escape-string-iso-8859-1 string))
-
-(flet ((non-7bit-ascii-escape-char-p (char)
-         (or (find char "<>&'\"")
-             (> (char-code char) 127))))
-  (defun escape-char-all (char)
-    "Escapes characters which aren't in the 7-bit ASCII character set."
-    (escape-char char :test #'non-7bit-ascii-escape-char-p))
-  (defun escape-string-all (string)
-    "Escapes all characters in STRING which aren't in the 7-bit ASCII
-character set."
-    (escape-string string :test #'non-7bit-ascii-escape-char-p)))
-
 (defun process-tag (sexp body-fn)
   (declare (optimize speed space))
   "Returns a string list corresponding to the `HTML' \(in CL-WHO
@@ -184,7 +83,6 @@ alist ATTR-LIST of attributes into a list of strings and/or Lisp
 forms."
   (declare (optimize speed space))
   (loop with =var= = (gensym)
-        with attribute-quote = (string *attribute-quote-char*)
         for (orig-attr . val) in attr-list
         for attr = (if *downcase-tokens-p*
                      (string-downcase orig-attr)
@@ -199,19 +97,14 @@ forms."
                           attr
                           (format nil "=~C" *attribute-quote-char*)
                           ;; value of attribute
-                          (cond ((stringp val)
-                                 ;; a string, just use it - this case is
-                                 ;; actually not necessary because of
-                                 ;; the last case
-                                 val)
-                                ((eq val t)
+                          (cond ((eq val t)
                                  ;; VAL is T, use attribute's name
                                  attr)
                                 (t
                                  ;; constant form, PRINC it -
                                  ;; EVAL is OK here because of CONSTANTP
                                  (format nil "~A" (eval val))))
-                          attribute-quote)
+                          (string *attribute-quote-char*))
             end
           else
             ;; do the same things as above but at runtime
@@ -219,19 +112,21 @@ forms."
                           (cond ((null ,=var=))
                                 ((eq ,=var= t) 
                                  ,(case *html-mode*
-                                        (:sgml
-                                         `(htm ,(format nil " ~A" attr)))
-                                        ;; otherwise default to :xml mode
-                                        (t
-                                         `(htm ,(format nil " ~A=~C~A~C"
-                                                        attr
-                                                        *attribute-quote-char*
-                                                        attr
-                                                        *attribute-quote-char*)))))
+                                    (:sgml
+                                     `(fmt " ~A" attr))
+                                    ;; otherwise default to :xml mode
+                                    (t
+                                     `(fmt " ~A=~C~A~C"
+                                           ,attr
+                                           *attribute-quote-char*
+                                           ,attr
+                                           *attribute-quote-char*))))
                                 (t
-                                 (htm ,(format nil " ~A=~C" attr *attribute-quote-char*)
-                                      (str ,=var=)
-                                      ,attribute-quote)))))))
+                                 (fmt " ~A=~C~A~C"
+                                      ,attr
+                                      *attribute-quote-char*
+                                      ,=var=
+                                      *attribute-quote-char*)))))))
 
 (defgeneric convert-tag-to-string-list (tag attr-list body body-fn)
   (:documentation "Used by PROCESS-TAG to convert `HTML' into a list
@@ -275,53 +170,21 @@ can use EQL specializers on the first argument."
          (list *empty-tag-end*)
          (list ">" ""))))))
 
-(defun apply-to-tree (function test tree)
-  (declare (optimize speed space))
-  (declare (type function function test))
-  "Apply FUNCTION recursively to all elements of the tree TREE \(not
-only leaves) which pass TEST."
-  (cond
-    ((funcall test tree)
-      (funcall function tree))
-    ((consp tree)
-      (cons
-       (apply-to-tree function test (car tree))
-       (apply-to-tree function test (cdr tree))))
-    (t tree)))
-
-(defun replace-htm (tree transformation)
-  (declare (optimize speed space))
-  "Replace all subtrees of TREE starting with the symbol HTM with the
-same subtree after TRANSFORMATION has been applied to it. Utility
-function used by TREE-TO-TEMPLATE and TREE-TO-COMMANDS-AUX."
-  (apply-to-tree #'(lambda (element)
-                     (cons 'htm (funcall transformation (cdr element))))
-                 #'(lambda (element)
-                     (and (consp element)
-                          (eq (car element) 'htm)))
-                 tree))
-
 (defun tree-to-template (tree)
   "Transforms an HTML tree into an intermediate format - mainly a
 flattened list of strings. Utility function used by TREE-TO-COMMANDS-AUX."
   (loop for element in tree
-        nconc (cond ((or (keywordp element)
-                         (and (listp element)
-                              (keywordp (first element)))
-                         (and (listp element)
-                              (listp (first element))
-                              (keywordp (first (first element)))))
-                     ;; normal tag
-                     (process-tag element #'tree-to-template))
-                    ((listp element)
-                     ;; most likely a normal Lisp form - check if we
-                     ;; have nested HTM subtrees
-                     (list
-                      (replace-htm element #'tree-to-template)))
-                    (t
-                     (if *indent*
-                       (list +newline+ (n-spaces *indent*) element)
-                       (list element))))))
+        when (or (keywordp element)
+                 (and (listp element)
+                      (keywordp (first element)))
+                 (and (listp element)
+                      (listp (first element))
+                      (keywordp (first (first element)))))
+        ;; the syntax for a tag - process it
+        nconc (process-tag element #'tree-to-template)
+        else
+        ;; something else - insert verbatim
+        collect element))
 
 (defun string-list-to-string (string-list)
   (declare (optimize speed space))
@@ -331,7 +194,9 @@ flattened list of strings. Utility function used by TREE-TO-COMMANDS-AUX."
   (let ((total-size 0))
     (dolist (string string-list)
       (incf total-size (length string)))
-    (let ((result-string (make-sequence 'simple-string total-size))
+    (let ((result-string (make-string total-size
+                                      #+:lispworks #+:lispworks
+                                      :element-type 'lw:simple-char))
           (curr-pos 0))
       (dolist (string string-list)
         (replace result-string string :start1 curr-pos)
@@ -342,119 +207,83 @@ flattened list of strings. Utility function used by TREE-TO-COMMANDS-AUX."
   "Concatenates all arguments which should be string into one string."
   (funcall #'string-list-to-string string-list))
 
-(defun tree-to-commands-aux (tree stream)
+(defun tree-to-commands (tree stream &key prologue ((:indent *indent*) *indent*))
   (declare (optimize speed space))
-  "Transforms the intermediate representation of an HTML tree into
-Lisp code to print the HTML to STREAM. Utility function used by
-TREE-TO-COMMANDS."
-  (let ((in-string t)
+  (when (and *indent*
+             (not (integerp *indent*)))
+    (setq *indent* 0))
+  (let ((in-string-p t)
         collector
-        string-collector)
+        string-collector
+        (template (tree-to-template tree)))
+    (when prologue
+      (push +newline+ template)
+      (when (eq prologue t)
+        (setq prologue *prologue*))
+      (push prologue template))
     (flet ((emit-string-collector ()
              "Generate a WRITE-STRING statement for what is currently
 in STRING-COLLECTOR."
              (list 'write-string
                    (string-list-to-string (nreverse string-collector))
-                   stream))
-           (tree-to-commands-aux-internal (tree)
-             "Same as TREE-TO-COMMANDS-AUX but with closed-over STREAM
-for REPLACE-HTM."
-             (tree-to-commands-aux tree stream)))
-      (unless (listp tree)
-        (return-from tree-to-commands-aux tree))
-      (loop for element in tree
-            do (cond ((and in-string (stringp element))
-                       ;; this element is a string and the last one
-                       ;; also was (or this is the first element) -
-                       ;; collect into STRING-COLLECTOR
-                       (push element string-collector))
-                     ((stringp element)
-                       ;; the last one wasn't a string so we start
-                       ;; with an empty STRING-COLLECTOR
-                       (setq string-collector (list element)
-                             in-string t))
-                     (string-collector
-                       ;; not a string but STRING-COLLECTOR isn't
-                       ;; empty so we have to emit the collected
-                       ;; strings first
-                       (push (emit-string-collector) collector)
-                       (setq in-string nil
-                             string-collector '())
-                       ;; collect this element but walk down the
-                       ;; subtree first
-                       (push (replace-htm element #'tree-to-commands-aux-internal)
-                             collector))
-                     (t
-                       ;; not a string and empty STRING-COLLECTOR
-                       (push (replace-htm element #'tree-to-commands-aux-internal)
-                             collector)))
-            finally (return (if string-collector
-                              ;; finally empty STRING-COLLECTOR if
-                              ;; there's something in it
-                              (nreverse (cons (emit-string-collector)
-                                              collector))
-                              (nreverse collector)))))))
-
-(defun tree-to-commands (tree stream &optional prologue)
-  (declare (optimize speed space))
-  "Transforms an HTML tree into code to print the HTML to STREAM."
-  ;; use TREE-TO-TEMPLATE, then TREE-TO-COMMANDS-AUX, and finally
-  ;; replace the special symbols ESC, STR, FMT, and HTM
-  (apply-to-tree #'(lambda (x)
-                     (case (first x)
-                       ((esc)
-                        ;; (ESC form ...)
-                        ;; --> (LET ((RESULT form))
-                        ;;       (WHEN RESULT
-                        ;;         (WRITE-STRING (ESCAPE-STRING RESULT STREAM))))
-                        (let ((result (gensym)))
-                          `(let ((,result ,(second x)))
-                             (when ,result (write-string (escape-string ,result) ,stream)))))
-                       ((str)
-                        ;; (STR form ...)
-                        ;; --> (LET ((RESULT form))
-                        ;;       (WHEN RESULT (PRINC RESULT STREAM)))
-                        (let ((result (gensym)))
-                          `(let ((,result ,(second x)))
-                             (when ,result (princ ,result ,stream)))))
-                       ((fmt)
-                        ;; (FMT form*) --> (FORMAT STREAM form*)
-                        (list* 'format stream (rest x)))))
-                 #'(lambda (x)
-                     (and (consp x)
-                          (member (first x)
-                                  '(esc str fmt)
-                                  :test #'eq)))
-                 ;; wrap PROGN around the HTM forms
-                 (apply-to-tree (constantly 'progn)
-                                #'(lambda (x)
-                                    (and (atom x)
-                                         (eq x 'htm)))
-                                (tree-to-commands-aux
-                                 (if prologue
-                                   (list* 'htm prologue +newline+
-                                          (tree-to-template tree))
-                                   (cons 'htm (tree-to-template tree)))
-                                 stream))))
+                   stream)))
+      (dolist (element template)
+        (cond ((and in-string-p (stringp element))
+               ;; this element is a string and the last one
+               ;; also was (or this is the first element) -
+               ;; collect into STRING-COLLECTOR
+               (push element string-collector))
+              ((stringp element)
+               ;; the last one wasn't a string so we start
+               ;; with an empty STRING-COLLECTOR
+               (setq string-collector (list element)
+                     in-string-p t))
+              (string-collector
+               ;; not a string but STRING-COLLECTOR isn't
+               ;; empty so we have to emit the collected
+               ;; strings first
+               (push (emit-string-collector) collector)
+               (setq in-string-p nil
+                     string-collector '())
+               (push element collector))
+              (t
+               ;; not a string and empty STRING-COLLECTOR
+               (push element collector))))
+      (if string-collector
+        ;; finally empty STRING-COLLECTOR if
+        ;; there's something in it
+        (nreverse (cons (emit-string-collector)
+                        collector))
+        (nreverse collector)))))
 
 (defmacro with-html-output ((var &optional stream
-                                 &key prologue
-                                      ((:indent *indent*) *indent*))
+                                 &rest rest
+                                 &key prologue indent)
                             &body body)
   "Transform the enclosed BODY consisting of HTML as s-expressions
 into Lisp code to write the corresponding HTML as strings to VAR -
 which should either hold a stream or which'll be bound to STREAM if
 supplied."
-  (when (and *indent*
-             (not (integerp *indent*)))
-    (setq *indent* 0))
-  (when (eq prologue t)
-    (setq prologue *prologue*))
+  (declare (ignore prologue))
   `(let ((,var ,(or stream var)))
-    ,(tree-to-commands body var prologue)))
+     (macrolet ((htm (&body body)
+                  `(with-html-output (,',var nil :prologue nil :indent ,,indent)
+                     ,@body))
+                (fmt (&rest args)                        
+                  `(format ,',var ,@args))
+                (esc (thing)
+                  (with-unique-names (result)
+                    `(let ((,result ,thing))
+                       (when ,result (write-string (escape-string ,result) ,',var)))))
+                (str (thing)
+                  (with-unique-names (result)
+                    `(let ((,result ,thing))
+                       (when ,result (princ ,result ,',var))))))
+       ,@(apply 'tree-to-commands body var rest))))
 
 (defmacro with-html-output-to-string ((var &optional string-form
-                                           &key (element-type ''character)
+                                           &key (element-type #-:lispworks ''character
+                                                              #+:lispworks ''lw:simple-char)
                                                 prologue
                                                 indent)
                                       &body body)
@@ -466,19 +295,6 @@ into Lisp code which creates the corresponding HTML as a string."
     (with-html-output (,var nil :prologue ,prologue :indent ,indent)
       ,@body)))
 
-(defmacro show-html-expansion ((var &optional stream
-                                    &key prologue
-                                         ((:indent *indent*) *indent*))
-                               &body body)
-  "Show the macro expansion of WITH-HTML-OUTPUT."
-  (when (and *indent*
-             (not (integerp *indent*)))
-    (setq *indent* 0))
-  (when (eq prologue t)
-    (setq prologue *prologue*))
-  `(pprint '(let ((,var ,(or stream var)))
-             ,(tree-to-commands body var prologue))))
-
 ;; stuff for Nikodemus Siivola's HYPERDOC
 ;; see 
 ;; and 
-- 
cgit v1.2.3