src.lisp

   1 ;; ptester.lisp
   2 ;; A test harness based on Franz's tester module
   3 ;;
   4 ;; copyright (c) 1985-1986 Franz Inc, Alameda, CA
   5 ;; copyright (c) 1986-2002 Franz Inc, Berkeley, CA - All rights reserved.
   6 ;; copyright (c) 2001-2003 Kevin Rosenberg (portability changes)
   7 ;;
   8 ;; This code is free software; you can redistribute it and/or
   9 ;; modify it under the terms of the version 2.1 of
  10 ;; the GNU Lesser General Public License as published by
  11 ;; the Free Software Foundation, as clarified by the Franz
  12 ;; preamble to the LGPL found in
  13 ;; http://opensource.franz.com/preamble.html.
  14 ;;
  15 ;; This code is distributed in the hope that it will be useful,
  16 ;; but without any warranty; without even the implied warranty of
  17 ;; merchantability or fitness for a particular purpose.  See the GNU
  18 ;; Lesser General Public License for more details.
  19 ;;
  20 ;; Version 2.1 of the GNU Lesser General Public License can be
  21 ;; found at http://opensource.franz.com/license.html.
  22 ;; If it is not present, you can access it from
  23 ;; http://www.gnu.org/copyleft/lesser.txt (until superseded by a newer
  24 ;; version) or write to the Free Software Foundation, Inc., 59 Temple
  25 ;; Place, Suite 330, Boston, MA  02111-1307  USA
  26 ;;
  27 ;;;; from the original ACL 6.1 sources:
  28 ;; Id: tester.cl,v 2.2.12.1 2001/06/05 18:45:10 layer Exp
  29
  30 ;; $Id: src.lisp,v 1.1 2003/07/20 18:10:22 kevin Exp $
  31
  32 (defpackage #:ptester
  33   (:use #:cl)
  34   (:shadow #:test)
  35   (:export
  36 ;;;; Control variables:
  37    #:*break-on-test-failures*
  38    #:*error-protect-tests*
  39    #:*test-errors*
  40    #:*test-successes*
  41    #:*test-unexpected-failures*
  42
  43 ;;;; The test macros:
  44    #:test
  45    #:test-error
  46    #:test-no-error
  47    #:test-warning
  48    #:test-no-warning
  49
  50    #:with-tests
  51    ))
  52
  53 (in-package #:ptester)
  54
  55 ;; Added by Kevin Rosenberg
  56
  57 (define-condition simple-break (error simple-condition) ())
  58
  59 #+cmu
  60 (unless (find-class 'break nil)
  61   (define-condition break (simple-condition) ()))
  62
  63 ;; the if* macro used in Allegro:
  64 ;;
  65 ;; This is in the public domain... please feel free to put this definition
  66 ;; in your code or distribute it with your version of lisp.
  67
  68 (eval-when (:compile-toplevel :load-toplevel :execute)
  69   (defvar if*-keyword-list '("then" "thenret" "else" "elseif")))
  70
  71 (defmacro if* (&rest args)
  72    (do ((xx (reverse args) (cdr xx))
  73         (state :init)
  74         (elseseen nil)
  75         (totalcol nil)
  76         (lookat nil nil)
  77         (col nil))
  78        ((null xx)
  79         (cond ((eq state :compl)
  80                `(cond ,@totalcol))
  81               (t (error "if*: illegal form ~s" args))))
  82        (cond ((and (symbolp (car xx))
  83                    (member (symbol-name (car xx))
  84                            if*-keyword-list
  85                            :test #'string-equal))
  86               (setq lookat (symbol-name (car xx)))))
  87
  88        (cond ((eq state :init)
  89               (cond (lookat (cond ((string-equal lookat "thenret")
  90                                    (setq col nil
  91                                          state :then))
  92                                   (t (error
  93                                       "if*: bad keyword ~a" lookat))))
  94                     (t (setq state :col
  95                              col nil)
  96                        (push (car xx) col))))
  97              ((eq state :col)
  98               (cond (lookat
  99                      (cond ((string-equal lookat "else")
 100                             (cond (elseseen
 101                                    (error
 102                                     "if*: multiples elses")))
 103                             (setq elseseen t)
 104                             (setq state :init)
 105                             (push `(t ,@col) totalcol))
 106                            ((string-equal lookat "then")
 107                             (setq state :then))
 108                            (t (error "if*: bad keyword ~s"
 109                                               lookat))))
 110                     (t (push (car xx) col))))
 111              ((eq state :then)
 112               (cond (lookat
 113                      (error
 114                       "if*: keyword ~s at the wrong place " (car xx)))
 115                     (t (setq state :compl)
 116                        (push `(,(car xx) ,@col) totalcol))))
 117              ((eq state :compl)
 118               (cond ((not (string-equal lookat "elseif"))
 119                      (error "if*: missing elseif clause ")))
 120               (setq state :init)))))
 121
 122
 123 (defvar *break-on-test-failures* nil
 124   "When a test failure occurs, common-lisp:break is called, allowing
 125 interactive debugging of the failure.")
 126
 127 (defvar *test-errors* 0
 128   "The value is the number of test errors which have occurred.")
 129 (defvar *test-successes* 0
 130   "The value is the number of test successes which have occurred.")
 131 (defvar *test-unexpected-failures* 0
 132   "The value is the number of unexpected test failures which have occurred.")
 133
 134 (defvar *error-protect-tests* nil
 135   "Protect each test from errors.  If an error occurs, then that will be
 136 taken as a test failure unless test-error is being used.")
 137
 138 (defmacro test-values-errorset (form &optional announce catch-breaks)
 139   ;; internal macro
 140   (let ((g-announce (gensym))
 141         (g-catch-breaks (gensym)))
 142     `(let* ((,g-announce ,announce)
 143             (,g-catch-breaks ,catch-breaks))
 144        (handler-case (cons t (multiple-value-list ,form))
 145          (condition (condition)
 146            (if* (and (null ,g-catch-breaks)
 147                      (typep condition 'simple-break))
 148               then (break condition)
 149             elseif ,g-announce
 150               then (format *error-output* "~&Condition type: ~a~%"
 151                            (class-of condition))
 152                    (format *error-output* "~&Message: ~a~%" condition))
 153            condition)))))
 154
 155 (defmacro test-values (form &optional announce catch-breaks)
 156   ;; internal macro
 157   (if* *error-protect-tests*
 158      then `(test-values-errorset ,form ,announce ,catch-breaks)
 159      else `(cons t (multiple-value-list ,form))))
 160
 161 (defmacro test (expected-value test-form
 162                 &key (test #'eql test-given)
 163                      (multiple-values nil multiple-values-given)
 164                      (fail-info nil fail-info-given)
 165                      (known-failure nil known-failure-given)
 166
 167 ;;;;;;;;;; internal, undocumented keywords:
 168 ;;;; Note about these keywords: if they were documented, we'd have a
 169 ;;;; problem, since they break the left-to-right order of evaluation.
 170 ;;;; Specifically, errorset breaks it, and I don't see any way around
 171 ;;;; that.  `errorset' is used by the old test.cl module (eg,
 172 ;;;; test-equal-errorset).
 173                      errorset
 174                      reported-form
 175                      (wanted-message nil wanted-message-given)
 176                      (got-message nil got-message-given))
 177   "Perform a single test.  `expected-value' is the reference value for the
 178 test.  `test-form' is a form that will produce the value to be compared to
 179 the expected-value.  If the values are not the same, then an error is
 180 logged, otherwise a success is logged.
 181
 182 Normally the comparison of values is done with `eql'.  The `test' keyword
 183 argument can be used to specify other comparison functions, such as eq,
 184 equal,equalp, string=, string-equal, etc.
 185
 186 Normally, only the first return value from the test-form is considered,
 187 however if `multiple-values' is t, then all values returned from test-form
 188 are considered.
 189
 190 `fail-info' allows more information to be printed with a test failure.
 191
 192 `known-failure' marks the test as a known failure.  This allows for
 193 programs that do regression analysis on the output from a test run to
 194 discriminate on new versus known failures."
 195   `(test-check
 196     :expected-result ,expected-value
 197     :test-results
 198     (,(if errorset 'test-values-errorset 'test-values) ,test-form t)
 199     ,@(when test-given `(:predicate ,test))
 200     ,@(when multiple-values-given `(:multiple-values ,multiple-values))
 201     ,@(when fail-info-given `(:fail-info ,fail-info))
 202     ,@(when known-failure-given `(:known-failure ,known-failure))
 203     :test-form ',(if reported-form reported-form test-form)
 204     ,@(when wanted-message-given `(:wanted-message ,wanted-message))
 205     ,@(when got-message-given `(:got-message ,got-message))))
 206
 207 (defmethod conditionp ((thing condition)) t)
 208 (defmethod conditionp ((thing t)) nil)
 209
 210 (defmacro test-error (form &key announce
 211                                 catch-breaks
 212                                 (fail-info nil fail-info-given)
 213                                 (known-failure nil known-failure-given)
 214                                 (condition-type ''simple-error)
 215                                 (include-subtypes nil include-subtypes-given)
 216                                 (format-control nil format-control-given)
 217                                 (format-arguments nil format-arguments-given))
 218   "Test that `form' signals an error. The order of evaluation of the
 219 arguments is keywords first, then test form.
 220
 221 If `announce' is non-nil, then cause the error message to be printed.
 222
 223 The `catch-breaks' is non-nil then consider a call to common-lisp:break an
 224 `error'.
 225
 226 `fail-info' allows more information to be printed with a test failure.
 227
 228 `known-failure' marks the test as a known failure.  This allows for
 229 programs that do regression analysis on the output from a test run to
 230 discriminate on new versus known failures.
 231
 232 If `condition-type' is non-nil, it should be a symbol naming a condition
 233 type, which is used to check against the signalled condition type.  The
 234 test will fail if they do not match.
 235
 236 `include-subtypes', used with `condition-type', can be used to match a
 237 condition to an entire subclass of the condition type hierarchy.
 238
 239 `format-control' and `format-arguments' can be used to check the error
 240 message itself."
 241   (let ((g-announce (gensym))
 242         (g-catch-breaks (gensym))
 243         (g-fail-info (gensym))
 244         (g-known-failure (gensym))
 245         (g-condition-type (gensym))
 246         (g-include-subtypes (gensym))
 247         (g-format-control (gensym))
 248         (g-format-arguments (gensym))
 249         (g-c (gensym)))
 250     `(let* ((,g-announce ,announce)
 251             (,g-catch-breaks ,catch-breaks)
 252             ,@(when fail-info-given `((,g-fail-info ,fail-info)))
 253             ,@(when known-failure-given `((,g-known-failure ,known-failure)))
 254             (,g-condition-type ,condition-type)
 255             ,@(when include-subtypes-given
 256                 `((,g-include-subtypes ,include-subtypes)))
 257             ,@(when format-control-given
 258                 `((,g-format-control ,format-control)))
 259             ,@(when format-arguments-given
 260                 `((,g-format-arguments ,format-arguments)))
 261             (,g-c (test-values-errorset ,form ,g-announce ,g-catch-breaks)))
 262        (test-check
 263         :predicate #'eq
 264         :expected-result t
 265         :test-results
 266         (test-values (and (conditionp ,g-c)
 267                           ,@(if* include-subtypes-given
 268                                then `((if* ,g-include-subtypes
 269                                          then (typep ,g-c ,g-condition-type)
 270                                          else (eq (class-of ,g-c)
 271                                                   (find-class
 272                                                    ,g-condition-type))))
 273                                else `((eq (class-of ,g-c)
 274                                           (find-class ,g-condition-type))))
 275                           ,@(when format-control-given
 276                               `((or
 277                                  (null ,g-format-control)
 278                                  (string=
 279                                   (concatenate 'simple-string
 280                                     "~1@<" ,g-format-control "~:@>")
 281                                   (simple-condition-format-control ,g-c)))))
 282                           ,@(when format-arguments-given
 283                               `((or
 284                                  (null ,g-format-arguments)
 285                                  (equal
 286                                   ,g-format-arguments
 287                                   (simple-condition-format-arguments ,g-c))))))
 288                      t)
 289         :test-form ',form
 290         ,@(when fail-info-given `(:fail-info ,g-fail-info))
 291         ,@(when known-failure-given `(:known-failure ,g-known-failure))
 292         :condition-type ,g-condition-type
 293         :condition ,g-c
 294         ,@(when include-subtypes-given
 295             `(:include-subtypes ,g-include-subtypes))
 296         ,@(when format-control-given
 297             `(:format-control ,g-format-control))
 298         ,@(when format-arguments-given
 299             `(:format-arguments ,g-format-arguments))))))
 300
 301 (defmacro test-no-error (form &key announce
 302                                    catch-breaks
 303                                    (fail-info nil fail-info-given)
 304                                    (known-failure nil known-failure-given))
 305   "Test that `form' does not signal an error.  The order of evaluation of
 306 the arguments is keywords first, then test form.
 307
 308 If `announce' is non-nil, then cause the error message to be printed.
 309
 310 The `catch-breaks' is non-nil then consider a call to common-lisp:break an
 311 `error'.
 312
 313 `fail-info' allows more information to be printed with a test failure.
 314
 315 `known-failure' marks the test as a known failure.  This allows for
 316 programs that do regression analysis on the output from a test run to
 317 discriminate on new versus known failures."
 318   (let ((g-announce (gensym))
 319         (g-catch-breaks (gensym))
 320         (g-fail-info (gensym))
 321         (g-known-failure (gensym))
 322         (g-c (gensym)))
 323     `(let* ((,g-announce ,announce)
 324             (,g-catch-breaks ,catch-breaks)
 325             ,@(when fail-info-given `((,g-fail-info ,fail-info)))
 326             ,@(when known-failure-given `((,g-known-failure ,known-failure)))
 327             (,g-c (test-values-errorset ,form ,g-announce ,g-catch-breaks)))
 328        (test-check
 329         :predicate #'eq
 330         :expected-result t
 331         :test-results (test-values (not (conditionp ,g-c)))
 332         :test-form ',form
 333         :condition ,g-c
 334         ,@(when fail-info-given `(:fail-info ,g-fail-info))
 335         ,@(when known-failure-given `(:known-failure ,g-known-failure))))))
 336
 337 (defvar *warn-cookie* (cons nil nil))
 338
 339 (defmacro test-warning (form &key fail-info known-failure)
 340   "Test that `form' signals a warning.  The order of evaluation of
 341 the arguments is keywords first, then test form.
 342
 343 `fail-info' allows more information to be printed with a test failure.
 344
 345 `known-failure' marks the test as a known failure.  This allows for
 346 programs that do regression analysis on the output from a test run to
 347 discriminate on new versus known failures."
 348   (let ((g-fail-info (gensym))
 349         (g-known-failure (gensym))
 350         (g-value (gensym)))
 351     `(let* ((,g-fail-info ,fail-info)
 352             (,g-known-failure ,known-failure)
 353             (,g-value (test-values-errorset ,form nil t)))
 354        (test
 355         *warn-cookie*
 356         (if* (or (typep ,g-value 'simple-warning) (typep ,g-value 'warning))
 357            then *warn-cookie*
 358            else ;; test produced no warning
 359                 nil)
 360         :test #'eq
 361         :reported-form ,form ;; quoted by test macro
 362         :wanted-message "a warning"
 363         :got-message "no warning"
 364         :fail-info ,g-fail-info
 365         :known-failure ,g-known-failure))))
 366
 367 (defmacro test-no-warning (form &key fail-info known-failure)
 368   "Test that `form' does not signal a warning.  The order of evaluation of
 369 the arguments is keywords first, then test form.
 370
 371 `fail-info' allows more information to be printed with a test failure.
 372
 373 `known-failure' marks the test as a known failure.  This allows for
 374 programs that do regression analysis on the output from a test run to
 375 discriminate on new versus known failures."
 376   (let ((g-fail-info (gensym))
 377         (g-known-failure (gensym))
 378         (g-value (gensym)))
 379     `(let* ((,g-fail-info ,fail-info)
 380             (,g-known-failure ,known-failure)
 381             (,g-value (test-values-errorset ,form nil t)))
 382        (test
 383         *warn-cookie*
 384         (if* (or (typep ,g-value 'simple-warning) (typep ,g-value 'warning))
 385            then nil ;; test produced warning
 386            else *warn-cookie*)
 387         :test #'eq
 388         :reported-form ',form
 389         :wanted-message "no warning"
 390         :got-message "a warning"
 391         :fail-info ,g-fail-info
 392         :known-failure ,g-known-failure))))
 393
 394 (defvar *announce-test* nil) ;; if true announce each test that was done
 395
 396 (defmacro errorset (form) ;subset of test-values-errorset
 397   `(handler-case
 398     (values-list (cons t (multiple-value-list ,form)))
 399     (error (cond)
 400      (format *error-output* "~&An error occurred: ~a~%" cond)
 401      nil)))
 402
 403
 404 (defun test-check (&key (predicate #'eql)
 405                         expected-result test-results test-form
 406                         multiple-values fail-info known-failure
 407                         wanted-message got-message condition-type condition
 408                         include-subtypes format-control format-arguments
 409                    &aux fail predicate-failed got wanted)
 410   ;; for debugging large/complex test sets:
 411   (when *announce-test*
 412     (format t "Just did test ~s~%" test-form)
 413     (force-output))
 414
 415   ;; this is an internal function
 416   (flet ((check (expected-result result)
 417            (let* ((results
 418                    (multiple-value-list
 419                     (errorset (funcall predicate expected-result result))))
 420                   (failed (null (car results))))
 421              (if failed
 422                  (progn
 423                    (setq predicate-failed t)
 424                    nil)
 425                  (cadr results)))))
 426     (when (conditionp test-results)
 427       (setq condition test-results)
 428       (setq test-results nil))
 429     (when (null (car test-results))
 430       (setq fail t))
 431     (if* (and (not fail) (not multiple-values))
 432        then ;; should be a single result
 433             ;; expected-result is the single result wanted
 434             (when (not (and (cdr test-results)
 435                             (check expected-result (cadr test-results))))
 436               (setq fail t))
 437             (when (and (not fail) (cddr test-results))
 438               (setq fail 'single-got-multiple))
 439        else ;; multiple results wanted
 440             ;; expected-result is a list of results, each of which
 441             ;; should be checked against the corresponding test-results
 442             ;; using the predicate
 443             (do ((got (cdr test-results) (cdr got))
 444                  (want expected-result (cdr want)))
 445                 ((or (null got) (null want))
 446                  (when (not (and (null want) (null got)))
 447                    (setq fail t)))
 448               (when (not (check (car got) (car want)))
 449                 (return (setq fail t)))))
 450     (if* fail
 451        then (when (not known-failure)
 452               (format *error-output*
 453                       "~& * * * UNEXPECTED TEST FAILURE * * *~%")
 454               (incf *test-unexpected-failures*))
 455             (format *error-output* "~&Test failed: ~@[known failure: ~*~]~s~%"
 456                     known-failure test-form)
 457             (if* (eq 'single-got-multiple fail)
 458                then (format
 459                      *error-output*
 460                      "~
 461 Reason: additional value were returned from test form.~%")
 462              elseif predicate-failed
 463                then (format *error-output* "Reason: predicate error.~%")
 464              elseif (null (car test-results))
 465                then (format *error-output* "~
 466 Reason: an error~@[ (of type `~s')~] was detected.~%"
 467                             (when condition (class-of condition)))
 468              elseif condition
 469                then (if* (not (conditionp condition))
 470                        then (format *error-output* "~
 471 Reason: expected but did not detect an error of type `~s'.~%"
 472                                     condition-type)
 473                      elseif (null condition-type)
 474                        then (format *error-output* "~
 475 Reason: detected an unexpected error of type `~s':
 476         ~a.~%"
 477                                     (class-of condition)
 478                                     condition)
 479                      elseif (not (if* include-subtypes
 480                                     then (typep condition condition-type)
 481                                     else (eq (class-of condition)
 482                                              (find-class condition-type))))
 483                        then (format *error-output* "~
 484 Reason: detected an incorrect condition type.~%")
 485                             (format *error-output*
 486                                     "  wanted: ~s~%" condition-type)
 487                             (format *error-output*
 488                                     "     got: ~s~%" (class-of condition))
 489                      elseif (and format-control
 490                                  (not (string=
 491                                        (setq got
 492                                          (concatenate 'simple-string
 493                                            "~1@<" format-control "~:@>"))
 494                                        (setq wanted
 495                                          (simple-condition-format-control
 496                                           condition)))))
 497                        then ;; format control doesn't match
 498                             (format *error-output* "~
 499 Reason: the format-control was incorrect.~%")
 500                             (format *error-output* "  wanted: ~s~%" wanted)
 501                             (format *error-output* "     got: ~s~%" got)
 502                      elseif (and format-arguments
 503                                  (not (equal
 504                                        (setq got format-arguments)
 505                                        (setq wanted
 506                                          (simple-condition-format-arguments
 507                                           condition)))))
 508                        then (format *error-output* "~
 509 Reason: the format-arguments were incorrect.~%")
 510                             (format *error-output* "  wanted: ~s~%" wanted)
 511                             (format *error-output* "     got: ~s~%" got)
 512                        else ;; what else????
 513                             (error "internal-error"))
 514                else (let ((*print-length* 50)
 515                           (*print-level* 10))
 516                       (if* wanted-message
 517                          then (format *error-output*
 518                                       "  wanted: ~a~%" wanted-message)
 519                          else (if* (not multiple-values)
 520                                  then (format *error-output*
 521                                               "  wanted: ~s~%"
 522                                               expected-result)
 523                                  else (format
 524                                        *error-output*
 525                                        "  wanted values: ~{~s~^, ~}~%"
 526                                        expected-result)))
 527                       (if* got-message
 528                          then (format *error-output*
 529                                       "     got: ~a~%" got-message)
 530                          else (if* (not multiple-values)
 531                                  then (format *error-output* "     got: ~s~%"
 532                                        (second test-results))
 533                                  else (format
 534                                        *error-output*
 535                                        "     got values: ~{~s~^, ~}~%"
 536                                        (cdr test-results))))))
 537             (when fail-info
 538               (format *error-output* "Additional info: ~a~%" fail-info))
 539             (incf *test-errors*)
 540             (when *break-on-test-failures*
 541               (break "~a is non-nil." '*break-on-test-failures*))
 542        else (when known-failure
 543               (format *error-output*
 544                       "~&Expected test failure for ~s did not occur.~%"
 545                       test-form)
 546               (when fail-info
 547                 (format *error-output* "Additional info: ~a~%" fail-info))
 548               (setq fail t))
 549             (incf *test-successes*))
 550     (not fail)))
 551
 552 (defmacro with-tests ((&key (name "unnamed")) &body body)
 553   (let ((g-name (gensym)))
 554     `(flet ((doit () ,@body))
 555        (let ((,g-name ,name)
 556              (*test-errors* 0)
 557              (*test-successes* 0)
 558              (*test-unexpected-failures* 0))
 559          (format *error-output* "Begin ~a test~%" ,g-name)
 560          (if* *break-on-test-failures*
 561               then (doit)
 562               else (handler-case (doit)
 563                      (error (c)
 564                        (format
 565                         *error-output*
 566                         "~
 567 ~&Test ~a aborted by signalling an uncaught error:~%~a~%"
 568                         ,g-name c))))
 569          #+allegro
 570          (let ((state (sys:gsgc-switch :print)))
 571            (setf (sys:gsgc-switch :print) nil)
 572            (format t "~&**********************************~%")
 573            (format t "End ~a test~%" ,g-name)
 574            (format t "Errors detected in this test: ~s " *test-errors*)
 575            (unless (zerop *test-unexpected-failures*)
 576              (format t "UNEXPECTED: ~s" *test-unexpected-failures*))
 577            (format t "~%Successes this test:~s~%" *test-successes*)
 578            (setf (sys:gsgc-switch :print) state))
 579          #-allegro
 580          (progn
 581            (format t "~&**********************************~%")
 582            (format t "End ~a test~%" ,g-name)
 583            (format t "Errors detected in this test: ~D " *test-errors*)
 584            (unless (zerop *test-unexpected-failures*)
 585              (format t "UNEXPECTED: ~D" *test-unexpected-failures*))
 586            (format t "~%Successes this test:~D~%" *test-successes*))))))
 587
 588 (provide :tester #+module-versions 1.1)