Author: junrue Date: Sun Aug 13 01:52:01 2006 New Revision: 212 Added: trunk/src/external-libraries/lisp-unit/ trunk/src/external-libraries/lisp-unit/lisp-unit.lisp trunk/src/external-libraries/lisp-unit/readme.txt Modified: trunk/README.txt trunk/build.lisp trunk/graphic-forms-tests.asd trunk/src/tests/uitoolkit/icon-bundle-unit-tests.lisp trunk/src/tests/uitoolkit/test-utils.lisp trunk/tests.lisp Log: upgraded to latest lisp-unit, now bundling lisp-unit under external-libraries Modified: trunk/README.txt ============================================================================== --- trunk/README.txt (original) +++ trunk/README.txt Sun Aug 13 01:52:01 2006 @@ -14,6 +14,7 @@ - ASDF http://cvs.sourceforge.net/cgi-bin/viewcvs.cgi/cclan/asdf/ + *note: ASDF is bundled with SBCL* - Cells (latest from CVS) http://www.common-lisp.net/project/cells/ @@ -27,12 +28,20 @@ - Closer to MOP http://common-lisp.net/project/closer/downloads.html - - ImageMagick 6.2.6.5-Q16 - http://www.imagemagick.org/download/binaries/ImageMagick-6.2.6-5-Q16-windows... +The following libraries are bundled with Graphic-Forms, thus do not need +to be downloaded separately: + + - Practical Common Lisp Chapter08 and Chapter24 + http://www.gigamonkeys.com/book/practicals-1.0.3.tar.gz - lisp-unit http://www.cs.northwestern.edu/academics/courses/325/readings/lisp-unit.html +The following libraries are optional: + + - ImageMagick 6.2.6.5-Q16 + http://www.imagemagick.org/download/binaries/ImageMagick-6.2.6-5-Q16-windows... + Supported Common Lisp Implementations ------------------------------------- Modified: trunk/build.lisp ============================================================================== --- trunk/build.lisp (original) +++ trunk/build.lisp Sun Aug 13 01:52:01 2006 @@ -49,7 +49,7 @@ (setf *closer-mop-dir* (concatenate 'string *asdf-repo-root* "closer-mop/")) (setf *lw-compat-dir* (concatenate 'string *asdf-repo-root* "lw-compat/")) (setf *gf-dir* (concatenate 'string *project-root* "graphic-forms/")) -(setf *lisp-unit-file* (concatenate 'string *library-root* "lisp-unit")) +(setf *lisp-unit-file* (concatenate 'string *gf-dir* "src/external-libraries/lisp-unit/lisp-unit")) (setf *binary-data-dir* (concatenate 'string *gf-dir* "src/external-libraries/practicals-1.0.3/Chapter08/")) (setf *macro-utilities-dir* (concatenate 'string *gf-dir* "src/external-libraries/practicals-1.0.3/Chapter24/")) Modified: trunk/graphic-forms-tests.asd ============================================================================== --- trunk/graphic-forms-tests.asd (original) +++ trunk/graphic-forms-tests.asd Sun Aug 13 01:52:01 2006 @@ -31,6 +31,8 @@ ;;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. ;;;; +(load gfsys::*lisp-unit-file*) + (defpackage #:graphic-forms.uitoolkit.tests (:nicknames #:gft) (:use :common-lisp :lisp-unit) @@ -78,16 +80,7 @@ ((:module "uitoolkit" :serial t :components - ((:file "test-utils") - (:file "mock-objects") - (:file "color-unit-tests") - (:file "graphics-context-unit-tests") - (:file "image-unit-tests") - (:file "icon-bundle-unit-tests") - (:file "layout-unit-tests") - (:file "widget-unit-tests") - (:file "misc-unit-tests") - (:file "hello-world") + ((:file "hello-world") (:file "event-tester") (:file "layout-tester") (:file "image-tester") Added: trunk/src/external-libraries/lisp-unit/lisp-unit.lisp ============================================================================== --- (empty file) +++ trunk/src/external-libraries/lisp-unit/lisp-unit.lisp Sun Aug 13 01:52:01 2006 @@ -0,0 +1,429 @@ +;;;-*- Mode: Lisp; Package: LISP-UNIT -*- + +#| +Copyright (c) 2004-2005 Christopher K. Riesbeck + +Permission is hereby granted, free of charge, to any person obtaining +a copy of this software and associated documentation files (the "Software"), +to deal in the Software without restriction, including without limitation +the rights to use, copy, modify, merge, publish, distribute, sublicense, +and/or sell copies of the Software, and to permit persons to whom the +Software is furnished to do so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included +in all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS +OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL +THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR +OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, +ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR +OTHER DEALINGS IN THE SOFTWARE. +|# + + +;;; A test suite package, modelled after JUnit. +;;; Author: Chris Riesbeck +;;; +;;; Update history: +;;; +;;; 04/07/06 added ~<...~> to remaining error output forms [CKR] +;;; 04/06/06 added ~<...~> to compact error output better [CKR] +;;; 04/06/06 fixed RUN-TESTS to get tests dynamically (bug reported +;;; by Daniel Edward Burke) [CKR] +;;; 02/08/06 added newlines to error output [CKR] +;;; 12/30/05 renamed ASSERT-PREDICATE to ASSERT-EQUALITY [CKR] +;;; 12/29/05 added ASSERT-EQ, ASSERT-EQL, ASSERT-EQUALP [CKR] +;;; 12/22/05 recoded use-debugger to use handler-bind, added option to prompt for debugger, +;;; 11/07/05 added *use-debugger* and assert-predicate [DFB] +;;; 09/18/05 replaced Academic Free License with MIT Licence [CKR] +;;; 08/30/05 added license notice [CKR] +;;; 06/28/05 changed RUN-TESTS to compile code at run time, not expand time [CKR] +;;; 02/21/05 removed length check from SET-EQUAL [CKR] +;;; 02/17/05 added RUN-ALL-TESTS [CKR] +;;; 01/18/05 added ASSERT-EQUAL back in [CKR] +;;; 01/17/05 much clean up, added WITH-TEST-LISTENER [CKR] +;;; 01/15/05 replaced ASSERT-EQUAL etc. with ASSERT-TRUE and ASSERT-FALSE [CKR] +;;; 01/04/05 changed COLLECT-RESULTS to echo output on *STANDARD-OUTPuT* [CKR] +;;; 01/04/05 added optional package argument to REMOVE-ALL-TESTS [CKR] +;;; 01/04/05 changed OUTPUT-OK-P to trim spaces and returns [CKR] +;;; 01/04/05 changed OUTPUT-OK-P to not check output except when asked to [CKR] +;;; 12/03/04 merged REMOVE-TEST into REMOVE-TESTS [CKR] +;;; 12/03/04 removed ability to pass forms to RUN-TESTS [CKR] +;;; 12/03/04 refactored RUN-TESTS expansion into RUN-TEST-THUNKS [CKR] +;;; 12/02/04 changed to group tests under packages [CKR] +;;; 11/30/04 changed assertions to put expected value first, like JUnit [CKR] +;;; 11/30/04 improved error handling and summarization [CKR] +;;; 11/30/04 generalized RUN-TESTS, removed RUN-TEST [CKR] +;;; 02/27/04 fixed ASSERT-PRINTS not ignoring value [CKR] +;;; 02/07/04 fixed ASSERT-EXPANDS failure message [CKR] +;;; 02/07/04 added ASSERT-NULL, ASSERT-NOT-NULL [CKR] +;;; 01/31/04 added error handling and totalling to RUN-TESTS [CKR] +;;; 01/31/04 made RUN-TEST/RUN-TESTS macros [CKR] +;;; 01/29/04 fixed ASSERT-EXPANDS quote bug [CKR] +;;; 01/28/04 major changes from BUG-FINDER to be more like JUnit [CKR] + + +#| +How to use +---------- + +1. Read the documentation in lisp-unit.html. + +2. Make a file of DEFINE-TEST's. See exercise-tests.lisp for many +examples. If you want, start your test file with (REMOVE-TESTS) to +clear any previously defined tests. + +2. Load this file. + +2. (use-package :lisp-unit) + +3. Load your code file and your file of tests. + +4. Test your code with (RUN-TESTS test-name1 test-name2 ...) -- no quotes! -- +or simply (RUN-TESTS) to run all defined tests. + +A summary of how many tests passed and failed will be printed, +with details on the failures. + +Note: Nothing is compiled until RUN-TESTS is expanded. Redefining +functions or even macros does not require reloading any tests. + +For more information, see lisp-unit.html. + +|# + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; Packages +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(cl:defpackage #:lisp-unit + (:use #:common-lisp) + (:export #:define-test #:run-all-tests #:run-tests + #:assert-eq #:assert-eql #:assert-equal #:assert-equalp + #:assert-error #:assert-expands #:assert-false + #:assert-equality #:assert-prints #:assert-true + #:get-test-code #:get-tests + #:remove-all-tests #:remove-tests + #:logically-equal #:set-equal + #:use-debugger + #:with-test-listener) + ) + +(in-package #:lisp-unit) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; Globals +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defparameter *test-listener* nil) + +(defparameter *tests* (make-hash-table)) + +;;; Used by RUN-TESTS to collect summary statistics +(defvar *test-count* 0) +(defvar *pass-count* 0) + +;;; Set by RUN-TESTS for use by SHOW-FAILURE +(defvar *test-name* nil) + +;;; If nil, errors in tests are caught and counted. +;;; If :ask, user is given option of entering debugger or not. +;;; If true and not :ask, debugger is entered. +(defparameter *use-debugger* nil) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; Macros +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;;; DEFINE-TEST + +(defmacro define-test (name &body body) + `(progn + (store-test-code ',name ',body) + ',name)) + +;;; ASSERT macros + +(defmacro assert-eq (expected form &rest extras) + (expand-assert :equal form form expected extras :test #'eq)) + +(defmacro assert-eql (expected form &rest extras) + (expand-assert :equal form form expected extras :test #'eql)) + +(defmacro assert-equal (expected form &rest extras) + (expand-assert :equal form form expected extras :test #'equal)) + +(defmacro assert-equalp (expected form &rest extras) + (expand-assert :equal form form expected extras :test #'equalp)) + +(defmacro assert-error (condition form &rest extras) + (expand-assert :error form (expand-error-form form) + condition extras)) + +(defmacro assert-expands (&environment env expansion form &rest extras) + (expand-assert :macro form + (expand-macro-form form #+lispworks nil #-lispworks env) + expansion extras)) + +(defmacro assert-false (form &rest extras) + (expand-assert :result form form nil extras)) + +(defmacro assert-equality (test expected form &rest extras) + (expand-assert :equal form form expected extras :test test)) + +(defmacro assert-prints (output form &rest extras) + (expand-assert :output form (expand-output-form form) + output extras)) + +(defmacro assert-true (form &rest extras) + (expand-assert :result form form t extras)) + + +(defun expand-assert (type form body expected extras &key (test #'eql)) + `(internal-assert + ,type ',form #'(lambda () ,body) #'(lambda () ,expected) ,(expand-extras extras), test)) + +(defun expand-error-form (form) + `(handler-case ,form + (condition (error) error))) + +(defun expand-output-form (form) + (let ((out (gensym))) + `(let* ((,out (make-string-output-stream)) + (*standard-output* (make-broadcast-stream *standard-output* ,out))) + ,form + (get-output-stream-string ,out)))) + +(defun expand-macro-form (form env) + `(macroexpand-1 ',form ,env)) + +(defun expand-extras (extras) + `#'(lambda () + (list ,@(mapcan #'(lambda (form) (list `',form form)) extras)))) + + +;;; RUN-TESTS + +(defmacro run-all-tests (package &rest tests) + `(let ((*package* (find-package ',package))) + (run-tests + ,@(mapcar #'(lambda (test) (find-symbol (symbol-name test) package)) + tests)))) + +(defmacro run-tests (&rest names) + `(run-test-thunks (get-test-thunks ,(if (null names) '(get-tests *package*) `',names)))) + +(defun get-test-thunks (names &optional (package *package*)) + (mapcar #'(lambda (name) (get-test-thunk name package)) + names)) + +(defun get-test-thunk (name package) + (assert (get-test-code name package) (name package) + "No test defined for ~S in package ~S" name package) + (list name (coerce `(lambda () ,@(get-test-code name)) 'function))) + +(defun use-debugger (&optional (flag t)) + (setq *use-debugger* flag)) + +;;; WITH-TEST-LISTENER +(defmacro with-test-listener (listener &body body) + `(let ((*test-listener* #',listener)) ,@body)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; Public functions +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defun get-test-code (name &optional (package *package*)) + (let ((table (get-package-table package))) + (unless (null table) + (gethash name table)))) + +(defun get-tests (&optional (package *package*)) + (let ((l nil) + (table (get-package-table package))) + (cond ((null table) nil) + (t + (maphash #'(lambda (key val) + (declare (ignore val)) + (push key l)) + table) + (sort l #'string< :key #'string))))) + + +(defun remove-tests (names &optional (package *package*)) + (let ((table (get-package-table package))) + (unless (null table) + (if (null names) + (clrhash table) + (dolist (name names) + (remhash name table)))))) + +(defun remove-all-tests (&optional (package *package*)) + (if (null package) + (clrhash *tests*) + (remhash (find-package package) *tests*))) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; Private functions +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + + +;;; DEFINE-TEST support + +(defun get-package-table (package &key create) + (let ((table (gethash (find-package package) *tests*))) + (or table + (and create + (setf (gethash package *tests*) + (make-hash-table)))))) + +(defun get-test-name (form) + (if (atom form) form (cadr form))) + +(defun store-test-code (name code &optional (package *package*)) + (setf (gethash name + (get-package-table package :create t)) + code)) + + +;;; ASSERTION support + +(defun internal-assert (type form code-thunk expected-thunk extras test) + (let* ((expected (multiple-value-list (funcall expected-thunk))) + (actual (multiple-value-list (funcall code-thunk))) + (passed (test-passed-p type expected actual test))) + + (incf *test-count*) + (when passed + (incf *pass-count*)) + + (record-result passed type form expected actual extras) + + passed)) + +(defun record-result (passed type form expected actual extras) + (funcall (or *test-listener* 'default-listener) + passed type *test-name* form expected actual + (and extras (funcall extras)) + *test-count* *pass-count*)) + +(defun default-listener + (passed type name form expected actual extras test-count pass-count) + (declare (ignore test-count pass-count)) + (unless passed + (show-failure type (get-failure-message type) + name form expected actual extras))) + +(defun test-passed-p (type expected actual test) + (ecase type + (:error + (or (eql (car actual) (car expected)) + (typep (car actual) (car expected)))) + (:equal + (and (<= (length expected) (length actual)) + (every test expected actual))) + (:macro + (equal (car actual) (car expected))) + (:output + (string= (string-trim '(#\newline #\return #\space) + (car actual)) + (car expected))) + (:result + (logically-equal (car actual) (car expected))) + )) + + +;;; RUN-TESTS support + +(defun run-test-thunks (test-thunks) + (unless (null test-thunks) + (let ((total-test-count 0) + (total-pass-count 0) + (total-error-count 0)) + (dolist (test-thunk test-thunks) + (multiple-value-bind (test-count pass-count error-count) + (run-test-thunk (car test-thunk) (cadr test-thunk)) + (incf total-test-count test-count) + (incf total-pass-count pass-count) + (incf total-error-count error-count))) + (unless (null (cdr test-thunks)) + (show-summary 'total total-test-count total-pass-count total-error-count)) + (values)))) + +(defun run-test-thunk (*test-name* thunk) + (if (null thunk) + (format t "~& Test ~S not found" *test-name*) + (prog ((*test-count* 0) + (*pass-count* 0) + (error-count 0)) + (handler-bind + ((error #'(lambda (e) + (let ((*print-escape* nil)) + (setq error-count 1) + (format t "~& ~S: ~W" *test-name* e)) + (if (use-debugger-p e) e (go exit))))) + (funcall thunk) + (show-summary *test-name* *test-count* *pass-count*)) + exit + (return (values *test-count* *pass-count* error-count))))) + +(defun use-debugger-p (e) + (and *use-debugger* + (or (not (eql *use-debugger* :ask)) + (y-or-n-p "~A -- debug?" e)))) + +;;; OUTPUT support + +(defun get-failure-message (type) + (case type + (:error "~&~@[Should have signalled ~{~S~^; ~} but saw~] ~{~S~^; ~}") + (:macro "~&Should have expanded to ~{~S~^; ~} ~<~%~:;but saw ~{~S~^; ~}~>") + (:output "~&Should have printed ~{~S~^; ~} ~<~%~:;but saw ~{~S~^; ~}~>") + (t "~&Expected ~{~S~^; ~} ~<~%~:;but saw ~{~S~^; ~}~>") + )) + +(defun show-failure (type msg name form expected actual extras) + (format t "~&~@[~S: ~]~S failed: " name form) + (format t msg expected actual) + (format t "~{~& ~S => ~S~}~%" extras) + type) + +(defun show-summary (name test-count pass-count &optional error-count) + (format t "~&~A: ~S assertions passed, ~S failed~@[, ~S execution errors~]." + name pass-count (- test-count pass-count) error-count)) + +(defun collect-form-values (form values) + (mapcan #'(lambda (form-arg value) + (if (constantp form-arg) + nil + (list form-arg value))) + (cdr form) + values)) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; Useful equality predicates for tests +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;;; (LOGICALLY-EQUAL x y) => true or false +;;; Return true if x and y both false or both true + +(defun logically-equal (x y) + (eql (not x) (not y))) + +;;; (SET-EQUAL l1 l2 :test) => true or false +;;; Return true if every element of l1 is an element of l2 +;;; and vice versa. + +(defun set-equal (l1 l2 &key (test #'equal)) + (and (listp l1) + (listp l2) + (subsetp l1 l2 :test test) + (subsetp l2 l1 :test test))) + + +(provide "lisp-unit") Added: trunk/src/external-libraries/lisp-unit/readme.txt ============================================================================== --- (empty file) +++ trunk/src/external-libraries/lisp-unit/readme.txt Sun Aug 13 01:52:01 2006 @@ -0,0 +1,7 @@ + +This directory contains the source file implementing the lisp-unit +unit-test library. Copyright (c) 2004-2005 Christopher K. Riesbeck + +The website for this library is: + + http://www.cs.northwestern.edu/academics/courses/325/readings/lisp-unit.html Modified: trunk/src/tests/uitoolkit/icon-bundle-unit-tests.lisp ============================================================================== --- trunk/src/tests/uitoolkit/icon-bundle-unit-tests.lisp (original) +++ trunk/src/tests/uitoolkit/icon-bundle-unit-tests.lisp Sun Aug 13 01:52:01 2006 @@ -32,7 +32,3 @@ ;;;; (in-package :graphic-forms.uitoolkit.tests) - - - - Modified: trunk/src/tests/uitoolkit/test-utils.lisp ============================================================================== --- trunk/src/tests/uitoolkit/test-utils.lisp (original) +++ trunk/src/tests/uitoolkit/test-utils.lisp Sun Aug 13 01:52:01 2006 @@ -33,8 +33,6 @@ (in-package :graphic-forms.uitoolkit.tests) -#| (defun validate-image (image expected-size expected-depth) (assert-equality #'gfs:equal-size-p expected-size (gfg:size image)) (assert-equal expected-depth (gfg:depth image))) -|# Modified: trunk/tests.lisp ============================================================================== --- trunk/tests.lisp (original) +++ trunk/tests.lisp Sun Aug 13 01:52:01 2006 @@ -33,9 +33,16 @@ (in-package #:graphic-forms-system) -(load (compile-file *lisp-unit-file*)) - (defun load-tests () #+lispworks (hcl:change-directory *gf-dir*) - (asdf:operate 'asdf:load-op :graphic-forms-tests)) + (asdf:operate 'asdf:load-op :graphic-forms-tests) + (load (concatenate 'string *gf-tests-dir* "test-utils")) + (load (concatenate 'string *gf-tests-dir* "mock-objects")) + (load (concatenate 'string *gf-tests-dir* "color-unit-tests")) + (load (concatenate 'string *gf-tests-dir* "graphics-context-unit-tests")) + (load (concatenate 'string *gf-tests-dir* "image-unit-tests")) + (load (concatenate 'string *gf-tests-dir* "icon-bundle-unit-tests")) + (load (concatenate 'string *gf-tests-dir* "layout-unit-tests")) + (load (concatenate 'string *gf-tests-dir* "widget-unit-tests")) + (load (concatenate 'string *gf-tests-dir* "misc-unit-tests")))