diff -uNr a/cl-who/CHANGELOG b/cl-who/CHANGELOG --- a/cl-who/CHANGELOG false +++ b/cl-who/CHANGELOG 2de38edb3bd249e062e085960c60e31b3148585b2bb3a42f2357a7a5b1887bd171bddd4885090cddac369c280300dbdf476184053d8cf28b79dc14b0145b2960 @@ -0,0 +1,133 @@ +Version 1.1.4 +2014-11-28 +update support info (Hans Huebner) + +Version 1.1.3 +2013-11-16 +Add type check to guard against invalid stream argument (Stas Boukarev) + +Version 1.1.2 +2013-11-16 +Missing comma in macro expansion (Jeff Cunningham) +Fix style-warning + +Version 1.1.1 +2012-09-04 +Bug fixes for broken declaration processing (Stas Boukarev) + +Version 1.1.0 +2012-09-01 +Make declarations work as advertised (Ala'a Mohammad Alawi) +Add :description to .asd file +Fix and improve tests +Add *HTML-NO-INDENT-TAGS* (Nikodemus Siivola) +Documentation fixes + +Version 1.0.0 +2010-0x-xx +Refactored internals and made STR etc. local macros +Added test suite + todo: replace s-h-texp with walk in docs +Removed deprecated ESCAPE-STRING-ISO-8859 function +Removed SHOW-HTML-EXPANSION +Bugfixes (thanks to Slawek Zak) +Added support for HTML5 (Chaitanya Gupta) +Test portability fixes and improvements (Nikodemus Siivola) +New *HTML-NO-INDENT-TAGS* variable to selectively suppress indentation (Nikodemus Siivola) +Lock package on SBCL (Nikodemus Siivola) + +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) + +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 Jorg-Cyril Hohle +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 Munoz) + +Version 0.1.1 +2003-07-20 +Typo in WITH-OUTPUT-TO-STRING + +Version 0.1.0 +2003-07-17 +Initial release diff -uNr a/cl-who/cl-who.asd b/cl-who/cl-who.asd --- a/cl-who/cl-who.asd false +++ b/cl-who/cl-who.asd d6a4f49049ca6068669b1ae31f8810fd50005e0969ddf81926191096d7cc3c428ee8ded0912d22cdedb345d6783c2c0103d8b0d7a85bd70440ffa7ee1b94f15f @@ -0,0 +1,48 @@ +;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*- +;;; $Header: /usr/local/cvsrep/cl-who/cl-who.asd,v 1.24 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. + +(asdf:defsystem :cl-who + :description "(X)HTML generation macros" + :version "1.1.4" + :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 -uNr a/cl-who/doc/index.html b/cl-who/doc/index.html --- a/cl-who/doc/index.html false +++ b/cl-who/doc/index.html cc75f60a495c60841d786d49daeb619e56ee02beec5fbe7c788aee05072aaff16eb72ad9f63866658e06f895646c7832baaf830ece8156bcc8d164eb8e618bbe @@ -0,0 +1,814 @@ + + + + + + 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. 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 +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. CL-WHO's output is +either XHTML (default), 'plain' (SGML) HTML or HTML5 (using HTML syntax) — 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 for example used by clutu and Heike Stephan. + +

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

+ +
 

Contents

+
    +
  1. Example usage +
  2. Download and installation +
  3. Support +
  4. Syntax and Semantics +
  5. The CL-WHO dictionary +
      +
    1. with-html-output +
    2. with-html-output-to-string +
    3. *attribute-quote-char* +
    4. *downcase-tokens-p* +
    5. *html-empty-tag-aware-p* +
    6. *html-empty-tags* +
    7. *html-no-indent-tags* +
    8. *prologue* +
    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-1 +
    20. escape-string-all +
    21. escape-char-minimal +
    22. escape-char-minimal-plus-quotes +
    23. escape-char-iso-8859-1 +
    24. escape-char-all +
    25. conc +
    26. convert-tag-to-string-list +
    27. 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 (simplified)
+
+(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 (simplified)
+
+(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 '("Fete" "Sorensen" "naive" "Huhner" "Strasse")
+         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 (simplified)
+
+(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 '("Fete" "Sorensen" "naive" "Huhner" "Strasse")
+          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 1.1.3. +

+The preferred method to fetch, compile and load CL-WHO is via Quicklisp. Install +Quicklisp, then run +

(ql:quickload :cl-who)
+

+The current development version of CL-WHO can be found +at https://github.com/edicl/cl-who. +This is the one to send patches against. Use at +your own risk. +

+Luís Oliveira maintains an +unofficial 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

+ +The development version of cl-who can be +found on +github. Please use the github issue tracking system to submit bug +reports. Patches are welcome, please +use GitHub pull +requests. If you want to make a change, +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 +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. Value +of *HTML-NO-INDENT-TAGS* +controls which tag-contents are excempt from indentation: by default +contents of PRE and TEXTAREA tags are not +indented to avoid spurious layout changes. (Note: in certain +situations additional whitespace may change the layout of tables.) +

+The results are the values returned by +the forms. +

+Note that the keyword arguments prologue +and indent, and the associated variables 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. +
+ +


[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] +
*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. +
+ +


[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 or HTML 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 :command :embed
+ :frame :hr :img :input :isindex :keygen :left :limittext :link :meta :nextid
+ :of :over :param :range :right :source :spacer :spot :tab :track :wbr)
+
+
+ +


[Special variable] +
*html-no-indent-tags* + +


+The list of HTML tags that should disable indentation inside them even +when indentation is requested. The initial value is a list containing +only :pre and :texarea. +
+ +


[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\">"
+
+ +


[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 or (SETF (HTML-MODE) :HTML5) to HTML5 mode (using HTML syntax). +

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

+Setting it to HTML5 sets the *prologue* to the following doctype string: +

<!DOCTYPE html>
+
+ +


[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 "<Huhner> 'naive'")
+"&lt;Huhner&gt; &#x27;naive&#x27;"
+* (with-html-output-to-string (s)
+    (:b (esc "<Huhner> 'naive'")))
+"<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.0 Strict//EN\" \"http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd\"<b>&lt;Huhner&gt; &#x27;naive&#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-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-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.68 2009/03/09 21:54:11 edi Exp $ +

BACK TO MY HOMEPAGE + + + diff -uNr a/cl-who/manifest b/cl-who/manifest --- a/cl-who/manifest false +++ b/cl-who/manifest 3848315efb850a3da7ed9db04ec798d420d913139764027d597c3e9117245f1dc202fd78f006580c795755154b77984cca1f0bdd7adfd55fed4282e74cf86dfa @@ -0,0 +1 @@ +577593 cl-who-genesis spyked CL-WHO, as lifted from Edi Weitz circa 2016 diff -uNr a/cl-who/packages.lisp b/cl-who/packages.lisp --- a/cl-who/packages.lisp false +++ b/cl-who/packages.lisp ec529f1105e0810cdb81cdd3c6ec24231824922e3385bc11d3d247f8b07413c67280a8eb8cea29f8a40ba57ce2bfc74ef0e9a252be2d9a9ccc37d96ed654627b @@ -0,0 +1,65 @@ +;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*- +;;; $Header: /usr/local/cvsrep/cl-who/packages.lisp,v 1.21 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-user) + +(defpackage :cl-who + (:use :cl) + (:nicknames :who) + #+:sbcl (:shadow :defconstant) + #+:sb-package-locks (:lock t) + (:export :*attribute-quote-char* + :*escape-char-p* + :*prologue* + :*downcase-tokens-p* + :*html-no-indent-tags* + :*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-1 + :escape-string-minimal + :escape-string-minimal-plus-quotes + :fmt + :htm + :html-mode + :str + :with-html-output + :with-html-output-to-string)) + +(pushnew :cl-who *features*) diff -uNr a/cl-who/specials.lisp b/cl-who/specials.lisp --- a/cl-who/specials.lisp false +++ b/cl-who/specials.lisp d0c3893835e4ba078b807234d110a0d4ce33876dd74e81bcd7d7060c7d07213b761beb40dbbe5edc78eac86285304e0e320b9fb353e1f6e62744b71fa393edc0 @@ -0,0 +1,122 @@ +;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package:CL-WHO; Base: 10 -*- +;;; $Header: /usr/local/cvsrep/cl-who/specials.lisp,v 1.6 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) + +#+: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") + +(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.") + +(defvar *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, :HTML5 for HTML5.") + +(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.") + +(defvar *attribute-quote-char* #\' + "Quote character for attributes.") + +(defvar *empty-tag-end* " />" + "End of an empty tag. Default is XML style.") + +(defvar *html-no-indent-tags* + '(:pre :textarea) + "The list of HTML tags that should disable indentation inside them. The initial +value is a list containing only :PRE and :TEXTAREA.") + +(defvar *html-empty-tags* + '(:area + :atop + :audioscope + :base + :basefont + :br + :choose + :col + :command + :embed + :frame + :hr + :img + :input + :isindex + :keygen + :left + :limittext + :link + :meta + :nextid + :of + :over + :param + :range + :right + :source + :spacer + :spot + :tab + :track + :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 and HTML5 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 -uNr a/cl-who/test/packages.lisp b/cl-who/test/packages.lisp --- a/cl-who/test/packages.lisp false +++ b/cl-who/test/packages.lisp c80dec2762c8a5c35da28c2f7820641ec9e20c6b48513e7921c0f40d142cfb28060bb93e0d27094323ab67f45378594445d8ae1fd033af8591201b8fce783968 @@ -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)) diff -uNr a/cl-who/test/simple b/cl-who/test/simple --- a/cl-who/test/simple false +++ b/cl-who/test/simple c4830ca5c4ec6ac31c2d387e2cb0407c068317588f1f9342ab7df2a6830ace1610c2a402afb5279b469459021f00c1ad99d4d09e0e45835e340155bed8a96624 @@ -0,0 +1,296 @@ +;;; -*- 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 + +;;; 1 +(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
") + +;;; 2 +(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
") + +;;; 3 +(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
") + +;;; 4 +(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
") + +;;; 5 +(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
") + +;;; 6 +(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
") + +;;; 7 +;;; XXX this fails uglily on SBCL for some reason that I'm too lazy to +;;; look into +;; (eq (array-element-type +;; (with-html-output-to-string (out nil :element-type 'base-char) +;; (:br))) +;; 'base-char) + +;;; 8 +(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
") + +;;; 9 +(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
") + +;;; 10 +(string= (with-html-output-to-string + (out nil :prologue "") + (:apply (:factorial) (:cn "3"))) + " +3") + +;;; 11 +(string= (let ((*prologue* "")) + (eval `(with-html-output-to-string (out nil :prologue t) + (:apply (:factorial) (:cn "3"))))) + " +3") + +;;; 12 +(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 + + +
") + +;;; 13 +(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 + + +
") + +;;; 14 +(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 + + +
") + +;;; 15 +(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
") + +;;; 16 +(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 '("Fete" "Sorensen" "naive" "Huhner" "Strasse") + 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

Fete

Sorensen

naive

Huhner

Strasse

") + +;;; 17 +(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")) + ""))) + +;;; 18 +(string= (with-html-output-to-string (out) + (:p)) + "

") + +;;; 19 +(string= (let ((cl-who:*html-empty-tag-aware-p* nil)) + (eval `(with-html-output-to-string (out) + (:p)))) + "

") + +;;; 20 +(string= (let ((*html-empty-tag-aware-p* t) + (*html-empty-tags* '(:p))) + (eval `(with-html-output-to-string (out) + (:p)))) + "

") + +;;; 21 +(string= (with-html-output-to-string (out) + (:|Foo| :bar 42)) + "") + +;;; 22 +(string= (let ((*downcase-tokens-p* nil)) + (eval `(with-html-output-to-string (out) + (:|Foo| :bar 42)))) + "") + +;;; 23 +(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)) + "
") + +;;; 24 +(string= (with-html-output-to-string (out) + (:div (:pre "Foo"))) + "

Foo
") + +;;; 25 +(string= (with-html-output-to-string (out nil :indent t) + (:div (:pre "Foo"))) + " +
+
Foo
+
") + +;;; 26 +(string= (with-html-output-to-string (out nil :indent t) + (:div (:p "Bar"))) + " +
+

Bar +

+
") + +;;; 27 +(string= (let ((*html-no-indent-tags* (cons :p *html-no-indent-tags*))) + (eval `(with-html-output-to-string (out nil :indent t) + (:div (:p "Bar"))))) + " +
+

Bar

+
") diff -uNr a/cl-who/test/tests.lisp b/cl-who/test/tests.lisp --- a/cl-who/test/tests.lisp false +++ b/cl-who/test/tests.lisp b1dc6b893d76de1713c05862d3e33a6a0616fd30f07fdeded240dba1c75d9171aede195e4ca3269b8cacfe9e2e070b62da2f0a3920b3bcdb0e840fc2723cea6a @@ -0,0 +1,158 @@ +;;; -*- 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 ((and (consp form) (eq 'string= (car form)) + (stringp (third form))) + (destructuring-bind (gen expected) (cdr form) + (let ((actual (eval gen))) + (unless (string= actual expected) + (list (format nil "~@<~:@_ ~2:I~S~:@_Expected: ~S~ + ~@:_ Actual: ~S~:>" + form expected actual)))))) + ((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)) diff -uNr a/cl-who/util.lisp b/cl-who/util.lisp --- a/cl-who/util.lisp false +++ b/cl-who/util.lisp 96d454d96c82e86626fd51a70d57df4d6a0a5186732cb168dd71d681d8af39c6e4f738977db5444af1c9c5e3edd3f3b62d0f7e93bd30fbef1ac85f399a2017fb @@ -0,0 +1,241 @@ +;;; -*- 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)) + +(defun extract-declarations (forms) + "Given a FORM, the declarations - if any - will be extracted + from the head of the FORM, and will return two values the declarations, + and the remaining of FORM" + (loop with declarations + for forms on forms + for form = (first forms) + while (and (consp form) + (eql (first form) 'cl:declare)) + do (push form declarations) + finally (return (values (nreverse declarations) forms)))) diff -uNr a/cl-who/who.lisp b/cl-who/who.lisp --- a/cl-who/who.lisp false +++ b/cl-who/who.lisp 3d6eb4940de09b38e43a715bae6417ed0b132235c81da2d06725b4a26dce16f58426e2bfe0eab9a04974525bc51bdf489c8e1a1ed9200a49d44784aacc71b89a @@ -0,0 +1,339 @@ +;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package:CL-WHO; Base: 10 -*- +;;; $Header: /usr/local/cvsrep/cl-who/who.lisp,v 1.42 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) + +(defun html-mode () + "Returns the current HTML mode. :SGML for \(SGML-)HTML, :XML for +XHTML and :HTML5 for HTML5 (HTML syntax)." + *html-mode*) + +(defun (setf html-mode) (mode) + "Sets the output mode to XHTML or \(SGML-)HTML. MODE can be +:SGML for HTML, :XML for XHTML or :HTML5 for HTML5 (HTML syntax)." + (ecase mode + ((:sgml) + (setf *html-mode* :sgml + *empty-tag-end* ">" + *prologue* "")) + ((:xml) + (setf *html-mode* :xml + *empty-tag-end* " />" + *prologue* "")) + ((:html5) + (setf *html-mode* :html5 + *empty-tag-end* ">" + *prologue* "")))) + +(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) + 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 ((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)))) + (string *attribute-quote-char*)) + 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 + `(fmt " ~A" ,attr)) + ;; otherwise default to :xml mode + (t + `(fmt " ~A=~C~A~C" + ,attr + *attribute-quote-char* + ,attr + *attribute-quote-char*)))) + (t + (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 +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))) + (body-indent + ;; increase *INDENT* by 2 for body -- or disable it + (when (and *indent* (not (member tag *html-no-indent-tags* + :test #'string-equal))) + (+ 2 *indent*)))) + (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 + (let ((*indent* body-indent)) + (funcall body-fn body)) + (when body-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 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." + (loop for element in tree + if (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) + ;; list - insert as sexp + else if (consp element) + collect `(let ((*indent* ,*indent*)) + nil ;; If the element is (declare ...) it + ;; won't be interpreted as a declaration and an + ;; appropriate error could be signaled + ,element) + ;; something else - insert verbatim + else + collect 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-string total-size + #+:lispworks #+:lispworks + :element-type 'lw:simple-char)) + (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 (tree stream + &key prologue ((:indent *indent*) *indent*)) + (declare (optimize speed space)) + (when (and *indent* + (not (integerp *indent*))) + (setq *indent* 0)) + (let ((in-string-p t) + 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))) + (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 + &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." + (declare (ignore prologue)) + (multiple-value-bind (declarations forms) (extract-declarations body) + `(let ((,var ,(or stream var))) + ,@declarations + (check-type ,var stream) + (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 forms var rest))))) + +(defmacro with-html-output-to-string ((var &optional string-form + &key #-(or :ecl :cmu :sbcl) + (element-type + #-:lispworks ''character + #+:lispworks ''lw:simple-char) + 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." + (multiple-value-bind (declarations forms) (extract-declarations body) + `(with-output-to-string (,var ,string-form + #-(or :ecl :cmu :sbcl) :element-type + #-(or :ecl :cmu :sbcl) ,element-type) + ,@declarations + (with-html-output (,var nil :prologue ,prologue :indent ,indent) + ,@forms)))) + +;; 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))))