Author: hhubner Date: 2007-10-08 00:39:27 -0400 (Mon, 08 Oct 2007) New Revision: 2232
Added: branches/trunk-reorg/thirdparty/cl-who-0.11.0/ branches/trunk-reorg/thirdparty/cl-who-0.11.0/CHANGELOG branches/trunk-reorg/thirdparty/cl-who-0.11.0/cl-who.asd branches/trunk-reorg/thirdparty/cl-who-0.11.0/doc/ branches/trunk-reorg/thirdparty/cl-who-0.11.0/doc/index.html branches/trunk-reorg/thirdparty/cl-who-0.11.0/packages.lisp branches/trunk-reorg/thirdparty/cl-who-0.11.0/specials.lisp branches/trunk-reorg/thirdparty/cl-who-0.11.0/who.lisp Removed: branches/trunk-reorg/thirdparty/cl-who-0.10.0/ Log: update cl-who
Added: branches/trunk-reorg/thirdparty/cl-who-0.11.0/CHANGELOG =================================================================== --- branches/trunk-reorg/thirdparty/cl-who-0.11.0/CHANGELOG 2007-10-07 23:19:21 UTC (rev 2231) +++ branches/trunk-reorg/thirdparty/cl-who-0.11.0/CHANGELOG 2007-10-08 04:39:27 UTC (rev 2232) @@ -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
Added: branches/trunk-reorg/thirdparty/cl-who-0.11.0/cl-who.asd =================================================================== --- branches/trunk-reorg/thirdparty/cl-who-0.11.0/cl-who.asd 2007-10-07 23:19:21 UTC (rev 2231) +++ branches/trunk-reorg/thirdparty/cl-who-0.11.0/cl-who.asd 2007-10-08 04:39:27 UTC (rev 2232) @@ -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")))
Added: branches/trunk-reorg/thirdparty/cl-who-0.11.0/doc/index.html =================================================================== --- branches/trunk-reorg/thirdparty/cl-who-0.11.0/doc/index.html 2007-10-07 23:19:21 UTC (rev 2231) +++ branches/trunk-reorg/thirdparty/cl-who-0.11.0/doc/index.html 2007-10-08 04:39:27 UTC (rev 2232) @@ -0,0 +1,807 @@ +<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.0 Transitional//EN"> +<html> + +<head> + <meta http-equiv="Content-Type" content="text/html; charset=iso-8859-1"> + <title>CL-WHO - Yet another Lisp markup language</title> + <style type="text/css"> + pre { padding:5px; background-color:#e0e0e0 } + h3, h4 { text-decoration: underline; } + a { text-decoration: none; padding: 1px 2px 1px 2px; } + a:visited { text-decoration: none; padding: 1px 2px 1px 2px; } + a:hover { text-decoration: none; padding: 1px 1px 1px 1px; border: 1px solid #000000; } + a:focus { text-decoration: none; padding: 1px 2px 1px 2px; border: none; } + a.none { text-decoration: none; padding: 0; } + a.none:visited { text-decoration: none; padding: 0; } + a.none:hover { text-decoration: none; border: none; padding: 0; } + a.none:focus { text-decoration: none; border: none; padding: 0; } + a.noborder { text-decoration: none; padding: 0; } + a.noborder:visited { text-decoration: none; padding: 0; } + a.noborder:hover { text-decoration: none; border: none; padding: 0; } + a.noborder:focus { text-decoration: none; border: none; padding: 0; } + pre.none { padding:5px; background-color:#ffffff } + </style> +</head> + +<body bgcolor=white> + +<h2>CL-WHO - Yet another Lisp markup language</h2> + +<blockquote> +<br> <br><h3><a name=abstract class=none>Abstract</a></h3> + +There are plenty of <a +href="http://www.cliki.net/Lisp%20Markup%20Languages%22%3ELisp Markup +Languages</a> out there - every Lisp programmer seems to write at +least one during his career - and CL-WHO (where <em>WHO</em> 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 <a +href="http://weitz.de/html-template/%22%3EHTML-TEMPLATE</a>. +<p> +I wrote this one in 2002 although at least Tim Bradshaw's <a +href="http://www.cliki.net/htout%22%3Ehtout</a> and <a +href="http://opensource.franz.com/aserve/aserve-dist/doc/htmlgen.html%22%3EAllegro... +HTML generation facilities</a> 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. +<p> +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 <code>WRITE-STRING</code> +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 <code>WRITE-STRING</code> forms with +constant strings - see +examples <a href="#show-html-expansion">below</a>. CL-WHO's output is +either XHTML (default) or 'plain' (SGML) HTML — depending on +what you've set <a href="#html-mode"><code>HTML-MODE</code></a> to. +<p> +CL-WHO is intended to be portable and should work with all +conforming Common Lisp implementations. <a +href="#mail">Let us know</a> if you encounter any +problems. +<p> +It comes with a <a +href="http://www.opensource.org/licenses/bsd-license.php%22%3EBSD-style +license</a> so you can basically do with it whatever you want. +<p> +CL-WHO is used by <a href="http://clutu.com/">clutu</a>, <a href="http://ergoweb.de/">ERGO</a>, and <a href="http://heikestephan.de/">Heike Stephan</a>. + +<p> +<font color=red>Download shortcut:</font> <a href="http://weitz.de/files/cl-who.tar.gz">http://weitz.de/files/cl-who.tar.gz</a>. +</blockquote> + +<br> <br><h3><a class=none name="contents">Contents</a></h3> +<ol> + <li><a href="#example">Example usage</a> + <li><a href="#install">Download and installation</a> + <li><a href="#mail">Support and mailing lists</a> + <li><a href="#syntax">Syntax and Semantics</a> + <li><a href="#dictionary">The CL-WHO dictionary</a> + <ol> + <li><a href="#with-html-output"><code>with-html-output</code></a> + <li><a href="#with-html-output-to-string"><code>with-html-output-to-string</code></a> + <li><a href="#show-html-expansion"><code>show-html-expansion</code></a> + <li><a href="#*attribute-quote-char*"><code>*attribute-quote-char*</code></a> + <li><a href="#*prologue*"><code>*prologue*</code></a> + <li><a href="#*html-empty-tag-aware-p*"><code>*html-empty-tag-aware-p*</code></a> + <li><a href="#*html-empty-tags*"><code>*html-empty-tags*</code></a> + <li><a href="#*downcase-tokens-p*"><code>*downcase-tokens-p*</code></a> + <li><a href="#esc"><code>esc</code></a> + <li><a href="#fmt"><code>fmt</code></a> + <li><a href="#htm"><code>htm</code></a> + <li><a href="#str"><code>str</code></a> + <li><a href="#html-mode"><code>html-mode</code></a> + <li><a href="#escape-string"><code>escape-string</code></a> + <li><a href="#escape-char"><code>escape-char</code></a> + <li><a href="#*escape-char-p*"><code>*escape-char-p*</code></a> + <li><a href="#escape-string-minimal"><code>escape-string-minimal</code></a> + <li><a href="#escape-string-minimal-plus-quotes"><code>escape-string-minimal-plus-quotes</code></a> + <li><a href="#escape-string-iso-8859"><code>escape-string-iso-8859</code></a> + <li><a href="#escape-string-iso-8859-1"><code>escape-string-iso-8859-1</code></a> + <li><a href="#escape-string-all"><code>escape-string-all</code></a> + <li><a href="#escape-char-minimal"><code>escape-char-minimal</code></a> + <li><a href="#escape-char-minimal-plus-quotes"><code>escape-char-minimal-plus-quotes</code></a> + <li><a href="#escape-char-iso-8859-1"><code>escape-char-iso-8859-1</code></a> + <li><a href="#escape-char-all"><code>escape-char-all</code></a> + <li><a href="#conc"><code>conc</code></a> + <li><a href="#convert-tag-to-string-list"><code>convert-tag-to-string-list</code></a> + <li><a href="#convert-attributes"><code>convert-attributes</code></a> + </ol> + <li><a href="#ack">Acknowledgements</a> +</ol> + +<br> <br><h3><a name="example" class=none>Example usage</a></h3> + +Let's assume that <code>*HTTP-STREAM*</code> 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. + +<table border=0 cellspacing=10 width="100%"> + +<tr> +<td bgcolor="#e0e0e0" valign=top><pre> +(<a class=noborder href="#with-html-output">with-html-output</a> (*http-stream*) + (loop for (link . title) in '(("http://zappa.com/%22; . "Frank Zappa") + ("http://marcusmiller.com/%22; . "Marcus Miller") + ("http://www.milesdavis.com/%22; . "Miles Davis")) + do (<a class=noborder href="#htm">htm</a> (:a :href link + (:b (str title))) + :br))) +</pre></td> + +<td valign=top rowspan=2> +<a href='http://zappa.com/'><b>Frank Zappa</b></a><br /><a href='http://marcusmiller.com/'><b>Marcus Miller</b></a><br /><a href='http://www.milesdavis.com/'><b>Miles Davis</b></a><br /> +</td> +</tr> + +<tr> +<td bgcolor="#e0e0e0" valign=top><pre> +<font color="orange">;; Code generated by CL-WHO</font> + +(let ((*http-stream* *http-stream*)) + (progn + nil + (loop for (link . title) in '(("http://zappa.com/%22; . "Frank Zappa") + ("http://marcusmiller.com/%22; . "Marcus Miller") + ("http://www.milesdavis.com/%22; . "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*))))) +</pre></td> +</tr> + +<tr> +<td bgcolor="#e0e0e0" valign=top><pre> +(<a class=noborder href="#with-html-output">with-html-output</a> (*http-stream*) + (:table :border 0 :cellpadding 4 + (loop for i below 25 by 5 + do (<a class=noborder href="#htm">htm</a> + (:tr :align "right" + (loop for j from i below (+ i 5) + do (<a class=noborder href="#htm">htm</a> + (:td :bgcolor (if (oddp j) + "pink" + "green") + (fmt "~@R" (1+ j)))))))))) +</pre></td> + +<td valign=top rowspan=2> +<table border='0' cellpadding='4'><tr align='right'><td bgcolor='green'>I</td><td bgcolor='pink'>II</td><td bgcolor='green'>III</td><td bgcolor='pink'>IV</td><td bgcolor='green'>V</td></tr><tr align='right'><td bgcolor='pink'>VI</td><td bgcolor='green'>VII</td><td bgcolor='pink'>VIII</td><td bgcolor='green'>IX</td><td bgcolor='pink'>X</td></tr><tr align='right'><td bgcolor='green'>XI</td><td bgcolor='pink'>XII</td><td bgcolor='green'>XIII</td><td bgcolor='pink'>XIV</td><td bgcolor='green'>XV</td></tr><tr align='right'><td bgcolor='pink'>XVI</td><td bgcolor='green'>XVII</td><td bgcolor='pink'>XVIII</td><td bgcolor='green'>XIX</td><td bgcolor='pink'>XX</td></tr><tr align='right'><td bgcolor='green'>XXI</td><td bgcolor='pink'>XXII</td><td bgcolor='green'>XXIII</td><td bgcolor='pink'>XXIV</td><td bgcolor='green'>XXV</td></tr></table> +</td> +</tr> + +<tr> +<td bgcolor="#e0e0e0" valign=top><pre> +<font color="orange">;; Code generated by CL-WHO</font> + +(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*))) +</pre></td> +</tr> + +<tr> +<td bgcolor="#e0e0e0" valign=top><pre> +(<a class=noborder href="#with-html-output">with-html-output</a> (*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 (<a class=noborder href="#htm">htm</a> + (:p :style (<a href="#conc">conc</a> "background-color:" (case (mod i 3) + ((0) "red") + ((1) "orange") + ((2) "blue"))) + (<a class=noborder href="#htm">htm</a> (<a href="#esc">esc</a> string)))))) +</pre></td> +<td valign=top rowspan=2> +<h4>Look at the character entities generated by this example</h4><p style='background-color:red'>Fête</p><p style='background-color:orange'>Sørensen</p><p style='background-color:blue'>naïve</p><p style='background-color:red'>Hühner</p><p style='background-color:orange'>Straße</p> +</td> +</tr> + +<tr> +<td bgcolor="#e0e0e0" valign=top><pre> +<font color="orange">;; Code generated by CL-WHO</font> + +(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 (<a class=noborder href="#conc">conc</a> "background-color:" + (case (mod i 3) + ((0) "red") + ((1) "orange") + ((2) "blue"))) + *http-stream*) + (write-string "'>" *http-stream*) + (progn (write-string (<a class=noborder href="#escape-string">escape-string</a> string) *http-stream*)) + (write-string "</p>" *http-stream*))))) +</pre></td> +</tr> + + +</table> + +<br> <br><h3><a name="install" class=none>Download and installation</a></h3> + +CL-WHO together with this documentation can be downloaded from <a +href="http://weitz.de/files/cl-who.tar.gz%22%3Ehttp://weitz.de/files/cl-who.tar.gz</a>. The +current version is 0.11.0. +<p> +The preferred method to compile and load Hunchentoot is via <a href="http://www.cliki.net/asdf">ASDF</a>. +<p> +If you're on <a href="http://www.debian.org/">Debian</a> you can +probably use +the <a +href="http://packages.debian.org/cgi-bin/search_packages.pl?keywords=cl-who&se... +Debian package</a> which is available thanks to Kevin +Rosenberg. There's also a port +for <a +href="http://www.gentoo.org/proj/en/common-lisp/index.xml%22%3EGentoo +Linux</a> thanks to Matthew Kennedy. In both cases, check if they have the newest version available. +<p> +Luís Oliveira maintains a <a href="http://darcs.net/">darcs</a> +repository of CL-WHO +at <a +href="http://common-lisp.net/~loliveira/ediware/%22%3Ehttp://common-lisp.net/~loli...</a>. + +<br> <br><h3><a name="mail" class=none>Support and mailing lists</a></h3> + +For questions, bug reports, feature requests, improvements, or patches +please use the <a +href="http://common-lisp.net/mailman/listinfo/cl-who-devel%22%3Ecl-who-devel +mailing list</a>. If you want to be notified about future releases +subscribe to the <a +href="http://common-lisp.net/mailman/listinfo/cl-who-announce%22%3Ecl-who-announce +mailing list</a>. These mailing lists were made available thanks to +the services of <a href="http://common-lisp.net/">common-lisp.net</a>. +<p> +If you want to send patches, please <a href="http://weitz.de/patches.html">read this first</a>. + +<br> <br><h3><a name="syntax" class=none>Syntax and Semantics</a></h3> + +CL-WHO is essentially just one <a +href="http://cl-cookbook.sourceforge.net/macros.html%22%3Emacro</a>, <a +href="#with-html-output"><code>WITH-HTML-OUTPUT</code></a>, which +transforms the body of code it encloses into something else obeying the +following rules (which we'll call <em>transformation rules</em>) for the body's forms: + +<ul> + + <li>A string will be printed verbatim. To be +more precise, it is transformed into a form which'll print this +string to the stream the user provides. + +<table border=0 cellpadding=2 cellspacing=3><tr><td><pre>"foo" <font color="red">=></font> (write-string "foo" s)</pre></td></tr></table> + + (Here and for the rest of this document the <em>red arrow</em> means '... will be converted to code equivalent to ...' where <em>equivalent</em> means that all output is sent to the "right" stream.) + + <li>Each list beginning with a <a +href="http://www.lispworks.com/reference/HyperSpec/Body/t_kwd.htm%22%3E<em>keyword</em></a> +is transformed into an (X)HTML <b>tag</b> of the same (usually <href="#*downcase-tokens-p*">downcased</a>) name by the following rules: + + <ul> + + <li>If the list contains nothing but the keyword, the resulting tag + will be empty. + + <table border=0 cellpadding=2 cellspacing=3><tr><td><pre>(:br) <font color="red">=></font> (write-string "<br />" s)</pre></td></tr></table> + With <a href="#html-mode"><code>HTML-MODE</code></a> set to <code>:SGML</code> an empty element is written this way: + <table border=0 cellpadding=2 cellspacing=3><tr><td><pre>(:br) <font color="red">=></font> (write-string "<br>" s)</pre></td></tr></table> + + <li>The initial keyword can be followed by another keyword which will be interpreted as the name of an <b>attribute</b>. The next form which will be taken as the attribute's <b>value</b>. (If there's no next form it'll be as if the next form had been <code>NIL</code>.) The form denoting the attribute's value will be treated as follows. (Note that the behaviour with respect to attributes is <em>incompatible</em> with versions earlier than 0.3.0!) + <ul> + <li>If it is a string it will be printed literally. + + <table border=0 cellpadding=2 cellspacing=3><tr><td><pre>(:td :bgcolor "red") <font color="red">=></font> (write-string "<td bgcolor='red' />" s)</pre></td></tr></table> + + <li>If it is <code>T</code> and <a href="#html-mode"><code>HTML-MODE</code></a> is <code>:XML</code> (default) the attribute's value will be the attribute's name (following XHTML convention to denote attributes which don't have a value in HTML). + + <table border=0 cellpadding=2 cellspacing=3><tr><td><pre>(:td :nowrap t) <font color="red">=></font> (write-string "<td nowrap='nowrap' />" s)</pre></td></tr></table> + + With <a href="#html-mode"><code>HTML-MODE</code></a> set to <code>:SGML</code>: + + <table border=0 cellpadding=2 cellspacing=3><tr><td><pre>(:td :nowrap t) <font color="red">=></font> (write-string "<td nowrap>" s)</pre></td></tr></table> + + <li>If it is <code>NIL</code> the attribute will be left out completely. + + <table border=0 cellpadding=2 cellspacing=3><tr><td><pre>(:td :nowrap nil) <font color="red">=></font> (write-string "<td />" s)</pre></td></tr></table> + + <li>If it is a <a + href="http://www.lispworks.com/reference/HyperSpec/Body/26_glo_c.htm#constant_form...<em>constant form</em></a>, the result of evaluating it will be inserted into the resulting string as if printed with the <a + href="http://www.lispworks.com/reference/HyperSpec/Body/26_glo_c.htm#constant_form... string</a> <code>"~A"</code> at macro expansion time. + + <table border=0 cellpadding=2 cellspacing=3><tr><td><pre>(:table :border 3) <font color="red">=></font> (write-string "<table border='3' />" s)</pre></td></tr></table> + + <li>If it is any other form it will be left as is and later evaluated at run time and printed with <a + href="http://www.lispworks.com/reference/HyperSpec/Body/f_wr_pr.htm%22%3E<code>PRINC</code></a> <em>unless</em> the value is <code>T</code> or <code>NIL</code> which will be treated as above. (It is the application developer's job to provide the correct <a href="http://www.lispworks.com/reference/HyperSpec/Body/26_glo_p.htm#printer_control_variable">printer control variables</a>.) + + <table border=0 cellpadding=2 cellspacing=3><tr><td><pre><font color="orange">;; simplified example, see function CHECKBOX below +;; note that this form is not necessarily CONSTANTP in all Lisps</font> + +(:table :border (+ 1 2)) <font color="red">=></font> (write-string "<table border='" s) + (princ (+ 1 2) s) + (write-string "' />" s)</pre></td></tr></table> + </ul> + + <li>Once an attribute/value pair has been worked up another one can follow, i.e. if the form following an attribute's value is again a keyword it will again be treated as an attribute and so on. + + <table border=0 cellpadding=2 cellspacing=3><tr><td><pre>(:table :border 0 :cellpadding 5 :cellspacing 5) + <font color="red">=></font> (write-string "<table border='0' cellpadding='5' cellspacing='5' />" s)</pre></td></tr></table> + + <li>The first form following either the tag's name itself or an attribute value which is <em>not</em> a keyword determines the beginning of the tag's <b>content</b>. This and all the following forms are subject to the transformation rules we're just describing. + + <table border=0 cellpadding=2 cellspacing=3><tr><td><pre>(:p "Paragraph") <font color="red">=></font> (write-string "<p>Paragraph</p>" s) +(:p :class "foo" "Paragraph") <font color="red">=></font> (write-string "<p class='foo'>Paragraph</p>" s) +(:p :class "foo" "One" " " "long" " " "sentence") <font color="red">=></font> (write-string "<p class='foo'>One long sentence</p>" s) +(:p :class "foo" "Visit " (:a :href "http://www.cliki.net/%22; "CLiki")) + <font color="red">=></font> (write-string "<p class='foo'>Visit <a href='http://www.cliki.net/%27%3ECLiki%3C/a%3E%3C/p%3E%22; s)</pre></td></tr></table> + + <li>Beginning with <a href="#install">version 0.4.0</a> you can also use a syntax like that of <a href="http://opensource.franz.com/xmlutils/xmlutils-dist/phtml.htm">LHTML</a> where the tag and all attribute/value pairs are enclosed in an additional list: + + <table border=0 cellpadding=2 cellspacing=3><tr><td><pre>((:p) "Paragraph") <font color="red">=></font> (write-string "<p>Paragraph</p>" s) +((:p :class "foo") "Paragraph") <font color="red">=></font> (write-string "<p class='foo'>Paragraph</p>" s) +((:p :class "foo" :name "humpty-dumpty") "One" " " "long" " " "sentence") + <font color="red">=></font> (write-string "<p class='foo' name='humpty-dumpty'>One long sentence</p>" s) +((:p :class "foo") "Visit " ((:a :href "http://www.cliki.net/%22;) "CLiki")) + <font color="red">=></font> (write-string "<p class='foo'>Visit <a href='http://www.cliki.net/%27%3ECLiki%3C/a%3E%3C/p%3E%22; s)</pre></td></tr></table> + + </ul> + + Here's a slightly more elaborate example: +<pre> +* (defun checkbox (stream name checked &optional value) + (with-html-output (stream) + (:input :type "checkbox" :name name :checked checked :value value))) + +CHECKBOX +* (with-output-to-string (s) (checkbox s "foo" t)) + +"<input type='checkbox' name='foo' checked='checked' />" +* (with-output-to-string (s) (checkbox s "foo" nil)) + +"<input type='checkbox' name='foo' />" +* (with-output-to-string (s) (checkbox s "foo" nil "bar")) + +"<input type='checkbox' name='foo' value='bar' />" +* (with-output-to-string (s) (checkbox s "foo" t "bar")) + +"<input type='checkbox' name='foo' checked='checked' value='bar' />" +</pre> + + <li>A keyword alone will be treated like a list containing only this keyword. + +<table border=0 cellpadding=2 cellspacing=3><tr><td><pre>:hr <font color="red">=></font> (write-string "<hr />" s)</pre></td></tr></table> + + <li>A form which is neither a string nor a keyword nor a list beginning with a keyword will be left as is except for the following <em>substitutions</em>: + <ul> + <li>Forms that look like <code>(<b>str</b> <i>form1</i> <i>form*</i>)</code> will be substituted with + <span style="white-space: nowrap"><code>(let ((result <i>form1</i>)) (when result (princ result s)))</code></span>. <br> + (Note that all forms behind <code><i>form1</i></code> are ignored.) + +<table border=0 cellpadding=2 cellspacing=3><tr><td><pre>(loop for i below 10 do (str i)) <font color="red">=></font> +(loop for i below 10 do + (let ((#:result i)) + (when #:result (princ #:result *standard-output*))))</pre></td></tr></table> + + <li>Forms that look like <code>(<b>fmt</b> <i>form*</i>)</code> will be substituted with <code>(format s <i>form*</i>)</code>. + +<table border=0 cellpadding=2 cellspacing=3><tr><td><pre>(loop for i below 10 do (fmt "~R" i)) <font color="red">=></font> (loop for i below 10 do (format s "~R" i))</pre></td></tr></table> + <li>Forms that look like <code>(<b>esc</b> <i>form1</i> <i>form*</i>)</code> will be substituted with + <span style="white-space: nowrap"><code>(let ((result <i>form1</i>)) (when result (write-string (<a href="#escape-string">escape-string</a> result s))))</code></span>. + + <li>If a form looks like <code>(<b>htm</b> <i>form*</i>)</code> then each of the <code><i>forms</i></code> will be subject to the transformation rules we're just describing. + +<table border=0 cellpadding=2 cellspacing=3><tr><td><pre>(loop for i below 100 do (htm (:b "foo") :br)) + <font color="red">=></font> (loop for i below 100 do (progn (write-string "<b>foo</b><br />" s)))</pre></td></tr></table> + + + </ul> + + <li>That's all. Note in particular that CL-WHO knows <em>nothing</em> about HTML or XHTML, i.e. it doesn't check whether you mis-spelled tag names or use attributes which aren't allowed. CL-WHO doesn't care if you use, say, <code>:foobar</code> instead of <code>:hr</code>. +</ul> + +<br> <br><h3><a class=none name="dictionary">The CL-WHO dictionary</a></h3> + +CL-WHO exports the following symbols: + +<p><br>[Macro] +<br><a class=none name="with-html-output"><b>with-html-output</b> <i>(var <tt>&optional</tt> stream <tt>&key</tt> prologue indent) declaration* form*</i> => <i>result*</i></a> + +<blockquote><br> +This is the main macro of CL-WHO. It will transform its body by the transformation rules described in <a href="#syntax"><em>Syntax and Semantics</em></a> such that the output generated is sent to the stream denoted by <code><i>var</i></code> and <code><i>stream</i></code>. <code><i>var</i></code> must be a symbol. If <code><i>stream</i></code> is <code>NIL</code> it is assumed that <code><i>var</i></code> is already bound to a stream, if <code><i>stream</i></code> is not <code>NIL</code> <code><i>var</i></code> will be bound to the form <code><i>stream</i></code> which will be evaluated at run time. <code><i>prologue</i></code> should be a string (or <code>NIL</code> 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 <code><i>prologue</i></code> is <code>T</code> the prologue string is the value of <a href="#*prologue*"><code>*PROLOGUE*</code></a>. CL-WHO will usually try not to insert any unnecessary whitespace in order to save bandwidth. However, if <code><i>indent</i></code> is <em>true</em> line breaks will be inserted and nested tags will be intended properly. The value of <code><i>indent</i></code> - if it is an integer - will be taken as the initial indentation. If it is not an integer it is assumed to mean <code>0</code>. The <code><i>results</i></code> are the values returned by the <code><i>forms</i></code>. +<p> +Note that the keyword arguments <code><i>prologue</i></code> and <code><i>indent</i></code> are used at macro expansion time. + +<pre> +* (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%22%3E%3Chtml%3E%3Cbody%3EN... 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%22%3E; +<html> + <body bgcolor='white'> + Not much there + </body> +</html> +</pre> +</blockquote> + +<p><br>[Macro] +<br><a class=none name="with-html-output-to-string"><b>with-html-output-to-string</b> <i>(var <tt>&optional</tt> string-form <tt>&key</tt> element-type prologue indent) declaration* form*</i> => <i>result*</i></a> + +<blockquote><br> +This is just a thin wrapper around <a href="#with-html-output"><code>WITH-HTML-OUTPUT</code></a>. Indeed, the wrapper is so thin that the best explanation probably is to show its definition: +<pre> +(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))) +</pre> +Note that the <code><i>results</i></code> of this macro are determined by the behaviour of <a href="http://www.lispworks.com/reference/HyperSpec/Body/m_w_out_.htm"><code>WITH-OUTPUT-TO-STRING</code></a>. +</blockquote> + +<p><br>[Macro] +<br><a class=none name="show-html-expansion"><b>show-html-expansion</b> <i>(var <tt>&optional</tt> stream <tt>&key</tt> prologue indent) declaration* form*</i> => <tt><no values></tt></a> + +<blockquote><br> +This macro is intended for debugging purposes. It'll print to <code>*STANDARD-OUTPUT*</code> the code which would have been generated by <a href="#with-html-output"><code>WITH-HTML-OUTPUT</code></a> had it been invoked with the same arguments. + +<pre> +* (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))) +</pre> +</blockquote> + +<p><br>[Special variable] +<br><a class=none name="*attribute-quote-char*"><b>*attribute-quote-char*</b></a> + +<blockquote><br> +This character is used as the quote character when building attributes. Defaults to the single quote <code>#'</code>. Only other reasonable character is the double quote <code>#"</code>. +</blockquote> + +<p><br>[Special variable] +<br><a class=none name="*prologue*"><b>*prologue*</b></a> + +<blockquote><br> +This is the prologue string which will be printed if the <code><i>prologue</i></code> keyword argument to <a href="#with-html-output"><code>WITH-HTML-OUTPUT</code></a> is <code>T</code>. Gets changed when you set <a href="#html-mode"><code>HTML-MODE</code></a>. Its initial value is + +<pre>"<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Strict//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd%5C%22%3E%22;</pre> +</blockquote> + +<p><br>[Special variable] +<br><a class=none name="*html-empty-tag-aware-p*"><b>*html-empty-tag-aware-p*</b></a> + +<blockquote><br> +Set this to <code>NIL</code> to if you want to use CL-WHO as a strict XML +generator. Otherwise, CL-WHO will only write empty tags listed in +<a href="#*html-empty-tags*"><code>*HTML-EMPTY-TAGS*</code></a> as <code><tag/></code> (XHTML mode) or <code><tag></code> (SGML mode). For +all other tags, it will always generate <code><tag></tag></code>. The initial value of this variable is <code>T</code>. +</blockquote> + +<p><br>[Special variable] +<br><a class=none name="*html-empty-tags*"><b>*html-empty-tags*</b></a> + +<blockquote><br> +The list of HTML tags that should be output as empty tags. See +<a href="#*html-empty-tag-aware-p*"><code>*HTML-EMPTY-TAG-AWARE-P*</code></a>. +The initial value is the list +<pre> +(: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) +</pre> +</blockquote> + +<p><br>[Special variable] +<br><a class=none name="*downcase-tokens-p*"><b>*downcase-tokens-p*</b></a> + +<blockquote><br> +If the value of this variable is <code>NIL</code>, 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 <code>T</code>. +</blockquote> + +<p><br>[Symbol] +<br><a class=none name="esc"><b>esc</b></a> +<br>[Symbol] +<br><a class=none name="fmt"><b>fmt</b></a> +<br>[Symbol] +<br><a class=none name="htm"><b>htm</b></a> +<br>[Symbol] +<br><a class=none name="str"><b>str</b></a> + +<blockquote><br> +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 <a href="#syntax"><em>Syntax and Semantics</em></a>. +</blockquote> + +<p><br>[Accessor] +<br><a class=none name="html-mode"><b>html-mode</b></a> <i>=> mode</i> +<br><tt>(setf (</tt><b>html-mode</b>) <i>mode</i><tt>)</tt> +<blockquote><br> +The function <code>HTML-MODE</code> returns the current mode for generating HTML. The default is <code>:XML</code> for XHTML. You can change this by setting it with <code>(SETF (HTML-MODE) :SGML)</code> to pre-XML HTML mode. +<p> +Setting it to SGML HTML sets the <a href="#*prologue*"><code>*prologue*</code></a> to the doctype string for HTML 4.01 transitional: +<pre><!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01 Transitional//EN" "http://www.w3.org/TR/html4/loose.dtd%22%3E;</pre> +Code generation in SGML HTML is slightly different from XHTML - there's no need to end empty elements with <code>/></code> and empty attributes are allowed. +</blockquote> + +<p><br>[Function] +<br><a class=none name="escape-string"><b>escape-string</b></a> <i>string <tt>&key</tt> test</i> => <i>escaped-string</i> + +<blockquote><br> +This function will accept a string <code><i>string</i></code> and will replace every character for which <code><i>test</i></code> returns <em>true</em> with its character entity. The numeric character entities use decimal instead of hexadecimal values when <a href="#html-mode"><code>HTML-MODE</code></a> is set to <code>:SGML</code> because of compatibility reasons with old clients. <code><i>test</i></code> must be a function of one argument which accepts a character and returns a <a href="http://www.lispworks.com/reference/HyperSpec/Body/26_glo_g.htm#generalized_boolean">generalized boolean</a>. The default is the value of <a href="#*escape-char-p*"><code>*ESCAPE-CHAR-P*</code></a>. Note the <a href="#esc"><code>ESC</code></a> shortcut described in <a href="#syntax"><em>Syntax and Semantics</em></a>. + +<pre> +* (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%5C%22%3Cb%3E<H&...; &#x27;na&#xEF;ve&#x27;</b>" +</pre> +</blockquote> + +<p><br>[Function] +<br><a class=none name="escape-char"><b>escape-char</b></a> <i>character <tt>&key</tt> test</i> => <i>escaped-string</i> + +<blockquote><br> +This function works identical to <a href="#escape-string"><code>ESCAPE-STRING</code></a>, except that it operates on characters instead of strings. +</blockquote> + +<p><br>[Special variable] +<br><a class=none name="*escape-char-p*"><b>*escape-char-p*</b></a> + +<blockquote><br> +This is the default for the <code><i>test</i></code> keyword argument to <a href="#escape-string"><code>ESCAPE-STRING</code></a> and <a href="#escape-char"><code>ESCAPE-CHAR</code></a>. Its initial value is + +<pre> +#'(lambda (char) + (or (find char "<>&'"") + (> (char-code char) 127))) +</pre> +</blockquote> + +<p><br>[Function] +<br><a class=none name="escape-string-minimal"><b>escape-string-minimal</b> <i>string</i> => <i>escaped-string</i></a> +<br>[Function] +<br><a class=none name="escape-string-minimal-plus-quotes"><b>escape-string-minimal-plus-quotes</b> <i>string</i> => <i>escaped-string</i></a> +<br>[Function] +<br><a class=none name="escape-string-iso-8859-1"><b>escape-string-iso-8859-1</b> <i>string</i> => <i>escaped-string</i></a> +<br>[Function] +<br><a class=none name="escape-string-iso-8859"><b>escape-string-iso-8859</b> <i>string</i> => <i>escaped-string</i></a> +<br>[Function] +<br><a class=none name="escape-string-all"><b>escape-string-all</b> <i>string</i> => <i>escaped-string</i></a> +<br>[Function] +<br><a class=none name="escape-char-minimal"><b>escape-char-minimal</b> <i>character</i> => <i>escaped-string</i></a> +<br>[Function] +<br><a class=none name="escape-char-minimal-plus-quotes"><b>escape-char-minimal-plus-quotes</b> <i>character</i> => <i>escaped-string</i></a> +<br>[Function] +<br><a class=none name="escape-char-iso-8859-1"><b>escape-char-iso-8859-1</b> <i>character</i> => <i>escaped-string</i></a> +<br>[Function] +<br><a class=none name="escape-char-all"><b>escape-char-all</b> <i>character</i> => <i>escaped-string</i></a> + +<blockquote><br> These are convenience function based +on <a href="#escape-string"><code>ESCAPE-STRING</code></a> +and <a href="#escape-char"><code>ESCAPE-CHAR</code></a>. The string +functions are defined in a way similar to this one: + +<pre> +(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))))) +</pre> +The character functions are defined in an analogous manner. +</blockquote> + +<p><br>[Function] +<br><a class=none name="conc"><b>conc</b> <i><tt>&rest</tt> string-list</i> => <i>string</i></a> + +<blockquote><br> +Utility function to concatenate all arguments (which should be strings) into one string. Meant to be used mainly with attribute values. + +<pre> +* (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>" +</pre> +</blockquote> + +<p><br>[Generic Function] +<br><a class=none name="convert-tag-to-string-list"><b>convert-tag-to-string-list</b></a> <i>tag attr-list body body-fn</i> => <i>strings-or-forms</i> + +<blockquote><br> + +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. +<p> +<code><i>tag</i></code> is a keyword symbol naming the outer tag, +<code><i>attr-list</i></code> is an alist of its attributes (the car +is the attribute's name as a keyword, the cdr is its value), +<code><i>body</i></code> is the tag's body, and +<code><i>body-fn</i></code> 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 <code><i>body-fn</i></code> if you want. +<p> +Here are some simple examples: +<pre> +* (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" + (<a class=noborder href="#convert-attributes">convert-attributes</a> (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 + <font color=orange>;; you could as well invoke CALL-NEXT-METHOD here, of course</font> + (nconc (cons "<table " + (<a class=noborder href="#convert-attributes">convert-attributes</a> 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))) +</pre> + +</blockquote> + +<p><br>[Function] +<br><a class=none name="convert-attributes"><b>convert-attributes</b></a> <i>attr-list</i> => <i>strings-or-forms</i> + +<blockquote><br> + +This is a helper function which can be called from +<a href="#convert-tag-to-string-list"><code>CONVERT-TAG-TO-STRING-LIST</code></a> to process the list of attributes. + +</blockquote> + +<br> <br><h3><a class=none name="ack">Acknowledgements</a></h3> + +Thanks to Tim Bradshaw and John Foderaro for the inspiration provided +by their libraries mentioned <a href="#abstract">above</a>. 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. + +<p> +$Header: /usr/local/cvsrep/cl-who/doc/index.html,v 1.58 2007/08/24 08:01:40 edi Exp $ +<p><a href="http://weitz.de/index.html">BACK TO MY HOMEPAGE</a> + +</body> +</html>
Added: branches/trunk-reorg/thirdparty/cl-who-0.11.0/packages.lisp =================================================================== --- branches/trunk-reorg/thirdparty/cl-who-0.11.0/packages.lisp 2007-10-07 23:19:21 UTC (rev 2231) +++ branches/trunk-reorg/thirdparty/cl-who-0.11.0/packages.lisp 2007-10-08 04:39:27 UTC (rev 2232) @@ -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
Added: branches/trunk-reorg/thirdparty/cl-who-0.11.0/specials.lisp =================================================================== --- branches/trunk-reorg/thirdparty/cl-who-0.11.0/specials.lisp 2007-10-07 23:19:21 UTC (rev 2231) +++ branches/trunk-reorg/thirdparty/cl-who-0.11.0/specials.lisp 2007-10-08 04:39:27 UTC (rev 2232) @@ -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* + "<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.0 Strict//EN\" \"http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd\">" + "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 <tag/> (XHTML mode) or <tag> (SGML +mode). For all other tags, it will always generate +<tag></tag>.") + +(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.") +
Property changes on: branches/trunk-reorg/thirdparty/cl-who-0.11.0/specials.lisp ___________________________________________________________________ Name: svn:executable + *
Added: branches/trunk-reorg/thirdparty/cl-who-0.11.0/who.lisp =================================================================== --- branches/trunk-reorg/thirdparty/cl-who-0.11.0/who.lisp 2007-10-07 23:19:21 UTC (rev 2231) +++ branches/trunk-reorg/thirdparty/cl-who-0.11.0/who.lisp 2007-10-08 04:39:27 UTC (rev 2232) @@ -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* "<!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 4.01 Transitional//EN\" \"http://www.w3.org/TR/html4/loose.dtd\">")) + ((:xml) + (setf *html-mode* :xml + *empty-tag-end* " />" + *prologue* "<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.0 Strict//EN\" \"http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd\">")))) + +(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 "</" tag ">")) + ;; 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 ">" "</" tag ">")))))) + +(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 http://common-lisp.net/project/hyperdoc/ +;; and http://www.cliki.net/hyperdoc +;; 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))))