lispdoc: implemented the whole URI syntax; updated URIs in all docstrings to be writt...
[com-informatimago:com-informatimago.git] / objcl / simple-test.lisp
1 ;;;; -*- mode:lisp;coding:utf-8 -*-
2 ;;;;**************************************************************************
3 ;;;;FILE:               simple-test.lisp
4 ;;;;LANGUAGE:           Common-Lisp
5 ;;;;SYSTEM:             Common-Lisp
6 ;;;;USER-INTERFACE:     NONE
7 ;;;;DESCRIPTION
8 ;;;;    
9 ;;;;    Defines a simple test tool.
10 ;;;;    
11 ;;;;AUTHORS
12 ;;;;    <PJB> Pascal J. Bourguignon <pjb@informatimago.com>
13 ;;;;MODIFICATIONS
14 ;;;;    2010-12-14 <PJB> Created.
15 ;;;;BUGS
16 ;;;;LEGAL
17 ;;;;    AGPL3
18 ;;;;    
19 ;;;;    Copyright Pascal J. Bourguignon 2010 - 2012
20 ;;;;    
21 ;;;;    This program is free software: you can redistribute it and/or modify
22 ;;;;    it under the terms of the GNU Affero General Public License as published by
23 ;;;;    the Free Software Foundation, either version 3 of the License, or
24 ;;;;    (at your option) any later version.
25 ;;;;    
26 ;;;;    This program is distributed in the hope that it will be useful,
27 ;;;;    but WITHOUT ANY WARRANTY; without even the implied warranty of
28 ;;;;    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
29 ;;;;    GNU Affero General Public License for more details.
30 ;;;;    
31 ;;;;    You should have received a copy of the GNU Affero General Public License
32 ;;;;    along with this program.  If not, see <http://www.gnu.org/licenses/>
33 ;;;;**************************************************************************
34
35 (in-package "COM.INFORMATIMAGO.SIMPLE-TEST")
36
37
38 (defvar *debug-on-error*          nil
39   "Whether an error in a test should go to the debugger.")
40 (defvar *success-count*           0
41   "The total number of successful tests.")
42 (defvar *failure-count*           0
43   "The total number of failed tests.")
44
45
46 ;; Private:
47 (defvar *last-success-p*          nil)
48 (defvar *current-test*            nil)
49 (defvar *current-test-printed-p*  nil)
50 (defvar *report-string*           "")
51 (defparameter *cr*                #\return)
52
53
54 (defun progress-start (test-name)
55   (setf *success-count*  0
56         *failure-count*  0
57         *last-success-p* nil
58         *report-string*  (make-array 8
59                                      :element-type 'character
60                                      :adjustable t
61                                      :fill-pointer 0)
62         *current-test*   test-name
63         *current-test-printed-p* nil)
64   (values))
65
66
67 (defun progress-report (new-last-succcess-p)
68   (if (setf *last-success-p* new-last-succcess-p)
69       (format t "~A" (aref *report-string* (1- (length *report-string*))))
70       (format t "~&~A" *report-string*))
71   (finish-output)
72   (values))
73
74
75 (defun progress-success (compare expression result)
76   (declare (ignorable compare expression result))
77   (incf *success-count*)
78   (vector-push-extend #\. *report-string*)
79   (progress-report t))
80
81
82 (defun progress-failure (compare expression expected-result result)
83   (incf *failure-count*)
84   (vector-push-extend #\! *report-string*)
85   (unless *current-test-printed-p*
86     (setf  *current-test-printed-p* t)
87     (format t "~&~A" *current-test*))
88   (format t "~&Failure:     expression: ~S~@
89              ~&           evaluates to: ~S~@
90              ~&           which is not  ~A~@
91              ~& to the expected result: ~S~%"
92           expression result compare expected-result)
93   (progress-report nil))
94
95
96 (defun progress-tally (test-name success-count failure-count)
97   (flet ((genline (name)
98            (format nil "~44A ~4D ~4A ~4D ~4A ~5D ~A"
99                    name
100                    success-count "succ" ; (format nil "success~[es~;~:;es~]," success-count)
101                    failure-count "fail" ; (format nil "failure~P," failure-count)
102                    (+ success-count failure-count)
103                    "test"; (format nil "test~P." (+ success-count failure-count))
104                    )))
105     (let* ((test-name (string test-name))
106            (data (genline ""))
107            (nlen (length test-name)))
108       
109       (format t "~&~A~%" 
110               (if (and (< nlen (+ 44 4)) (char= #\space (aref data nlen)))
111                   (progn
112                     (replace data test-name)
113                     data)
114                   (genline test-name)))))
115   (finish-output)
116   (values))
117
118
119 (defmacro test (compare expression expected)
120   "Evaluates a test EXPRESSION and compare the result with EXPECTED (evaluated) using the COMPARE operator.
121 EXAMPLE:  (test equal (list 1 2 3) '(1 2 3))
122 "
123   (let ((vresult   (gensym "RESULT-"))
124         (vexpected (gensym "EXPECTED-")))
125     `(let ((,vresult   (if *debug-on-error*
126                            (handler-bind
127                                ((error (function invoke-debugger)))
128                              ,expression)
129                            (handler-case
130                                ,expression
131                              (error (err) (list 'error (princ-to-string err))))))
132            (,vexpected ,expected))
133        (if (,compare ,vresult ,vexpected)
134            (progress-success ',compare ',expression ,vexpected)
135            (progress-failure ',compare ',expression ,vexpected ,vresult)))))
136
137
138 (defmacro define-test (name parameters &body body)
139   "Like DEFUN, but wraps the body in test reporting boilerplate."
140   `(defun ,name ,parameters
141      (multiple-value-bind (successes failures)
142          (let ((*success-count* 0)
143                (*failure-count* 0))
144            (progress-start ',name)
145            (locally ,@body)
146            (progress-tally ',name *success-count* *failure-count*)
147            (values *success-count* *failure-count*))
148        (incf *success-count* successes)
149        (incf *failure-count* failures)
150        (if (zerop *failure-count*)
151            :success
152            :failure))))
153
154 (defmacro with-debugger-on-error (&body body)
155   `(let ((*debug-on-error* t))
156      ,@body))
157
158 ;;;; THE END ;;;;