From c27f5b3411fb71316f4c9a936b0a1c6d519bdbdc Mon Sep 17 00:00:00 2001 From: Edi Weitz Date: Mon, 9 Mar 2009 21:56:26 +0000 Subject: Rename to version-less name git-svn-id: svn://bknr.net/svn/trunk/thirdparty/cl-who@4335 4281704c-cde7-0310-8518-8e2dc76b1ff0 --- CHANGELOG | 91 +++++++ cl-who.asd | 35 +++ doc/index.html | 807 +++++++++++++++++++++++++++++++++++++++++++++++++++++++++ packages.lisp | 65 +++++ specials.lisp | 113 ++++++++ who.lisp | 499 +++++++++++++++++++++++++++++++++++ 6 files changed, 1610 insertions(+) create mode 100644 CHANGELOG create mode 100644 cl-who.asd create mode 100644 doc/index.html create mode 100644 packages.lisp create mode 100755 specials.lisp create mode 100644 who.lisp diff --git a/CHANGELOG b/CHANGELOG new file mode 100644 index 0000000..34aef45 --- /dev/null +++ b/CHANGELOG @@ -0,0 +1,91 @@ +Version 0.11.0 +2007-08-24 +Replaces *DOWNCASE-TAGS-P* with *DOWNCASE-TOKENS-P* (thanks to Osei Poku) + +Version 0.10.0 +2007-07-25 +Added ESCAPE-CHAR-... functions (based on a patch by Volkan Yazici) + +Version 0.9.1 +2007-05-28 +Fixed bug in CONVERT-TAG-TO-STRING-LIST (thanks to Simon Cusack) + +Version 0.9.0 +2007-05-08 +Changed behaviour of STR and ESC when "argument" is NIL (patch by Mac Chan) + +Version 0.8.1 +2007-04-27 +Removed antiquated installation instructions and files (thanks to a hint by Mac Chan) + +Version 0.8.0 +2007-04-27 +Added *HTML-EMPTY-TAG-AWARE-P* (patch by Mac Chan) +A bit of refactoring + +Version 0.7.1 +2007-04-05 +Made *HTML-MODE* a compile-time flag (patch by Mac Chan) + +Version 0.7.0 +2007-03-23 +Added *DOWNCASE-TAGS-P* (patch by Mac Chan) + +Version 0.6.3 +2006-12-22 +Fixed example for CONVERT-TAG-TO-STRING-LIST (thanks to Daniel Gackle) + +Version 0.6.2 +2006-10-10 +Reintroduced ESCAPE-STRING-ISO-8859-1 for backwards compatibility + +Version 0.6.1 +2006-07-27 +EVAL CONSTANTP forms in attribute position (caught by Erik Enge) +Added WHO nickname to CL-WHO package + +Version 0.6.0 +2005-08-02 +Introduced *ATTRIBUTE-QUOTE-CHAR* and HTML-MODE and adapted code accordingly (patch by Stefan Scholl) + +Version 0.5.0 +2005-03-01 +Enable customization via CONVERT-TAG-TO-STRING-LIST + +Version 0.4.4 +2005-01-22 +Explicitely provide elementy type for +SPACES+ to prevent problems with LW (thanks to Bob Hutchinson) + +Version 0.4.3 +2004-09-13 +ESCAPE-STRING-ISO-8859 wasn't exported + +Version 0.4.2 +2004-09-08 +Fixed bug in docs (caught by Peter Seibel) +Added hyperdoc support + +Version 0.4.1 +2004-04-15 +Added :CL-WHO to *FEATURES* (for TBNL) + +Version 0.4.0 +2003-12-03 +Allow for optional LHTML syntax (patch by Kevin Rosenberg) + +Version 0.3.0 +2003-08-02 +Changed behaviour of attributes (incompatible with 0.2.0 syntax!) due to a question by Jörg-Cyril Höhle +Changed ' back to ' because of IE + +Version 0.2.0 +2003-07-27 +Changed default for :PROLOGUE (I was convinced by Rob Warnock and Eduardo Muñoz) + +Version 0.1.1 +2003-07-20 +Typo in WITH-OUTPUT-TO-STRING + +Version 0.1.0 +2003-07-17 +Initial release diff --git a/cl-who.asd b/cl-who.asd new file mode 100644 index 0000000..814fc5a --- /dev/null +++ b/cl-who.asd @@ -0,0 +1,35 @@ +;;; -*- 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 $ + +;;; Copyright (c) 2003-2007, 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. + +(asdf:defsystem :cl-who + :version "0.11.0" + :serial t + :components ((:file "packages") + (:file "specials") + (:file "who"))) diff --git a/doc/index.html b/doc/index.html new file mode 100644 index 0000000..62a5bfd --- /dev/null +++ b/doc/index.html @@ -0,0 +1,807 @@ + + + + + + CL-WHO - Yet another Lisp markup language + + + + + +

