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.2 2003/07/20 18:56:28 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 (defgeneric conditionp (thing) )
 208 (defmethod conditionp ((thing condition)) t)
 209 (defmethod conditionp ((thing t)) nil)
 210
 211 (defmacro test-error (form &key announce
 212                                 catch-breaks
 213                                 (fail-info nil fail-info-given)
 214                                 (known-failure nil known-failure-given)
 215                                 (condition-type ''simple-error)
 216                                 (include-subtypes nil include-subtypes-given)
 217                                 (format-control nil format-control-given)
 218                                 (format-arguments nil format-arguments-given))
 219   "Test that `form' signals an error. The order of evaluation of the
 220 arguments is keywords first, then test form.
 221
 222 If `announce' is non-nil, then cause the error message to be printed.
 223
 224 The `catch-breaks' is non-nil then consider a call to common-lisp:break an
 225 `error'.
 226
 227 `fail-info' allows more information to be printed with a test failure.
 228
 229 `known-failure' marks the test as a known failure.  This allows for
 230 programs that do regression analysis on the output from a test run to
 231 discriminate on new versus known failures.
 232
 233 If `condition-type' is non-nil, it should be a symbol naming a condition
 234 type, which is used to check against the signalled condition type.  The
 235 test will fail if they do not match.
 236
 237 `include-subtypes', used with `condition-type', can be used to match a
 238 condition to an entire subclass of the condition type hierarchy.
 239
 240 `format-control' and `format-arguments' can be used to check the error
 241 message itself."
 242   (let ((g-announce (gensym))
 243         (g-catch-breaks (gensym))
 244         (g-fail-info (gensym))
 245         (g-known-failure (gensym))
 246         (g-condition-type (gensym))
 247         (g-include-subtypes (gensym))
 248         (g-format-control (gensym))
 249         (g-format-arguments (gensym))
 250         (g-c (gensym)))
 251     `(let* ((,g-announce ,announce)
 252             (,g-catch-breaks ,catch-breaks)
 253             ,@(when fail-info-given `((,g-fail-info ,fail-info)))
 254             ,@(when known-failure-given `((,g-known-failure ,known-failure)))
 255             (,g-condition-type ,condition-type)
 256             ,@(when include-subtypes-given
 257                 `((,g-include-subtypes ,include-subtypes)))
 258             ,@(when format-control-given
 259                 `((,g-format-control ,format-control)))
 260             ,@(when format-arguments-given
 261                 `((,g-format-arguments ,format-arguments)))
 262             (,g-c (test-values-errorset ,form ,g-announce ,g-catch-breaks)))
 263        (test-check
 264         :predicate #'eq
 265         :expected-result t
 266         :test-results
 267         (test-values (and (conditionp ,g-c)
 268                           ,@(if* include-subtypes-given
 269                                then `((if* ,g-include-subtypes
 270                                          then (typep ,g-c ,g-condition-type)
 271                                          else (eq (class-of ,g-c)
 272                                                   (find-class
 273                                                    ,g-condition-type))))
 274                                else `((eq (class-of ,g-c)
 275                                           (find-class ,g-condition-type))))
 276                           ,@(when format-control-given
 277                               `((or
 278                                  (null ,g-format-control)
 279                                  (string=
 280                                   (concatenate 'simple-string
 281                                     "~1@<" ,g-format-control "~:@>")
 282                                   (simple-condition-format-control ,g-c)))))
 283                           ,@(when format-arguments-given
 284                               `((or
 285                                  (null ,g-format-arguments)
 286                                  (equal
 287                                   ,g-format-arguments
 288                                   (simple-condition-format-arguments ,g-c))))))
 289                      t)
 290         :test-form ',form
 291         ,@(when fail-info-given `(:fail-info ,g-fail-info))
 292         ,@(when known-failure-given `(:known-failure ,g-known-failure))
 293         :condition-type ,g-condition-type
 294         :condition ,g-c
 295         ,@(when include-subtypes-given
 296             `(:include-subtypes ,g-include-subtypes))
 297         ,@(when format-control-given
 298             `(:format-control ,g-format-control))
 299         ,@(when format-arguments-given
 300             `(:format-arguments ,g-format-arguments))))))
 301
 302 (defmacro test-no-error (form &key announce
 303                                    catch-breaks
 304                                    (fail-info nil fail-info-given)
 305                                    (known-failure nil known-failure-given))
 306   "Test that `form' does not signal an error.  The order of evaluation of
 307 the arguments is keywords first, then test form.
 308
 309 If `announce' is non-nil, then cause the error message to be printed.
 310
 311 The `catch-breaks' is non-nil then consider a call to common-lisp:break an
 312 `error'.
 313
 314 `fail-info' allows more information to be printed with a test failure.
 315
 316 `known-failure' marks the test as a known failure.  This allows for
 317 programs that do regression analysis on the output from a test run to
 318 discriminate on new versus known failures."
 319   (let ((g-announce (gensym))
 320         (g-catch-breaks (gensym))
 321         (g-fail-info (gensym))
 322         (g-known-failure (gensym))
 323         (g-c (gensym)))
 324     `(let* ((,g-announce ,announce)
 325             (,g-catch-breaks ,catch-breaks)
 326             ,@(when fail-info-given `((,g-fail-info ,fail-info)))
 327             ,@(when known-failure-given `((,g-known-failure ,known-failure)))
 328             (,g-c (test-values-errorset ,form ,g-announce ,g-catch-breaks)))
 329        (test-check
 330         :predicate #'eq
 331         :expected-result t
 332         :test-results (test-values (not (conditionp ,g-c)))
 333         :test-form ',form
 334         :condition ,g-c
 335         ,@(when fail-info-given `(:fail-info ,g-fail-info))
 336         ,@(when known-failure-given `(:known-failure ,g-known-failure))))))
 337
 338 (defvar *warn-cookie* (cons nil nil))
 339
 340 (defmacro test-warning (form &key fail-info known-failure)
 341   "Test that `form' signals a warning.  The order of evaluation of
 342 the arguments is keywords first, then test form.
 343
 344 `fail-info' allows more information to be printed with a test failure.
 345
 346 `known-failure' marks the test as a known failure.  This allows for
 347 programs that do regression analysis on the output from a test run to
 348 discriminate on new versus known failures."
 349   (let ((g-fail-info (gensym))
 350         (g-known-failure (gensym))
 351         (g-value (gensym)))
 352     `(let* ((,g-fail-info ,fail-info)
 353             (,g-known-failure ,known-failure)
 354             (,g-value (test-values-errorset ,form nil t)))
 355        (test
 356         *warn-cookie*
 357         (if* (or (typep ,g-value 'simple-warning) (typep ,g-value 'warning))
 358            then *warn-cookie*
 359            else ;; test produced no warning
 360                 nil)
 361         :test #'eq
 362         :reported-form ,form ;; quoted by test macro
 363         :wanted-message "a warning"
 364         :got-message "no warning"
 365         :fail-info ,g-fail-info
 366         :known-failure ,g-known-failure))))
 367
 368 (defmacro test-no-warning (form &key fail-info known-failure)
 369   "Test that `form' does not signal a warning.  The order of evaluation of
 370 the arguments is keywords first, then test form.
 371
 372 `fail-info' allows more information to be printed with a test failure.
 373
 374 `known-failure' marks the test as a known failure.  This allows for
 375 programs that do regression analysis on the output from a test run to
 376 discriminate on new versus known failures."
 377   (let ((g-fail-info (gensym))
 378         (g-known-failure (gensym))
 379         (g-value (gensym)))
 380     `(let* ((,g-fail-info ,fail-info)
 381             (,g-known-failure ,known-failure)
 382             (,g-value (test-values-errorset ,form nil t)))
 383        (test
 384         *warn-cookie*
 385         (if* (or (typep ,g-value 'simple-warning) (typep ,g-value 'warning))
 386            then nil ;; test produced warning
 387            else *warn-cookie*)
 388         :test #'eq
 389         :reported-form ',form
 390         :wanted-message "no warning"
 391         :got-message "a warning"
 392         :fail-info ,g-fail-info
 393         :known-failure ,g-known-failure))))
 394
 395 (defvar *announce-test* nil) ;; if true announce each test that was done
 396
 397 (defmacro errorset (form) ;subset of test-values-errorset
 398   `(handler-case
 399     (values-list (cons t (multiple-value-list ,form)))
 400     (error (cond)
 401      (format *error-output* "~&An error occurred: ~a~%" cond)
 402      nil)))
 403
 404
 405 (defun test-check (&key (predicate #'eql)
 406                         expected-result test-results test-form
 407                         multiple-values fail-info known-failure
 408                         wanted-message got-message condition-type condition
 409                         include-subtypes format-control format-arguments
 410                    &aux fail predicate-failed got wanted)
 411   ;; for debugging large/complex test sets:
 412   (when *announce-test*
 413     (format t "Just did test ~s~%" test-form)
 414     (force-output))
 415
 416   ;; this is an internal function
 417   (flet ((check (expected-result result)
 418            (let* ((results
 419                    (multiple-value-list
 420                     (errorset (funcall predicate expected-result result))))
 421                   (failed (null (car results))))
 422              (if failed
 423                  (progn
 424                    (setq predicate-failed t)
 425                    nil)
 426                  (cadr results)))))
 427     (when (conditionp test-results)
 428       (setq condition test-results)
 429       (setq test-results nil))
 430     (when (null (car test-results))
 431       (setq fail t))
 432     (if* (and (not fail) (not multiple-values))
 433        then ;; should be a single result
 434             ;; expected-result is the single result wanted
 435             (when (not (and (cdr test-results)
 436                             (check expected-result (cadr test-results))))
 437               (setq fail t))
 438             (when (and (not fail) (cddr test-results))
 439               (setq fail 'single-got-multiple))
 440        else ;; multiple results wanted
 441             ;; expected-result is a list of results, each of which
 442             ;; should be checked against the corresponding test-results
 443             ;; using the predicate
 444             (do ((got (cdr test-results) (cdr got))
 445                  (want expected-result (cdr want)))
 446                 ((or (null got) (null want))
 447                  (when (not (and (null want) (null got)))
 448                    (setq fail t)))
 449               (when (not (check (car got) (car want)))
 450                 (return (setq fail t)))))
 451     (if* fail
 452        then (when (not known-failure)
 453               (format *error-output*
 454                       "~& * * * UNEXPECTED TEST FAILURE * * *~%")
 455               (incf *test-unexpected-failures*))
 456             (format *error-output* "~&Test failed: ~@[known failure: ~*~]~s~%"
 457                     known-failure test-form)
 458             (if* (eq 'single-got-multiple fail)
 459                then (format
 460                      *error-output*
 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* "Reason: an error~@[ (of type `~s')~] was detected.~%"
 466                             (when condition (class-of condition)))
 467              elseif condition
 468                then (if* (not (conditionp condition))
 469                        then (format *error-output* "Reason: expected but did not detect an error of type `~s'.~%"
 470                                     condition-type)
 471                      elseif (null condition-type)
 472                        then (format *error-output* "Reason: detected an unexpected error of type `~s':
 473         ~a.~%"
 474                                     (class-of condition)
 475                                     condition)
 476                      elseif (not (if* include-subtypes
 477                                     then (typep condition condition-type)
 478                                     else (eq (class-of condition)
 479                                              (find-class condition-type))))
 480                        then (format *error-output* "Reason: detected an incorrect condition type.~%")
 481                             (format *error-output*
 482                                     "  wanted: ~s~%" condition-type)
 483                             (format *error-output*
 484                                     "     got: ~s~%" (class-of condition))
 485                      elseif (and format-control
 486                                  (not (string=
 487                                        (setq got
 488                                          (concatenate 'simple-string
 489                                            "~1@<" format-control "~:@>"))
 490                                        (setq wanted
 491                                          (simple-condition-format-control
 492                                           condition)))))
 493                        then ;; format control doesn't match
 494                             (format *error-output* "Reason: the format-control was incorrect.~%")
 495                             (format *error-output* "  wanted: ~s~%" wanted)
 496                             (format *error-output* "     got: ~s~%" got)
 497                      elseif (and format-arguments
 498                                  (not (equal
 499                                        (setq got format-arguments)
 500                                        (setq wanted
 501                                          (simple-condition-format-arguments
 502                                           condition)))))
 503                        then (format *error-output* "Reason: the format-arguments were incorrect.~%")
 504                             (format *error-output* "  wanted: ~s~%" wanted)
 505                             (format *error-output* "     got: ~s~%" got)
 506                        else ;; what else????
 507                             (error "internal-error"))
 508                else (let ((*print-length* 50)
 509                           (*print-level* 10))
 510                       (if* wanted-message
 511                          then (format *error-output*
 512                                       "  wanted: ~a~%" wanted-message)
 513                          else (if* (not multiple-values)
 514                                  then (format *error-output*
 515                                               "  wanted: ~s~%"
 516                                               expected-result)
 517                                  else (format
 518                                        *error-output*
 519                                        "  wanted values: ~{~s~^, ~}~%"
 520                                        expected-result)))
 521                       (if* got-message
 522                          then (format *error-output*
 523                                       "     got: ~a~%" got-message)
 524                          else (if* (not multiple-values)
 525                                  then (format *error-output* "     got: ~s~%"
 526                                        (second test-results))
 527                                  else (format
 528                                        *error-output*
 529                                        "     got values: ~{~s~^, ~}~%"
 530                                        (cdr test-results))))))
 531             (when fail-info
 532               (format *error-output* "Additional info: ~a~%" fail-info))
 533             (incf *test-errors*)
 534             (when *break-on-test-failures*
 535               (break "~a is non-nil." '*break-on-test-failures*))
 536        else (when known-failure
 537               (format *error-output*
 538                       "~&Expected test failure for ~s did not occur.~%"
 539                       test-form)
 540               (when fail-info
 541                 (format *error-output* "Additional info: ~a~%" fail-info))
 542               (setq fail t))
 543             (incf *test-successes*))
 544     (not fail)))
 545
 546 (defmacro with-tests ((&key (name "unnamed")) &body body)
 547   (let ((g-name (gensym)))
 548     `(flet ((doit () ,@body))
 549        (let ((,g-name ,name)
 550              (*test-errors* 0)
 551              (*test-successes* 0)
 552              (*test-unexpected-failures* 0))
 553          (format *error-output* "Begin ~a test~%" ,g-name)
 554          (if* *break-on-test-failures*
 555               then (doit)
 556               else (handler-case (doit)
 557                      (error (c)
 558                        (format
 559                         *error-output*
 560                         "~&Test ~a aborted by signalling an uncaught error:~%~a~%"
 561                         ,g-name c))))
 562          #+allegro
 563          (let ((state (sys:gsgc-switch :print)))
 564            (setf (sys:gsgc-switch :print) nil)
 565            (format t "~&**********************************~%")
 566            (format t "End ~a test~%" ,g-name)
 567            (format t "Errors detected in this test: ~s " *test-errors*)
 568            (unless (zerop *test-unexpected-failures*)
 569              (format t "UNEXPECTED: ~s" *test-unexpected-failures*))
 570            (format t "~%Successes this test:~s~%" *test-successes*)
 571            (setf (sys:gsgc-switch :print) state))
 572          #-allegro
 573          (progn
 574            (format t "~&**********************************~%")
 575            (format t "End ~a test~%" ,g-name)
 576            (format t "Errors detected in this test: ~D " *test-errors*)
 577            (unless (zerop *test-unexpected-failures*)
 578              (format t "UNEXPECTED: ~D" *test-unexpected-failures*))
 579            (format t "~%Successes this test:~D~%" *test-successes*))))))
 580
 581 (provide :tester #+module-versions 1.1)