cl-who-1.1.4/ 0000775 0001750 0001750 00000000000 12436067373 011007 5 ustar edi edi cl-who-1.1.4/cl-who.asd 0000664 0001750 0001750 00000004161 12436067373 012673 0 ustar edi edi ;;; -*- 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))))
cl-who-1.1.4/specials.lisp 0000664 0001750 0001750 00000007630 12436067373 013511 0 ustar edi edi ;;; -*- 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.")
cl-who-1.1.4/packages.lisp 0000664 0001750 0001750 00000004663 12436067373 013467 0 ustar edi edi ;;; -*- 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*) cl-who-1.1.4/doc/ 0000775 0001750 0001750 00000000000 12436067373 011554 5 ustar edi edi cl-who-1.1.4/doc/index.html 0000664 0001750 0001750 00000127043 12436067373 013560 0 ustar edi edi
CL-WHO - Yet another Lisp markup language
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.
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)))
;; 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))))))))))
I
II
III
IV
V
VI
VII
VIII
IX
X
XI
XII
XIII
XIV
XV
XVI
XVII
XVIII
XIX
XX
XXI
XXII
XXIII
XXIV
XXV
;; 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 '("Fête" "Sørensen" "naïve" "Hühner" "Straße")
do (htm
(:p :style (conc "background-color:" (case (mod i 3)
((0) "red")
((1) "orange")
((2) "blue")))
(htm (esc string))))))
Look at the character entities generated by this example
Fête
Sørensen
naïve
Hühner
Straße
;; code generated by CL-WHO (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 '("Fête" "Sørensen" "naïve" "Hühner" "Straße")
do (progn
(write-string "<p style='" *http-stream*)
(princ (conc "background-color:"
(case (mod i 3)
((0) "red")
((1) "orange")
((2) "blue")))
*http-stream*)
(write-string "'>" *http-stream*)
(progn (write-string (escape-string string) *http-stream*))
(write-string "</p>" *http-stream*)))))
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.
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.
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:
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.
"foo" => (write-string "foo" s)
(Here and for the rest of this document the red arrow means '... will be converted to code equivalent to ...' where equivalent means that all output is sent to the "right" stream.)
Each list beginning with a keyword
is transformed into an (X)HTML tag of the same (usually downcased) name by the following rules:
If the list contains nothing but the keyword, the resulting tag
will be empty.
(:br) => (write-string "<br />" s)
With HTML-MODE set to :SGML an empty element is written this way:
(:br) => (write-string "<br>" s)
The initial keyword can be followed by another keyword which will be interpreted as the name of an attribute. The next form which will be taken as the attribute's value. (If there's no next form it'll be as if the next form had been NIL.) The form denoting the attribute's value will be treated as follows. (Note that the behaviour with respect to attributes is incompatible with versions earlier than 0.3.0!)
If it is T and HTML-MODE is :XML (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).
If it is NIL the attribute will be left out completely.
(:td :nowrap nil) => (write-string "<td />" s)
If it is a constant form, the result of evaluating it will be inserted into the resulting string as if printed with the format string"~A" at macro expansion time.
If it is any other form it will be left as is and later evaluated at run time and printed like with PRINCunless the value is T or NIL which will be treated as above. (It is the application developer's job to provide the correct printer control variables.)
;; simplified example, see function CHECKBOX below
;; note that this form is not necessarily CONSTANTP in all Lisps
(:table :border (+ 1 2)) => (write-string "<table border='" s)
(princ (+ 1 2) s)
(write-string "' />" s)
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.
The first form following either the tag's name itself or an attribute value which is not a keyword determines the beginning of the tag's content. This and all the following forms are subject to the transformation rules we're just describing.
Beginning with version 0.4.0 you can also use a syntax like that of LHTML where the tag and all attribute/value pairs are enclosed in an additional list:
* (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' />"
A keyword alone will be treated like a list containing only this keyword.
:hr => (write-string "<hr />" s)
A form which is neither a string nor a keyword nor a list beginning with a keyword will be left as is except for the following local macros:
Forms that look like (strform) will be substituted with
(let ((result form)) (when result (princ result s))).
(loop for i below 10 do (str i)) =>
(loop for i below 10 do
(let ((#:result i))
(when #:result (princ #:result *standard-output*))))
Forms that look like (fmtform*) will be substituted with (format s form*).
(loop for i below 10 do (fmt "~R" i)) => (loop for i below 10 do (format s "~R" i))
Forms that look like (escform) will be substituted with
(let ((result form)) (when result (write-string (escape-string result s)))).
If a form looks like (htmform*) then each of the forms will be subject to the transformation rules we're just describing, i.e. this is the body is wrapped with another invocation of WITH-HTML-OUTPUT.
(loop for i below 100 do (htm (:b "foo") :br))
=> (loop for i below 100 do (progn (write-string "<b>foo</b><br />" s)))
That's all. Note in particular that CL-WHO knows nothing 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, :foobar instead of :hr.
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 NILvar 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>
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.
This character is used as the quote character when building attributes. Defaults to the single quote #\'. Only other reasonable character is the double quote #\".
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.
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.
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.
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\">"
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.
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-stringstring &key test => escaped-string
This function will accept a string string and will replace every character for which test returns true with its character entity. The numeric character entities use decimal instead of hexadecimal values when HTML-MODE is set to :SGML because of compatibility reasons with old clients. test must be a function of one argument which accepts a character and returns a generalized boolean. The default is the value of *ESCAPE-CHAR-P*. Note the ESC shortcut described in Syntax and Semantics.
* (escape-string "<Hühner> 'naïve'")
"<Hühner> 'naïve'"
* (with-html-output-to-string (s)
(:b (esc "<Hühner> 'naïve'")))
"<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.0 Strict//EN\" \"http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd\"<b><Hühner> 'naïve'</b>"
[Function]
escape-charcharacter &key test => escaped-string
This function works identical to ESCAPE-STRING, except that it operates on characters instead of strings.
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)))
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
cl-who-1.1.4/util.lisp 0000664 0001750 0001750 00000023031 12436067373 012654 0 ustar edi edi ;;; -*- 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;" "~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;" "~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))))
cl-who-1.1.4/who.lisp 0000664 0001750 0001750 00000034125 12436067373 012502 0 ustar edi edi ;;; -*- 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 "" 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 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
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))))
cl-who-1.1.4/CHANGELOG 0000664 0001750 0001750 00000006240 12436067373 012223 0 ustar edi edi 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 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
cl-who-1.1.4/test/ 0000775 0001750 0001750 00000000000 12436067373 011766 5 ustar edi edi cl-who-1.1.4/test/packages.lisp 0000664 0001750 0001750 00000003117 12436067373 014437 0 ustar edi edi ;;; -*- 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)) cl-who-1.1.4/test/simple 0000664 0001750 0001750 00000031631 12436067373 013206 0 ustar edi edi ;;; -*- 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
(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))))))))))
"
I
II
III
IV
V
VI
VII
VIII
IX
X
XI
XII
XIII
XIV
XV
XVI
XVII
XVIII
XIX
XX
XXI
XXII
XXIII
XXIV
XXV
")
;;; 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 '("Fête" "Sørensen" "naïve" "Hühner" "Straße")
do (htm
(:p :style (conc "background-color:" (case (mod i 3)
((0) "red")
((1) "orange")
((2) "blue")))
(htm (esc string))))))
"
Look at the character entities generated by this example
")
cl-who-1.1.4/test/tests.lisp 0000664 0001750 0001750 00000014727 12436067373 014034 0 ustar edi edi ;;; -*- 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))