CL-WHO - Yet another Lisp markup language

+ +
+
 

Abstract

+ +There are plenty of Lisp Markup +Languages out there - every Lisp programmer seems to write at +least one during his career - and CL-WHO (where WHO means +"with-html-output" for want of a better acronym) is probably +just as good or bad as the next one. They are all more or less similar +in that they provide convenient means to convert S-expressions +intermingled with code into (X)HTML, XML, or whatever but differ with +respect to syntax, implementation, and API. So, if you haven't made a +choice yet, check out the alternatives as well before you begin to use +CL-WHO just because it was the first one you came across. (Was that +repelling enough?) If you're looking for a slightly different approach +you might also want to look at 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 +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 +different. +

+CL-WHO tries to create efficient code in that it makes constant +strings as long as possible. In other words, the code generated by the +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 +either XHTML (default) or 'plain' (SGML) HTML — depending on +what you've set HTML-MODE to. +

+CL-WHO is intended to be portable and should work with all +conforming Common Lisp implementations. Let us know if you encounter any +problems. +

+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. + +

+Download shortcut: http://weitz.de/files/cl-who.tar.gz. +

+ +
 

Contents

+
    +
  1. Example usage +
  2. Download and installation +
  3. Support and mailing lists +
  4. Syntax and Semantics +
  5. The CL-WHO dictionary +
      +
    1. with-html-output +
    2. with-html-output-to-string +
    3. show-html-expansion +
    4. *attribute-quote-char* +
    5. *prologue* +
    6. *html-empty-tag-aware-p* +
    7. *html-empty-tags* +
    8. *downcase-tokens-p* +
    9. esc +
    10. fmt +
    11. htm +
    12. str +
    13. html-mode +
    14. escape-string +
    15. escape-char +
    16. *escape-char-p* +
    17. escape-string-minimal +
    18. escape-string-minimal-plus-quotes +
    19. escape-string-iso-8859 +
    20. escape-string-iso-8859-1 +
    21. escape-string-all +
    22. escape-char-minimal +
    23. escape-char-minimal-plus-quotes +
    24. escape-char-iso-8859-1 +
    25. escape-char-all +
    26. conc +
    27. convert-tag-to-string-list +
    28. convert-attributes +
    +
  6. Acknowledgements +
+ +
 

Example usage

