Dev version

git-svn-id: svn://bknr.net/svn/trunk/thirdparty/cl-who@4336 4281704c-cde7-0310-8518-8e2dc76b1ff0

3 files changed, 424 insertions, 0 deletions

diff --git a/test/packages.lisp b/test/packages.lisp
new file mode 100644
index 0000000..b41a38e
--- /dev/null
+++ b/test/packages.lisp
@@ -0,0 +1,34 @@
+;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*-
+;;; $Header: /usr/local/cvsrep/cl-who/test/packages.lisp,v 1.3 2009/01/26 11:10:52 edi Exp $
+
+;;; Copyright (c) 2008-2009, Dr. Edmund Weitz. All rights reserved.
+
+;;; Redistribution and use in source and binary forms, with or without
+;;; modification, are permitted provided that the following conditions
+;;; are met:
+
+;;;   * Redistributions of source code must retain the above copyright
+;;;     notice, this list of conditions and the following disclaimer.
+
+;;;   * Redistributions in binary form must reproduce the above
+;;;     copyright notice, this list of conditions and the following
+;;;     disclaimer in the documentation and/or other materials
+;;;     provided with the distribution.
+
+;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED
+;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
+;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+;;; ARE DISCLAIMED.  IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY
+;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
+;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
+;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
+;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
+;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
+;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
+;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+
+(in-package :cl-user)
+
+(defpackage :cl-who-test
+  (:use :cl :cl-who)
+  (:export :run-all-tests))
\ No newline at end of file
diff --git a/test/simple b/test/simple
new file mode 100644
index 0000000..128c62b
--- /dev/null
+++ b/test/simple
@@ -0,0 +1,240 @@
+;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-WHO-TEST; Base: 10 -*-
+;;; $Header: /usr/local/cvsrep/cl-who/test/simple,v 1.4 2009/01/26 11:10:52 edi Exp $
+
+;;; some simple tests for CL-WHO - entered manually and to be read
+;;; in the CL-WHO-TEST package; all forms are expected to return a
+;;; true value on success when EVALuated
+
+(string= (with-output-to-string (out)
+           (with-html-output (out)
+             (loop for (link . title) in '(("http://zappa.com/" . "Frank Zappa")
+                                           ("http://marcusmiller.com/" . "Marcus Miller")
+                                           ("http://www.milesdavis.com/" . "Miles Davis"))
+                   do (htm (:a :href link
+                            (:b (str title)))
+                           :br))))
+         "<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 />")
+
+(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))))
+         "<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 />")
+
+(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))))
+         "<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 />")
+
+(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)))
+         "<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 />")
+
+(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)))
+         "<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 />")
+
+(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)))
+         "<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 />")
+
+(eq (array-element-type
+     (with-html-output-to-string (out nil :element-type 'base-char)
+       (:br)))
+    'base-char)
+
+(string= (let ((*attribute-quote-char* #\"))
+           (with-html-output-to-string (out)
+             (loop for (link . title) in '(("http://zappa.com/" . "Frank Zappa")
+                                           ("http://marcusmiller.com/" . "Marcus Miller")
+                                           ("http://www.milesdavis.com/" . "Miles Davis"))
+                   do (htm (:a :href link
+                            (:b (str title)))
+                           :br))))
+         "<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 />")
+
+(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)))
+         "<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.0 Strict//EN\" \"http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd\">
+<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 />")
+
+(string= (with-html-output-to-string
+             (out nil :prologue "<!DOCTYPE math SYSTEM \"http://www.w3.org/Math/DTD/mathml1/mathml.dtd\">")
+           (:apply (:factorial) (:cn "3")))
+         "<!DOCTYPE math SYSTEM \"http://www.w3.org/Math/DTD/mathml1/mathml.dtd\">
+<apply><factorial></factorial><cn>3</cn></apply>")
+
+(string= (let ((*prologue* "<!DOCTYPE math SYSTEM \"http://www.w3.org/Math/DTD/mathml1/mathml.dtd\">"))
+           (with-html-output-to-string (out nil :prologue t)
+             (:apply (:factorial) (:cn "3"))))
+         "<!DOCTYPE math SYSTEM \"http://www.w3.org/Math/DTD/mathml1/mathml.dtd\">
+<apply><factorial></factorial><cn>3</cn></apply>")
+
+(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)))
+         "
+<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 />")
+
+(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)))
+         "
+<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 />")
+
+(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)))
+         "
+   <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 />")
+
+(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))))))))))
+         "<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>")
+
+(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))))))
+         "<h4>Look at the character entities generated by this example</h4><p style='background-color:red'>F&#xEA;te</p><p style='background-color:orange'>S&#xF8;rensen</p><p style='background-color:blue'>na&#xEF;ve</p><p style='background-color:red'>H&#xFC;hner</p><p style='background-color:orange'>Stra&#xDF;e</p>")
+
+(flet ((checkbox (stream name checked &optional value)
+         (with-html-output (stream)
+           (:input :type "checkbox" :name name :checked checked :value value))))
+  (and (string= (with-output-to-string (s) (checkbox s "foo" t))
+                "<input type='checkbox' name='foo' checked='checked' />")
+       (string= (with-output-to-string (s) (checkbox s "foo" nil))
+                "<input type='checkbox' name='foo' />")
+       (string= (with-output-to-string (s) (checkbox s "foo" nil "bar"))
+                "<input type='checkbox' name='foo' value='bar' />")
+       (string= (with-output-to-string (s) (checkbox s "foo" t "bar"))         
+                "<input type='checkbox' name='foo' checked='checked' value='bar' />")))
+
+(string= (with-html-output-to-string (out)
+           (:p))
+         "<p></p>")
+
+(string= (let ((*html-empty-tag-aware-p* nil))
+           (with-html-output-to-string (out)
+             (:p)))
+         "<p />")
+
+(string= (let ((*html-empty-tag-aware-p* t)
+               (*html-empty-tags* '(:p)))
+           (with-html-output-to-string (out)
+             (:p)))
+         "<p />")
+
+(string= (with-html-output-to-string (out)
+           (:|Foo| :bar 42))
+         "<foo bar='42'></foo>")
+
+(string= (let ((*downcase-tokens-p* nil))
+           (with-html-output-to-string (out)
+             (:|Foo| :bar 42)))
+         "<Foo BAR='42'></Foo>")
+
+(string= (let* ((list (list (make-string-output-stream) (make-string-output-stream)))
+                (stream (first list)))
+           (with-html-output (var (pop list))
+             (progn (htm (:br))))
+           (get-output-stream-string stream))
+         "<br />")
\ No newline at end of file
diff --git a/test/tests.lisp b/test/tests.lisp
new file mode 100644
index 0000000..44ea411
--- /dev/null
+++ b/test/tests.lisp
@@ -0,0 +1,150 @@
+;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package:CL-WHO-TEST; Base: 10 -*-
+;;; $Header: /usr/local/cvsrep/cl-who/test/tests.lisp,v 1.5 2009/01/26 11:10:52 edi Exp $
+
+;;; Copyright (c) 2008-2009, Dr. Edmund Weitz. All rights reserved.
+
+;;; Redistribution and use in source and binary forms, with or without
+;;; modification, are permitted provided that the following conditions
+;;; are met:
+
+;;;   * Redistributions of source code must retain the above copyright
+;;;     notice, this list of conditions and the following disclaimer.
+
+;;;   * Redistributions in binary form must reproduce the above
+;;;     copyright notice, this list of conditions and the following
+;;;     disclaimer in the documentation and/or other materials
+;;;     provided with the distribution.
+
+;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED
+;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
+;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+;;; ARE DISCLAIMED.  IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY
+;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
+;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
+;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
+;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
+;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
+;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
+;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+
+(in-package :cl-who-test)
+
+(defvar *initial-settings*
+  (list #\'
+        t
+        (lambda (char)
+          (or (find char "<>&'\"")
+              (> (char-code char) 127)))
+        t
+        '(:area
+          :atop
+          :audioscope
+          :base
+          :basefont
+          :br
+          :choose
+          :col
+          :frame
+          :hr
+          :img
+          :input
+          :isindex
+          :keygen
+          :left
+          :limittext
+          :link
+          :meta
+          :nextid
+          :of
+          :over
+          :param
+          :range   
+          :right
+          :spacer
+          :spot
+          :tab
+          :wbr)
+        "<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.0 Strict//EN\" \"http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd\">"))
+
+(defvar *this-file* (load-time-value
+                     (or #.*compile-file-pathname* *load-pathname*))
+  "The location of this source file.")
+
+(defmacro do-tests ((name &optional show-progress-p) &body body)
+  "Helper macro which repeatedly executes BODY until the code in body
+calls the function DONE.  It is assumed that each invocation of BODY
+will be the execution of one test which returns NIL in case of success
+and list of string describing errors otherwise.
+
+The macro prints a simple progress indicator \(one dots for ten tests)
+to *STANDARD-OUTPUT* unless SHOW-PROGRESS-P is NIL and returns a true
+value iff all tests succeeded.  Errors in BODY are caught and reported
+\(and counted as failures)."
+  `(let ((successp t)
+         (testcount 1))
+     (block test-block
+       (flet ((done ()
+                (return-from test-block successp)))
+         (format t "~&Test: ~A~%" ,name)
+         (loop
+          (when (and ,show-progress-p (zerop (mod testcount 1)))
+            (format t ".")
+            (when (zerop (mod testcount 10))
+              (terpri))
+            (force-output))
+          (let ((errors
+                 (handler-case
+                     (progn ,@body)
+                   (error (msg)
+                     (list (format nil "~&got an unexpected error: ~A" msg))))))
+            (setq successp (and successp (null errors)))
+            (when errors
+              (format t "~&~4@A:~{~&   ~A~}~%" testcount errors))
+            (incf testcount)))))
+     successp))
+
+(defun simple-tests (&key (file-name
+                           (make-pathname :name "simple"
+                                          :type nil :version nil
+                                          :defaults *this-file*))
+                          (external-format '(:latin-1 :eol-style :lf))
+                          verbose)
+  "Loops through all the forms in the file FILE-NAME and executes each
+of them using EVAL.  It is assumed that each FORM specifies a test
+which returns a true value iff it succeeds.  Prints each test form to
+*STANDARD-OUTPUT* if VERBOSE is true and shows a simple progress
+indicator otherwise.  EXTERNAL-FORMAT is the FLEXI-STREAMS external
+format which is used to read the file.  Returns a true value iff all
+tests succeeded."
+  (with-open-file (binary-stream file-name :element-type 'flex:octet)
+    (let ((stream (flex:make-flexi-stream binary-stream :external-format external-format))
+          (*package* (find-package :cl-who-test))
+          (html-mode (html-mode)))
+      (unwind-protect
+          (destructuring-bind (*attribute-quote-char*
+                               *downcase-tokens-p*
+                               *escape-char-p*
+                               *html-empty-tag-aware-p*
+                               *html-empty-tags*
+                               *prologue*)
+              *initial-settings*
+            (setf (html-mode) :xml)
+            (do-tests ((format nil "Simple tests from file ~S" (file-namestring file-name))
+                       (not verbose))
+              (let ((form (or (read stream nil) (done))))
+                (when verbose
+                  (format t "~&~S" form))
+                (cond ((eval form) nil)
+                      (t (list (format nil "~S returned NIL" form)))))))
+        (setf (html-mode) html-mode)))))
+
+(defun run-all-tests (&key verbose)
+  "Runs all tests for CL-WHO and returns a true value iff all tests
+succeeded.  VERBOSE is interpreted by the individual test suites."
+  (let ((successp t))
+    (macrolet ((run-test-suite (&body body)
+                 `(unless (progn ,@body)
+                    (setq successp nil))))
+      (run-test-suite (simple-tests :verbose verbose)))
+    (format t "~2&~:[Some tests failed~;All tests passed~]." successp)
+    successp))
\ No newline at end of file