+ +Let's assume that *HTTP-STREAM* is the stream your web +application is supposed to write to. Here are some contrived code snippets +together with the Lisp code generated by CL-WHO and the resulting HTML output. + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
+(with-html-output (*http-stream*)
+  (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
+
+;; Code generated by CL-WHO
+
+(let ((*http-stream* *http-stream*))
+  (progn
+    nil
+    (loop for (link . title) in '(("http://zappa.com/" . "Frank Zappa")
+                                  ("http://marcusmiller.com/" . "Marcus Miller")
+                                  ("http://www.milesdavis.com/" . "Miles Davis"))
+          do (progn
+               (write-string "<a href='" *http-stream*)
+               (princ link *http-stream*)
+               (write-string "'><b>" *http-stream*)
+               (princ title *http-stream*)
+               (write-string "</b></a><br />" *http-stream*)))))
+
+(with-html-output (*http-stream*)
+  (: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
+
+;; Code generated by CL-WHO
+
+(let ((*http-stream* *http-stream*))
+  (progn
+    nil
+    (write-string "<table border='0' cellpadding='4'>" *http-stream*)
+    (loop for i below 25 by 5
+          do (progn
+               (write-string "<tr align='right'>" *http-stream*)
+               (loop for j from i below (+ i 5)
+                     do (progn
+                          (write-string "<td bgcolor='" *http-stream*)
+                          (princ (if (oddp j) "pink" "green") *http-stream*)
+                          (write-string "'>" *http-stream*)
+                          (format *http-stream* "~@r" (1+ j))
+                          (write-string "</td>" *http-stream*)))
+               (write-string "</tr>" *http-stream*)))
+    (write-string "</table>" *http-stream*)))
+
+(with-html-output (*http-stream*)
+  (: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

+
+;; Code generated by CL-WHO
+
+(let ((*http-stream* *http-stream*))
+  (progn
+    nil
+    (write-string
+     "<h4>Look at the character entities generated by this example</h4>"
+     *http-stream*)
+    (loop for i from 0 for string in '("Fête" "Sørensen" "naïve" "Hühner" "Straße")
+          do (progn
+               (write-string "<p style='" *http-stream*)
+               (princ (conc "background-color:"
+                            (case (mod i 3)
+                              ((0) "red")
+                              ((1) "orange")
+                              ((2) "blue")))
+                      *http-stream*)
+               (write-string "'>" *http-stream*)
+               (progn (write-string (escape-string string) *http-stream*))
+               (write-string "</p>" *http-stream*)))))
+
+ +
 

Download and installation

+ +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. +

+The preferred method to compile and load Hunchentoot is via ASDF. +

+If you're on Debian you can +probably use +the cl-who +Debian package which is available thanks to Kevin +Rosenberg. There's also a port +for Gentoo +Linux thanks to Matthew Kennedy. In both cases, check if they have the newest version available. +

+Luís Oliveira maintains a darcs +repository of CL-WHO +at http://common-lisp.net/~loliveira/ediware/. + +
 

Support and mailing lists

+ +For questions, bug reports, feature requests, improvements, or patches +please use the cl-who-devel +mailing list. If you want to be notified about future releases +subscribe to the cl-who-announce +mailing list. These mailing lists were made available thanks to +the services of common-lisp.net. +

+If you want to send patches, please read this first. + +
 

Syntax and Semantics

+ +CL-WHO is essentially just one macro, WITH-HTML-OUTPUT, which +transforms the body of code it encloses into something else obeying the +following rules (which we'll call transformation rules) for the body's forms: + + + +
 

The CL-WHO dictionary

+ +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. +

+Note that the keyword arguments prologue and indent are used at macro expansion time. + +

+* (with-html-output (*standard-output* nil :prologue t)
+    (:html (:body "Not much there"))
+    (values))
+<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Strict//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd"><html><body>Not much there</body></html>
+* (with-html-output (*standard-output*)
+    (:html (:body :bgcolor "white"
+             "Not much there"))
+    (values))
+<html><body bgcolor='white'>Not much there</body></html>
+* (with-html-output (*standard-output* nil :prologue t :indent t)
+    (:html (:body :bgcolor "white"
+             "Not much there"))
+    (values))
+<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Strict//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd">
+<html>
+  <body bgcolor='white'>
+    Not much there
+  </body>
+</html>
+
+
+ +


[Macro] +
with-html-output-to-string (var &optional string-form &key element-type prologue indent) declaration* form* => result* + +


+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)
+                                                prologue
+                                                indent)
+                                      &body body)
+  "Transform the enclosed BODY consisting of HTML as s-expressions
+into Lisp code which creates the corresponding HTML as a string."
+  `(with-output-to-string (,var ,string-form :elementy-type ,element-type)
+    (with-html-output (,var nil :prologue ,prologue :indent ,indent)
+      ,@body)))
+
+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* + +


+This character is used as the quote character when building attributes. Defaults to the single quote #\'. Only other reasonable character is the double quote #\". +
+ +


[Special variable] +
*prologue* + +


+This is the prologue string which will be printed if the prologue keyword argument to WITH-HTML-OUTPUT is T. Gets changed when you set HTML-MODE. Its initial value is + +
"<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.0 Strict//EN\" \"http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd\">"
+
+ +


[Special variable] +
*html-empty-tag-aware-p* + +


+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 <tag/> (XHTML mode) or <tag> (SGML mode). For +all other tags, it will always generate <tag></tag>. The initial value of this variable is T. +
+ +


[Special variable] +
*html-empty-tags* + +


+The list of HTML tags that should be output as empty tags. See +*HTML-EMPTY-TAG-AWARE-P*. +The initial value is the list +
+(: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)
+
+
+ +


[Special variable] +
*downcase-tokens-p* + +


+If the value of this variable is NIL, keyword symbols representing a tag or attribute name will not be +automatically converted to lowercase. This is useful when one needs to +output case sensitive XML. The default is T. +
+ +


[Symbol] +
esc +
[Symbol] +
fmt +
[Symbol] +
htm +
[Symbol] +
str + +


+These are just symbols with no bindings associated with them. The only reason they are exported is their special meaning during the transformations described in Syntax and Semantics. +
+ +


[Accessor] +
html-mode => mode +
(setf (html-mode) mode) +


+The function HTML-MODE returns the current mode for generating HTML. The default is :XML for XHTML. You can change this by setting it with (SETF (HTML-MODE) :SGML) to pre-XML HTML mode. +

+Setting it to SGML HTML sets the *prologue* to the doctype string for HTML 4.01 transitional: +

<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01 Transitional//EN" "http://www.w3.org/TR/html4/loose.dtd">
+Code generation in SGML HTML is slightly different from XHTML - there's no need to end empty elements with /> and empty attributes are allowed. +
+ +


[Function] +
escape-string string &key test => escaped-string + +


+This function will accept a string string and will replace every character for which test returns true with its character entity. The numeric character entities use decimal instead of hexadecimal values when HTML-MODE is set to :SGML because of compatibility reasons with old clients. test must be a function of one argument which accepts a character and returns a generalized boolean. The default is the value of *ESCAPE-CHAR-P*. Note the ESC shortcut described in Syntax and Semantics. + +
+* (escape-string "<Hühner> 'naïve'")
+"&lt;H&#xFC;hner&gt; &#x27;na&#xEF;ve&#x27;"
+* (with-html-output-to-string (s)
+    (:b (esc "<Hühner> 'naïve'")))
+"<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.0 Strict//EN\" \"http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd\"<b>&lt;H&#xFC;hner&gt; &#x27;na&#xEF;ve&#x27;</b>"
+
+
+ +


[Function] +
escape-char character &key test => escaped-string + +


+This function works identical to ESCAPE-STRING, except that it operates on characters instead of strings. +
+ +


[Special variable] +
*escape-char-p* + +


+This is the default for the test keyword argument to ESCAPE-STRING and ESCAPE-CHAR. Its initial value is + +
+#'(lambda (char)
+    (or (find char "<>&'\"")
+        (> (char-code char) 127)))
+
+
+ +


[Function] +
escape-string-minimal string => escaped-string +
[Function] +
escape-string-minimal-plus-quotes string => escaped-string +
[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 +
[Function] +
escape-char-minimal-plus-quotes character => escaped-string +
[Function] +
escape-char-iso-8859-1 character => escaped-string +
[Function] +
escape-char-all character => escaped-string + +


These are convenience function based +on ESCAPE-STRING +and ESCAPE-CHAR. The string +functions are defined in a way similar to this one: + +
+(defun escape-string-minimal (string)
+  "Escape only #\<, #\>, and #\& in STRING."
+  (escape-string string :test #'(lambda (char) (find char "<>&"))))
+
+(defun escape-string-minimal-plus-quotes (string)
+  "Like ESCAPE-STRING-MINIMAL but also escapes quotes."
+  (escape-string string :test #'(lambda (char) (find char "<>&'\""))))
+
+(defun escape-string-iso-8859-1 (string)
+  "Escapes all characters in STRING which aren't defined in ISO-8859-1."
+  (escape-string string :test #'(lambda (char)
+                                  (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."
+  (escape-string string :test #'(lambda (char)
+                                  (or (find char "<>&'\"")
+                                      (> (char-code char) 127)))))
+
+The character functions are defined in an analogous manner. +
+ +


[Function] +
conc &rest string-list => string + +


+Utility function to concatenate all arguments (which should be strings) into one string. Meant to be used mainly with attribute values. + +
+* (conc "This" " " "is" " " "a" " " "sentence")
+"This is a sentence"
+* (with-html-output-to-string (s)
+    (:div :style (conc "padding:"
+                       (format nil "~A" (+ 3 2)))
+     "Foobar"))
+"<div style='padding:5'>Foobar</div>"
+
+
+ +


[Generic Function] +
convert-tag-to-string-list tag attr-list body body-fn => strings-or-forms + +


+ +This function exposes some of CL-WHO's internals so users can +customize its behaviour. It is called whenever a tag is processed and +must return a corresponding list of strings or Lisp forms. The idea +is that you can specialize this generic function in order to process +certain tags yourself. +

+tag is a keyword symbol naming the outer tag, +attr-list is an alist of its attributes (the car +is the attribute's name as a keyword, the cdr is its value), +body is the tag's body, and +body-fn is a function which should be applied to +the body to further process it. Of course, if you define your own +methods you can ignore body-fn if you want. +

+Here are some simple examples: +

+* (defmethod convert-tag-to-string-list ((tag (eql :red)) attr-list body body-fn)
+    (declare (ignore attr-list))
+    (nconc (cons "<font color='red'>" (funcall body-fn body)) (list "</font>"))) 
+; Compiling LAMBDA (PCL::.PV-CELL. PCL::.NEXT-METHOD-CALL. TAG ATTR-LIST BODY BODY-FN): 
+; Compiling Top-Level Form: 
+
+#<STANDARD-METHOD CONVERT-TAG-TO-STRING-LIST ((EQL :RED) T T T) {582B268D}>
+* (with-html-output (*standard-output*)
+    (:red (:b "Bold and red")) 
+    (values))
+<font color='red'><b>Bold and red</b></font>
+* (show-html-expansion (s)
+    (:red :style "spiffy" (if (foo) (htm "Attributes are ignored")))) 
+
+(LET ((S S))
+  (PROGN
+   NIL
+   (WRITE-STRING "<font color='red'>" S)
+   (IF (FOO) (PROGN (WRITE-STRING "Attributes are ignored" S)))
+   (WRITE-STRING "</font>" S)))
+* (defmethod convert-tag-to-string-list ((tag (eql :table)) attr-list body body-fn)
+    (cond ((cdr (assoc :simple attr-list))
+           (nconc (cons "<table"
+                        (convert-attributes (remove :simple attr-list :key #'car)))
+                  (list ">")
+                  (loop for row in body
+                        collect "<tr>"
+                        nconc (loop for col in row
+                                    collect "<td>"
+                                    when (constantp col)
+                                      collect (format nil "~A" col)
+                                    else 
+                                      collect col
+                                    collect "</td>")
+                        collect "</tr>")
+                  (list "</table>")))
+          (t 
+            ;; you could as well invoke CALL-NEXT-METHOD here, of course
+            (nconc (cons "<table "
+                         (convert-attributes attr-list))
+                   (list ">")
+                   (funcall body-fn body)
+                   (list "</table>")))))
+; Compiling LAMBDA (PCL::.PV-CELL. PCL::.NEXT-METHOD-CALL. TAG ATTR-LIST BODY BODY-FN): 
+; Compiling Top-Level Form: 
+
+#<STANDARD-METHOD CONVERT-TAG-TO-STRING-LIST ((EQL :TABLE) T T T) {58AFB7CD}>
+* (with-html-output (*standard-output*)
+    (:table :border 0 (:tr (:td "1") (:td "2")) (:tr (:td "3") (:td "4")))) 
+<table  border='0'><tr><td>1</td><td>2</td></tr><tr><td>3</td><td>4</td></tr></table>
+"</td></tr></table>"
+* (show-html-expansion (s)
+    (:table :simple t :border 0
+            (1 2) (3 (fmt "Result = ~A" (compute-result)))))
+
+(LET ((S S))
+  (PROGN
+   NIL
+   (WRITE-STRING
+    "<table border='0'><tr><td>1</td><td>2</td></tr><tr><td>3</td><td>"
+    S)
+   (FORMAT S "Result = ~A" (COMPUTE-RESULT))
+   (WRITE-STRING "</td></tr></table>" S)))
+
+ +
+ +


[Function] +
convert-attributes attr-list => strings-or-forms + +


+ +This is a helper function which can be called from +CONVERT-TAG-TO-STRING-LIST to process the list of attributes. + +
+ +
 

Acknowledgements

+ +Thanks to Tim Bradshaw and John Foderaro for the inspiration provided +by their libraries mentioned above. Thanks to +Jörg-Cyril Höhle for his suggestions with respect to +attribute values. Thanks to Kevin Rosenberg for the LHTML patch. +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 $ +

BACK TO MY HOMEPAGE + + + diff --git a/packages.lisp b/packages.lisp new file mode 100644 index 0000000..1d9bdec --- /dev/null +++ b/packages.lisp @@ -0,0 +1,65 @@ +;;; -*- 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 $ + +;;; Copyright (c) 2003-2007, 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 + (:use :cl) + (:nicknames :who) + #+:sbcl (:shadow :defconstant) + (:export :*attribute-quote-char* + :*escape-char-p* + :*prologue* + :*downcase-tokens-p* + :*html-empty-tags* + :*html-empty-tag-aware-p* + :conc + :convert-attributes + :convert-tag-to-string-list + :esc + :escape-char + :escape-char-all + :escape-char-iso-8859-1 + :escape-char-minimal + :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)) + +(pushnew :cl-who *features*) \ No newline at end of file diff --git a/specials.lisp b/specials.lisp new file mode 100755 index 0000000..2df1adb --- /dev/null +++ b/specials.lisp @@ -0,0 +1,113 @@ +;;; -*- 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 $ + +;;; Copyright (c) 2003-2007, 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) + +#+:sbcl +(defmacro defconstant (name value &optional doc) + "Make sure VALUE is evaluated only once \(to appease SBCL)." + `(cl:defconstant ,name (if (boundp ',name) (symbol-value ',name) ,value) + ,@(when doc (list doc)))) + +(defvar *prologue* + "" + "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))) + "Used by ESCAPE-STRING to test whether a character should be escaped.") + +(defparameter *indent* nil + "Whether to insert line breaks and indent. Also controls amount of +indentation dynamically.") + +(defvar *html-mode* :xml + ":SGML for \(SGML-)HTML, :XML \(default) for XHTML.") + +(defvar *downcase-tokens-p* t + "If NIL, a keyword symbol representing a tag or attribute name will +not be automatically converted to lowercase. This is useful when one +needs to output case sensitive XML.") + +(defparameter *attribute-quote-char* #\' + "Quote character for attributes.") + +(defparameter *empty-tag-end* " />" + "End of an empty tag. Default is XML style.") + +(defparameter *html-empty-tags* + '(: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) + "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 + "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 +mode). For all other tags, it will always generate +.") + +(defconstant +newline+ (make-string 1 :initial-element #\Newline) + "Used for indentation.") + +(defconstant +spaces+ (make-string 2000 + :initial-element #\Space + :element-type 'base-char) + "Used for indentation.") + diff --git a/who.lisp b/who.lisp new file mode 100644 index 0000000..f154427 --- /dev/null +++ b/who.lisp @@ -0,0 +1,499 @@ +;;; -*- 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 $ + +;;; Copyright (c) 2003-2007, 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) + +(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 +:XML for XHTML." + *html-mode*) + +(defun (setf html-mode) (mode) + "Sets the output mode to XHTML or \(SGML-)HTML. MODE can be +:SGML for HTML or :XML for XHTML." + (ecase mode + ((:sgml) + (setf *html-mode* :sgml + *empty-tag-end* ">" + *prologue* "")) + ((:xml) + (setf *html-mode* :xml + *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 +syntax) in SEXP. Uses the generic function CONVERT-TO-STRING-LIST +internally. Utility function used by TREE-TO-TEMPLATE." + (let (tag attr-list body) + (cond + ((keywordp sexp) + (setq tag sexp)) + ((atom (first sexp)) + (setq tag (first sexp)) + ;; collect attribute/value pairs into ATTR-LIST and tag body (if + ;; any) into BODY + (loop for rest on (cdr sexp) by #'cddr + if (keywordp (first rest)) + collect (cons (first rest) (second rest)) into attr + else + do (progn (setq attr-list attr) + (setq body rest) + (return)) + finally (setq attr-list attr))) + ((listp (first sexp)) + (setq tag (first (first sexp))) + (loop for rest on (cdr (first sexp)) by #'cddr + if (keywordp (first rest)) + collect (cons (first rest) (second rest)) into attr + finally (setq attr-list attr)) + (setq body (cdr sexp)))) + (convert-tag-to-string-list tag attr-list body body-fn))) + +(defun convert-attributes (attr-list) + "Helper function for CONVERT-TAG-TO-STRING-LIST which converts the +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) + (string orig-attr)) + unless (null val) ;; no attribute at all if VAL is NIL + if (constantp val) + if (and (eq *html-mode* :sgml) (eq val t)) ; special case for SGML + nconc (list " " attr) + else + nconc (list " " + ;; name of attribute + 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) + ;; 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) + end + else + ;; do the same things as above but at runtime + nconc (list `(let ((,=var= ,val)) + (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*))))) + (t + (htm ,(format nil " ~A=~C" attr *attribute-quote-char*) + (str ,=var=) + ,attribute-quote))))))) + +(defgeneric convert-tag-to-string-list (tag attr-list body body-fn) + (:documentation "Used by PROCESS-TAG to convert `HTML' into a list +of strings. TAG is a keyword symbol naming the outer tag, ATTR-LIST +is an alist of its attributes \(the car is the attribute's name as a +keyword, the cdr is its value), BODY is the tag's body, and BODY-FN is +a function which should be applied to BODY. The function must return +a list of strings or Lisp forms.")) + +(defmethod convert-tag-to-string-list (tag attr-list body body-fn) + "The standard method which is not specialized. The idea is that you +can use EQL specializers on the first argument." + (declare (optimize speed space)) + (let ((tag (if *downcase-tokens-p* (string-downcase tag) (string tag)))) + (nconc + (if *indent* + ;; indent by *INDENT* spaces + (list +newline+ (n-spaces *indent*))) + ;; tag name + (list "<" tag) + ;; attributes + (convert-attributes attr-list) + ;; body + (if body + (append + (list ">") + ;; now hand over the tag's body to TREE-TO-TEMPLATE, increase + ;; *INDENT* by 2 if necessary + (if *indent* + (let ((*indent* (+ 2 *indent*))) + (funcall body-fn body)) + (funcall body-fn body)) + (if *indent* + ;; indentation + (list +newline+ (n-spaces *indent*))) + ;; closing tag + (list "")) + ;; no body, so no closing tag unless defined in *HTML-EMPTY-TAGS* + (if (or (not *html-empty-tag-aware-p*) + (member tag *html-empty-tags* :test #'string-equal)) + (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)))))) + +(defun string-list-to-string (string-list) + (declare (optimize speed space)) + "Concatenates a list of strings to one string." + ;; note that we can't use APPLY with CONCATENATE here because of + ;; CALL-ARGUMENTS-LIMIT + (let ((total-size 0)) + (dolist (string string-list) + (incf total-size (length string))) + (let ((result-string (make-sequence 'simple-string total-size)) + (curr-pos 0)) + (dolist (string string-list) + (replace result-string string :start1 curr-pos) + (incf curr-pos (length string))) + result-string))) + +(defun conc (&rest string-list) + "Concatenates all arguments which should be string into one string." + (funcall #'string-list-to-string string-list)) + +(defun tree-to-commands-aux (tree stream) + (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) + collector + string-collector) + (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)))) + +(defmacro with-html-output ((var &optional stream + &key prologue + ((:indent *indent*) *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*)) + `(let ((,var ,(or stream var))) + ,(tree-to-commands body var prologue))) + +(defmacro with-html-output-to-string ((var &optional string-form + &key (element-type ''character) + prologue + indent) + &body body) + "Transform the enclosed BODY consisting of HTML as s-expressions +into Lisp code which creates the corresponding HTML as a string." + `(with-output-to-string (,var ,string-form + #-(or :ecl :cmu :sbcl) :element-type + #-(or :ecl :cmu :sbcl) ,element-type) + (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 +;; also used by LW-ADD-ONS + +(defvar *hyperdoc-base-uri* "http://weitz.de/cl-who/") + +(let ((exported-symbols-alist + (loop for symbol being the external-symbols of :cl-who + collect (cons symbol + (concatenate 'string + "#" + (string-downcase symbol)))))) + (defun hyperdoc-lookup (symbol type) + (declare (ignore type)) + (cdr (assoc symbol + exported-symbols-alist + :test #'eq)))) -- cgit v1.2.3