dev/reports.lisp

   1 (in-package #:lift)
   2
   3 ;; dribble
   4 ;; full output for all tests on separate pages per suite? whatever.
   5 ;; test environment
   6
   7 #|
   8 For *standard-input*: an input stream
   9
  10 For *error-output*, *standard-output*, and *trace-output*: an output stream.
  11
  12 For *debug-io*, *query-io*: a bidirectional stream.
  13 |#
  14
  15 #|
  16
  17   (start-report-output result stream format)
  18   (summarize-test-result result stream format)
  19   (summarize-test-environment result stream format)
  20   (when (or (failures result) (errors result)
  21             (expected-failures result) (expected-errors result)
  22             (skipped-test-cases result))
  23     (summarize-test-problems result stream format))
  24   (summarize-tests-run result stream format)
  25   (end-report-output result stream format)
  26   (generate-detailed-reports result stream format))
  27
  28 lift::(progn
  29   (setf (test-result-property *test-result* :style-sheet) "test-style.css")
  30   (setf (test-result-property *test-result* :title) "lubm-50")
  31   (setf (test-result-property *test-result* :unique-name) t)
  32   (test-result-report *test-result* #p "/fi/internal/people/gwking/agraph/testing/report/2008-08-21-lubm-50-prolog" :html))
  33
  34 lift::(progn
  35         (setf (test-result-property *test-result* :style-sheet)
  36               "test-style.css")
  37         (setf (test-result-property *test-result* :title)
  38               "Ugh")
  39         (setf (test-result-property *test-result* :if-exists)
  40               :error)
  41         (test-result-report *test-result*  #p"report-20080813a.sav" :save))
  42
  43 (run-tests :suite '(lift-test test-cursors))
  44
  45 (run-tests :suite 'lift-test-ensure)
  46
  47 (test-result-property *test-result* :title)
  48 |#
  49
  50
  51 (defvar *log-header-hooks* nil)
  52 (defvar *log-footer-hooks* nil)
  53 (defvar *log-detail-hooks* nil)
  54
  55 (defvar *report-hooks* nil)
  56
  57 (defun report-hooks-for (mode)
  58   (cdr (assoc mode *report-hooks*)))
  59
  60 (defun (setf report-hooks-for) (value mode)
  61   (setf *report-hooks* (remove mode *report-hooks* :key 'car))
  62   (push (cons mode value) *report-hooks*)
  63   value)
  64
  65 (defun add-report-hook-for (mode hook)
  66   (setf (report-hooks-for mode) (push hook (report-hooks-for mode))))
  67
  68 (defgeneric start-report-output (result stream format)
  69   )
  70
  71 (defgeneric summarize-test-result (result stream format)
  72   )
  73
  74 (defgeneric summarize-test-environment (result stream format)
  75   )
  76
  77 (defgeneric summarize-test-problems (result stream format)
  78   )
  79
  80 (defgeneric summarize-test-problems-of-type
  81     (format problems stream id heading name kind)
  82   )
  83
  84 (defgeneric write-log-test
  85     (format suite-name test-case-name data &key stream)
  86   )
  87
  88 (defgeneric generate-detailed-reports (result stream format)
  89   )
  90
  91 (defgeneric summarize-tests-run (result stream format)
  92  )
  93
  94 (defgeneric end-report-output (result stream format)
  95  )
  96
  97 (defgeneric html-header (stream title style-sheet)
  98  )
  99
 100 ;; when it doubt, add a special
 101 (defvar *report-environment* nil
 102   "Used internally by LIFT reports.")
 103
 104 (defun make-report-environment ()
 105   nil)
 106
 107 ;; env variables need to be part saved in result
 108
 109 (defgeneric test-result-report (result output format
 110                                &key package &allow-other-keys)
 111   )
 112
 113 (defmethod test-result-report (result output format
 114                                &rest args
 115                                &key (package *package*) &allow-other-keys)
 116   (declare (ignore args))
 117   (let ((*report-environment* (make-report-environment))
 118         (*package* (or (find-package package) *package*)))
 119     (cond ((or (stringp output)
 120                (pathnamep output))
 121            (with-open-file (stream
 122                             output
 123                             :direction :output
 124                             :if-does-not-exist :create
 125                             :if-exists (or (test-result-property
 126                                             result :if-exists)
 127                                            :error))
 128              (%test-result-report-stream result stream format)))
 129           ((streamp output)
 130            (%test-result-report-stream result output format))
 131           ((eq output t)
 132            (%test-result-report-stream result *standard-output* format))
 133           (t
 134            (error "Don't know how to send a report to ~s" output)))))
 135
 136 (defun %test-result-report-stream (result stream format)
 137   (start-report-output result stream format)
 138   (summarize-test-result result stream format)
 139   (summarize-test-environment result stream format)
 140   (summarize-test-problems result stream format)
 141   (summarize-tests-run result stream format)
 142   (end-report-output result stream format)
 143   (generate-detailed-reports result stream format))
 144
 145 (defmethod start-report-output (result stream format)
 146   (declare (ignore result stream format))
 147   )
 148
 149 (defmethod summarize-test-result (result stream format)
 150   (declare (ignore format))
 151   (format stream"~&Test results for: ~a~%"
 152           (results-for result))
 153   (let ((complete-success? (and (null (errors result))
 154                                 (null (failures result)))))
 155     (cond (complete-success?
 156            (format stream"~&~A Successful test~:P~%"
 157                    (length (tests-run result))))
 158           (t
 159            (format stream "~&~A Test~:P~[~:;, ~:*~A Failure~:P~]~[~:;, ~:*~A Error~:P~].~%"
 160                         (length (tests-run result))
 161                         (length (failures result))
 162                         (length (errors result)))))))
 163
 164 (defmethod summarize-test-environment (result stream format)
 165   (format stream "~&Lisp: ~a (~a)"
 166           (lisp-version-string) (lisp-implementation-version))
 167   (format stream "~&On  : ~a ~a ~a"
 168           (machine-type) (machine-version) (machine-instance))
 169   (terpri stream)
 170   (let ((*standard-output* stream))
 171     (loop for hook in (report-hooks-for :summarize-environment) do
 172          (funcall hook result format)))
 173   (terpri stream)
 174   )
 175
 176 (defmethod summarize-test-problems (result stream format)
 177   (declare (ignore result stream format))
 178   )
 179
 180 (defmethod generate-detailed-reports (result stream format)
 181   (declare (ignore result stream format))
 182   )
 183
 184 (defmethod summarize-tests-run (result stream format)
 185   (declare (ignore result stream format)))
 186
 187 (defmethod end-report-output (result stream format)
 188   (declare (ignore result stream format))
 189   )
 190
 191 #+(or)
 192 (defun summarize-test-environment (result stream format)
 193   (loop for symbol in (sort `((*lift-dribble-pathname*)
 194                               (*lift-debug-output* interpret-lift-stream)
 195                               (*lift-standard-output* interpret-lift-stream)
 196                               (*test-break-on-errors?*)
 197                               (*test-do-children?*)
 198                               (*lift-equality-test*)
 199                               (*test-print-length*)
 200                               (*test-print-level*)
 201                               (*lift-if-dribble-exists*))
 202                             'string-lessp :key 'first) do
 203
 204        (print)))
 205
 206
 207 ;; some cruft stolen from cl-markdown
 208 (defvar *html-meta*
 209   '((name (:author :description :copyright :keywords :date))
 210     (http-equiv (:refresh :expires))))
 211
 212 (defmethod start-report-output (result stream (format (eql :html)))
 213   (html-header
 214    stream
 215    (test-result-property result :title)
 216    (test-result-property result :style-sheet)))
 217
 218 (defmethod html-header (stream title style-sheet)
 219   (format stream "~&<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.0 Strict//EN\"
 220         \"http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd\">")
 221   (format stream "~&<html>~&<head>")
 222   (when title
 223     (format stream "~&<title>~a</title>" title))
 224   (when style-sheet
 225     (unless (search ".css" style-sheet)
 226       (setf style-sheet (concatenate 'string style-sheet ".css")))
 227     (format stream "~&<link type='text/css' href='~a' rel='stylesheet' />"
 228             style-sheet))
 229   (format stream "~&</head>~&<body>"))
 230
 231 (defmethod summarize-test-result (result stream (format (eql :html)))
 232   (format stream "~&<div id=\"summary\">")
 233   (format stream "~&<h1>Test results for: ")
 234   (cond ((ignore-errors (probe-file (results-for result)))
 235          (let ((config-html (merge-pathnames "config.html" stream)))
 236            (save-configuration-file result config-html)
 237            (format stream "<a href=\"config.html\">~a</a>"
 238                    (results-for result))))
 239         (t
 240          (format stream "~a" (results-for result))))
 241   (format stream "</h1>~%")
 242   (let ((complete-success? (and (null (errors result))
 243                                 (null (failures result)))))
 244     (cond (complete-success?
 245            (format stream "~&<h2>~A Successful test~:P</h2>~%"
 246                    (length (tests-run result))))
 247           (t
 248            (format stream "~&<h2>~:d test~:p"
 249                    (length (tests-run result)))
 250            (format stream "~[~:;, ~:*<a href=\"#failures\">~:d failure~:P</a>~]"
 251                    (length (failures result)))
 252            (format stream "~[~:;, ~:*<a href=\"#errors\">~:d error~:P</a>~]"
 253                    (length (errors result)))
 254            (format stream "</h2>")))
 255
 256     (when (or (expected-errors result) (expected-failures result)
 257               (skipped-test-cases result) (skipped-testsuites result))
 258       (format stream "~&<h3>")
 259       (let ((first? t))
 260         (loop for (fn div title) in `((expected-errors   "expected-errors"   "Expected error")
 261                                       (expected-failures "expected-failures" "Expected failure")
 262                                       (skipped-test-cases "skipped-test-cases" "Skipped test cases")
 263                                       (skipped-testsuites "skipped-testsuites" "Skipped testsuites")) do
 264              (let ((count (length (funcall fn result))))
 265                (when (plusp count)
 266                  (unless first? (format stream ", "))
 267                  (setf first? nil)
 268                  (format stream "<a href=\"#~a\">~a~p: ~:*~:d</a>" div title count)))))
 269       (format stream "</h3>~%"))
 270
 271     (when (and (slot-boundp result 'end-time-universal)
 272                (numberp (end-time-universal result))
 273                (numberp (start-time-universal result)))
 274       (format stream "~&<h3>Testing took: ~:d seconds</h3>"
 275               (- (end-time-universal result)
 276                  (start-time-universal result)))))
 277   (format stream "~&</div>"))
 278
 279 (defmethod summarize-test-environment (result stream (format (eql :html)))
 280   (declare (ignore result))
 281   (format stream "~&<div id=\"environment\">")
 282   (call-next-method)
 283   (format stream "~&</div>"))
 284
 285 (defmethod summarize-tests-run (result stream (format (eql :html)))
 286   (flet ((doit (stream)
 287            (format stream "~&<div id=\"results\">")
 288            (format stream "~&<h2>Tests Run:</h2>")
 289            (format stream "<div>(list of test suite and their test cases. Each test case shows its start-time, name, time taken (in seconds), conses used and any additional information).</div>")
 290            (report-tests-by-suite format (tests-run result) stream nil)
 291            (format stream "~&</div>")))
 292     (cond ((or (failures result) (errors result)
 293                (expected-failures result) (expected-errors result))
 294            ;; print separately
 295            (with-open-file (new-stream (merge-pathnames "summary.html" stream)
 296                                        :direction :output
 297                                        :if-does-not-exist :create
 298                                        :if-exists :supersede)
 299              (html-header
 300               new-stream
 301               "test summary"
 302               (test-result-property result :style-sheet))
 303              (format new-stream "~&<br><br><h1>Test Summary</h1>~%")
 304              (format new-stream "~&<a href=\"~a\">Back</a>"
 305                      (namestring (make-pathname :name (pathname-name stream)
 306                                                 :type (pathname-type stream))))
 307              (doit new-stream)
 308              (html-footer new-stream))
 309            (format stream
 310                    "~&<h2><a href=\"summary.html\">Test result summary</a></h2>~%")
 311            (when (errors result)
 312              (build-issues-report result :errors stream))
 313            (when (failures result)
 314              (build-issues-report result :failures stream))
 315            (when (expected-failures result)
 316              (build-issues-report result :expected-failures stream))
 317            (when (expected-errors result)
 318              (build-issues-report result :expected-errors stream))
 319            (when (skipped-test-cases result)
 320              (build-issues-report result :skipped-testsuites stream)))
 321           (t
 322            (doit stream)))))
 323
 324 (defmethod summarize-test-problems (result stream (format (eql :html)))
 325   (let ((done-header? nil))
 326     (flet ((output-header ()
 327              (unless done-header?
 328                (format stream "~&<div id=\"problem-summary\">")
 329                (format stream "~&<h2>Problem Summary:</h2>"))
 330              (setf done-header? t)))
 331       (loop for (fn id heading name kind) in
 332            `((configuration-failures "configuration-failure-summary"
 333                                      "Configuration Failures" "configuration-failures" :config-failures)
 334              (errors "error-summary" "Errors" "errors" :errors)
 335              (testsuite-failures "failure-summary" "Failures" "failures" :failures)
 336              (expected-failures  "expected-failure-summary" "Expected Failures" "expected-failures"
 337                                  :expected-failures)
 338              (expected-errors "expected-failure-summary"
 339                               "Expected Errors" "expected-errors"
 340                               :expected-errors)
 341              (skipped-test-cases "skipped-cases-summary"
 342                                  "Skipped test cases" "skipped-tests"
 343                                  :skipped-test-cases)
 344              (skipped-testsuites  "skipped-suites-summary"
 345                                   "Skipped testsuites" "skipped-tests"
 346                                   :skipped-test-suites))
 347            do
 348            (let ((problems (funcall fn result)))
 349              (when problems
 350                (output-header)
 351                (summarize-test-problems-of-type
 352                 format problems stream id heading name kind)))))
 353     (when done-header?
 354       (format stream "~&</div>"))))
 355
 356 (defmethod problem-summarization ((problem testsuite-problem-mixin))
 357   `(,(testsuite problem) ,(test-method problem) (:problem ,problem)))
 358
 359 (defmethod problem-summarization ((problem test-configuration-problem-mixin))
 360   `(:configuration :configuration (:problem ,problem)))
 361
 362 (defmethod summarize-test-problems-of-type
 363     (format problems stream id heading name kind)
 364   (when problems
 365     (format stream "~&<div id=\"~a\">" id)
 366     (format stream "~&<a name=\"~a\"></a><h3>~a</h3>" name heading)
 367     (report-tests-by-suite
 368      format (mapcar #'problem-summarization problems) stream kind)
 369     (format stream "~&</div>")))
 370
 371 (defun report-tests-by-suite (format tests stream kind)
 372   (let ((current-suite nil))
 373     (loop for rest = (sort (copy-list tests)
 374                            'string-lessp :key 'first) then (rest rest)
 375        while rest
 376        for (suite test-name datum) = (first rest) do
 377          (unless (eq current-suite suite)
 378            (report-test-suite-by-suite format stream rest current-suite suite kind)
 379            (setf current-suite suite))
 380          (report-test-case-by-suite format stream suite test-name datum kind))
 381     (finish-report-tests-by-suite format stream current-suite)))
 382
 383 (defmethod report-test-suite-by-suite
 384     (format stream remaining current-suite suite kind)
 385   (declare (ignore format stream remaining current-suite suite kind))
 386   )
 387
 388 (defmethod report-test-case-by-suite (format stream suite test-name datum kind)
 389   (declare (ignore format stream suite test-name datum kind))
 390   )
 391
 392 (defmethod finish-report-tests-by-suite (format stream current-suite)
 393   (declare (ignore format stream current-suite))
 394   )
 395
 396 (defmethod report-test-suite-by-suite
 397     :around ((format (eql :html)) stream remaining current-suite suite kind)
 398   (declare (ignore remaining suite kind))
 399   (finish-report-tests-by-suite format stream current-suite)
 400   (call-next-method)
 401   (format stream "</div>"))
 402
 403 (defmethod report-test-suite-by-suite
 404     ((format (eql :html)) stream remaining current-suite (suite (eql :configuration)) kind)
 405   (declare (ignore remaining current-suite kind))
 406   (format stream "~&<div class=\"testsuite\">"))
 407
 408 (defmethod report-test-suite-by-suite
 409     ((format (eql :html)) stream remaining current-suite suite kind)
 410   (declare (ignore current-suite kind))
 411   (format stream "~&<div class=\"testsuite\">")
 412   (let* ((this-suite-end (or
 413                           (position-if
 414                            (lambda (datum)
 415                              (not (eq suite (first datum))))
 416                            remaining)
 417                           (length remaining)))
 418          (error-count (count-if
 419                        (lambda (datum)
 420                          (and (getf (third datum) :problem)
 421                               (typep (getf (third datum) :problem)
 422                                      'test-error)))
 423                        remaining
 424                        :end this-suite-end))
 425          (failure-count (count-if
 426                          (lambda (datum)
 427                            (and (getf (third datum) :problem)
 428                                 (typep (getf (third datum) :problem)
 429                                        'test-failure)))
 430                          remaining
 431                          :end this-suite-end))
 432          (extra-class (cond ((and (= error-count 0) (= failure-count 0))
 433                              'testsuite-all-passed)
 434                             ((> error-count 0)
 435                              'testsuite-some-errors)
 436                             (t
 437                              'testsuite-some-failures))))
 438     (format stream "~&<div class=\"testsuite-title\"><table class=\"~a\"><tr><td>~a</td>" extra-class suite)
 439     (format stream "<td class=\"testsuite-test-count\">~:d test~:p</td>"
 440             (test-case-count suite))
 441     (format stream "<td class=\"testsuite-summary\">")
 442     (cond ((and (= error-count 0) (= failure-count 0))
 443            (format stream "all passed"))
 444           (t
 445            (format stream "~[~:;~:*~:d failure~:p~]"
 446                    failure-count)
 447            (when (and (> error-count 0) (> failure-count 0))
 448              (format stream ", "))
 449            (format stream  "~[~:;~:*~a error~:p~]"
 450                    error-count)))
 451     (format stream "</td></tr></table>")))
 452
 453 (defmethod report-test-case-by-suite
 454     ((format (eql :html)) stream suite test-name datum kind)
 455   (format stream "~&<div class=\"test-case\">")
 456   (let ((problem (getf datum :problem))
 457         (start (getf datum :start-time)))
 458     (when start
 459       (format stream "<span class=\"start-time\">~a</span>"
 460               (format-test-time-for-log start)))
 461     (cond ((typep problem 'test-failure)
 462            (format stream "~&<span class=\"test-name\"><a href=\"~a\" title=\"details\">~a</a></span>~@[, <span>~a</span>~]"
 463                    (details-link suite test-name)
 464                    test-name (extra-info kind suite test-name))
 465            (format stream
 466                    "~&<span class=\"test-failure\">failure</span>" ))
 467           ((typep problem 'test-error)
 468            (format stream "~&<span class=\"test-name\"><a href=\"~a\" title=\"details\">~a [during ~a]</a></span>~@[, <span>~a</span>~]"
 469                    (details-link suite test-name)
 470                    test-name
 471                    (test-step problem) (extra-info kind suite test-name))
 472            (format stream "~&<span class=\"test-error\">error</span>"))
 473           (t
 474            (format stream "~&<span class=\"test-name\">~a</span>~@[, <span>~a</span>~]"
 475                    test-name (extra-info kind suite test-name))
 476            (let ((seconds (getf datum :seconds))
 477                  (conses (getf datum :conses)))
 478              (when seconds
 479                (format stream "<span class=\"test-time\">~,3f</span>"
 480                        seconds))
 481              (when conses
 482                (format stream "<span class=\"test-space\">~:d</span>"
 483                        conses)))))
 484     (format stream "~&</div>")))
 485
 486 (defmethod report-test-case-by-suite
 487     ((format (eql :html)) stream (suite (eql :configuration)) test-name datum kind)
 488   (declare (ignore test-name kind))
 489   (format stream "~&<div class=\"test-case\">")
 490   (let ((problem (getf datum :problem)))
 491     (format stream "~&<span class=\"test-name\">~a</span>: ~a~%"
 492             (test-problem-kind problem)
 493             (test-problem-message problem))
 494     (format stream "~&</div>")))
 495
 496 (defmethod finish-report-tests-by-suite
 497     ((format (eql :html)) stream current-suite)
 498   (when current-suite
 499     (format stream "</div>")))
 500
 501 (defun get-details-links-table ()
 502   (let ((hash (getf *report-environment* :details-links)))
 503     (or hash
 504         (setf (getf *report-environment* :details-links)
 505               (make-hash-table :test 'equal)))))
 506
 507 #+(or)
 508 (get-details-links-table)
 509
 510 (defun details-link (suite name)
 511   (let* ((hash (get-details-links-table)))
 512     (or (gethash (cons suite name) hash)
 513         (progn
 514           (incf (getf *report-environment* :details-links-count 0))
 515           (setf (gethash (cons suite name) hash)
 516                 (make-pathname
 517                  :name (format nil "details-~a"
 518                                (getf *report-environment* :details-links-count))
 519                  :type "html"))))))
 520
 521 (defmethod end-report-output (result stream (format (eql :html)))
 522   (let ((style-sheet (test-result-property result :style-sheet)))
 523     (when style-sheet
 524       (ignore-errors
 525         (copy-file (asdf:system-relative-pathname
 526                     'lift "resources/test-style.css")
 527                    (make-pathname
 528                     :name (pathname-name style-sheet)
 529                     :type (pathname-type style-sheet)
 530                     :defaults (pathname stream))
 531                    :if-exists :supersede))))
 532   (html-footer stream))
 533
 534 (defun html-footer (stream)
 535   (format stream "<div id=\"footer\">")
 536   (format stream "~&generated on ~a"
 537           #+allegro
 538           (excl:locale-print-time
 539            (get-universal-time)
 540            :fmt "%B %d, %Y %T GMT%z" :stream nil)
 541           #-allegro
 542           (get-universal-time))
 543   (format stream "</div>")
 544   (format stream "~&</body></html>"))
 545
 546 (defmethod generate-detailed-reports (result stream (format (eql :html)))
 547   (loop for (suite-name test-name datum) in (tests-run result)
 548      when (getf datum :problem) do
 549      (let ((output-pathname (merge-pathnames
 550                              (details-link suite-name test-name)
 551                              stream)))
 552        (ensure-directories-exist output-pathname)
 553        (let ((*print-right-margin* 64)
 554              (problem (getf datum :problem))
 555              (source-file (gethash test-name (test-case-source-file suite-name)))
 556              (start-time (getf datum :start-time)))
 557          (with-open-file (out output-pathname
 558                               :direction :output
 559                               :if-does-not-exist :create
 560                               :if-exists :supersede)
 561            (html-header
 562             out
 563             (format nil "Test ~a details | ~a"
 564                     test-name (test-result-property result :title))
 565             (test-result-property result :style-sheet))
 566            (format out "~&<h2>Suite ~a, case ~a details</h2>"
 567                    suite-name test-name)
 568            (format out "~&<a href=\"~a\">Back</a>"
 569                    (namestring (make-pathname :name (pathname-name stream)
 570                                               :type (pathname-type stream))))
 571            (format out "~&<p>Problem occurred during ~a.</p>"
 572                    (test-step problem))
 573                    (format out "<pre>")
 574            (when source-file
 575              (format out "~&Source file: ~a" source-file))
 576            (when start-time
 577              (format out "~&Start time: ~a"
 578                      (format-test-time-for-log start-time)))
 579            (format out "~&<pre>")
 580            (format out "~&<p>Reproduce using: <pre>")
 581            (format out "~&  (lift:run-test :suite '~a :name '~a" suite-name test-name)
 582            (when (testsuite-initargs problem)
 583              (format out "~&            :testsuite-initargs '~s"
 584                      (testsuite-initargs problem)))
 585            (format out ")")
 586            (format out "~&  (lift:run-tests :suite '~a" suite-name)
 587            (when (testsuite-initargs problem)
 588              (format out "~&            :testsuite-initargs '~s"
 589                      (testsuite-initargs problem)))
 590            (format out ")")
 591            (format out "~&</pre>")
 592            (format out "~&<pre>")
 593            (format out "~a"
 594                    (wrap-encode-pre
 595                     (with-output-to-string (s)
 596                       (print-test-problem "" problem s t))
 597                     :width (test-result-property
 598                             *test-result* :print-width 60)))
 599            (format out "~&</pre>")
 600            (when (and (typep problem 'test-error-mixin)
 601                       (backtrace problem))
 602              (format out "~&~%<h2>Backtrace</h2>~%~%")
 603              (format out "~&<pre><code>~%")
 604              (format out "~a"
 605                      (wrap-encode-pre
 606                       (with-output-to-string (s)
 607                         (print (backtrace problem) s))
 608                       :width (test-result-property
 609                               *test-result* :print-width 60)))
 610              (format out "~&</pre></code>~%"))
 611            (html-footer out))))))
 612
 613 #+(or)
 614 (defmethod summarize-test-environment (result stream format)
 615   (loop for symbol in (sort `((*lift-dribble-pathname*)
 616                               (*lift-debug-output* interpret-lift-stream)
 617                               (*lift-standard-output* interpret-lift-stream)
 618                               (*test-break-on-errors?*)
 619                               (*test-do-children?*)
 620                               (*lift-equality-test*)
 621                               (*test-print-length*)
 622                               (*test-print-level*)
 623                               (*lift-if-dribble-exists*))
 624                             'string-lessp :key 'first) do
 625
 626        (print)))
 627
 628 (defun wrap-encode-pre (string &key (width 80))
 629   ;; Copied from CL-Markdown
 630   ;; Copied from HTML-Encode
 631   ;;?? this is very consy
 632   ;;?? crappy name
 633   (declare (simple-string string))
 634   (let ((output (make-array (truncate (length string) 2/3)
 635                             :element-type 'character
 636                             :adjustable t
 637                             :fill-pointer 0))
 638         (column 0))
 639     (with-output-to-string (out output)
 640       (loop for char across string
 641          do (case char
 642               ((#\&) (incf column) (write-string "&amp;" out))
 643               ((#\<) (incf column) (write-string "&lt;" out))
 644               ((#\>) (incf column) (write-string "&gt;" out))
 645               ((#\Tab #\Space #\Return #\Newline)
 646                (cond ((or (>= column width)
 647                           (char= char #\Return)
 648                           (char= char #\Newline))
 649                       (setf column 0)
 650                       (terpri out))
 651                      ((char= char #\Space)
 652                       (incf column)
 653                       (write-char char out))
 654                      ((char= char #\Tab)
 655                       (incf column 4)
 656                       (write-string "    " out))))
 657               (t (incf column) (write-char char out)))))
 658     (coerce output 'simple-string)))
 659
 660 ;;;;;
 661
 662 (defmethod summarize-test-result (result stream (format (eql :describe)))
 663   (describe result stream))
 664
 665 (defmethod summarize-tests-run (result stream (format (eql :detail)))
 666   (format stream "~&## Tests Run:")
 667   (let ((tests (tests-run result))
 668         (current-suite nil))
 669     (loop for rest = tests then (rest rest)
 670        while rest
 671        for (suite test-name datum) = (first rest) do
 672        (unless (eq current-suite suite)
 673          (when current-suite
 674            (format stream "~%~%"))
 675          (setf current-suite suite)
 676          (let* ((this-suite-end (or
 677                                  (position-if
 678                                   (lambda (datum)
 679                                     (not (eq current-suite (first datum))))
 680                                   rest)
 681                                  (length rest)))
 682                 (error-count (count-if
 683                               (lambda (datum)
 684                                 (and (getf (third datum) :problem)
 685                                      (typep (getf (third datum) :problem)
 686                                             'test-error)))
 687                               rest
 688                               :end this-suite-end))
 689                 (failure-count (count-if
 690                                 (lambda (datum)
 691                                   (and (getf (third datum) :problem)
 692                                        (typep (getf (third datum) :problem)
 693                                               'test-failure)))
 694                                 rest
 695                                 :end this-suite-end))
 696                 #+(or)
 697                 (extra-class (cond ((and (= error-count 0) (= failure-count 0))
 698                                     'testsuite-all-passed)
 699                                    ((> error-count 0)
 700                                     'testsuite-some-errors)
 701                                    (t
 702                                     'testsuite-some-failures))))
 703            (format stream "~%### ~a, ~d tests ~&"
 704                    suite (test-case-count current-suite))
 705            (cond ((and (= error-count 0) (= failure-count 0))
 706                   (format stream "all passed"))
 707                  (t
 708                   (format stream "~[~:;~:*~:d failure~:p~]"
 709                           failure-count)
 710                   (when (and (> error-count 0) (> failure-count 0))
 711                     (format stream ", "))
 712                   (format stream  "~[~:;~:*~a error~:p~]"
 713                           error-count)))))
 714          (let ((problem (getf datum :problem)))
 715            (cond ((typep problem 'test-failure)
 716                   (format stream "~&failure" ))
 717                  ((typep problem 'test-error)
 718                   (format stream "~&error"))
 719                  (t
 720                   (format stream "~&~a" test-name)
 721                   (let ((seconds (getf datum :seconds))
 722                         (conses (getf datum :conses)))
 723                     (when seconds
 724                       (format stream "~15,3f" seconds))
 725                     (when conses
 726                       (format stream "~15:d" conses)))))))))
 727
 728
 729 ;;;;;
 730
 731 (defmethod summarize-test-result (result stream (format (eql :save)))
 732   (flet ((add-property (name)
 733            (when (slot-boundp result name)
 734              (format stream "~&\(~s ~a\)"
 735                      (intern (symbol-name name) :keyword)
 736                      (slot-value result name)))))
 737     (format stream "\(~%")
 738     (add-property 'results-for)
 739     (format stream "~&\(:date-time ~a\)" (get-universal-time))
 740     (add-property 'real-start-time-universal)
 741     (add-property 'start-time-universal)
 742     (add-property 'end-time-universal)
 743     (add-property 'real-end-time-universal)
 744     (format stream "~&\(:tests-run ")
 745     (loop for (suite name data) in
 746          (copy-list (tests-run result)) do
 747          (write-log-test format suite name data :stream stream))
 748     (format stream "~&\)")
 749     (format stream "~&\)")))
 750
 751 #+(or)
 752 (progn
 753   (setf (test-result-property *test-result* :if-exists) :supersede)
 754   (test-result-report *test-result* #p"/tmp/report.save" :save))
 755
 756 (defun ensure-symbol (thing)
 757   (etypecase thing
 758     (symbol thing)
 759     (string (intern thing))))
 760
 761 ;;;;
 762
 763 (defun write-log-header (stream result args)
 764   (append-to-report (out stream)
 765     (format out "~&\(")
 766     (out :results-for (results-for result))
 767     (out :arguments (make-printable args))
 768     (out :features (copy-list *features*))
 769     (out :datetime (get-universal-time))
 770     (loop for hook in *log-header-hooks* do
 771          (funcall hook out result))
 772     (format out "~&\)~%")))
 773
 774 (defun write-log-footer (stream result)
 775   (append-to-report (out stream)
 776     (format out "~&\(")
 777     (out :test-case-count (length (tests-run result)))
 778     (out :test-suite-count (length (suites-run result)))
 779     (out :failure-count (length (failures result)))
 780     (out :error-count (length (errors result)))
 781     (out :expected-failure-count (length (expected-failures result)))
 782     (out :expected-error-count (length (expected-errors result)))
 783     (out :skipped-testsuites-count (length (skipped-testsuites result)))
 784     (out :skipped-test-cases-count (length (skipped-test-cases result)))
 785     (out :start-time-universal (start-time-universal result))
 786     (when (slot-boundp result 'end-time-universal)
 787       (out :end-time-universal (end-time-universal result)))
 788     (out :errors (collect-testsuite-summary-for-log result :errors))
 789     (out :failures (collect-testsuite-summary-for-log result :failures))
 790     (out :expected-errors
 791          (collect-testsuite-summary-for-log result :expected-errors))
 792     (out :expected-failures
 793          (collect-testsuite-summary-for-log result :expected-failures))
 794     (out :skipped-testsuites
 795          (collect-testsuite-summary-for-log result :skipped-testsuites))
 796     (out :skipped-test-cases
 797          (collect-testsuite-summary-for-log result :skipped-test-cases))
 798     (loop for hook in *log-footer-hooks* do
 799          (funcall hook out result))
 800     (format out "~&\)~%")))
 801
 802 (defmethod write-log-test :around
 803     (format suite-name test-case-name data &key stream)
 804   (append-to-report (out stream)
 805     (call-next-method format suite-name test-case-name data :stream out)))
 806
 807 (defmethod write-log-test (format suite-name test-case-name data
 808                            &key (stream *standard-output*))
 809   (write-log-test-start format suite-name test-case-name data
 810                         :stream stream)
 811   (write-log-test-end format suite-name test-case-name
 812                         :stream stream))
 813
 814 (defmethod write-log-test-start
 815     ((format (eql :save)) suite-name test-case-name
 816      &key (stream *standard-output*))
 817   (when stream
 818     (append-to-report (out-stream stream)
 819       (format out-stream "~&\(~%")
 820       (out :suite (encode-symbol suite-name))
 821       (out :name (encode-symbol test-case-name))
 822       (out :start-time (get-test-real-time)))))
 823
 824 (defmethod write-log-test-end
 825     ((format (eql :save)) suite-name test-case-name data
 826      &key (stream *standard-output*))
 827   (declare (ignore suite-name test-case-name))
 828   (when stream
 829     (append-to-report (out-stream stream)
 830       (labels ((write-datum (name &key (source data))
 831                  (let* ((key (form-keyword name))
 832                         (value (getf source key)))
 833                    (out key value))))
 834         (write-datum 'end-time)
 835         (write-datum 'result)
 836         (write-datum 'seconds)
 837         (write-datum 'conses)
 838         (let ((properties (getf data :properties)))
 839           (loop for key in properties by #'cddr
 840              for value in (rest properties) by #'cddr do
 841              (out key value)))
 842         (cond ((getf data :problem)
 843                (let ((problem (getf data :problem)))
 844                  (out :problem-kind (test-problem-kind problem))
 845                  (out :problem-step (test-step problem))
 846                  (out :problem-condition
 847                       (let ((*print-readably* nil))
 848                         (format nil "~s" (test-condition problem))))
 849                  (out :problem-condition-description
 850                       (format nil "~a" (test-condition problem)))
 851                  (when (slot-exists-p problem 'backtrace)
 852                    (out :problem-backtrace (backtrace problem)))))
 853               (t
 854                (out :result t)))
 855         (loop for hook in *log-detail-hooks* do
 856              (funcall hook out-stream data))
 857         (format out-stream "\)~%")))))
 858
 859 ;;;;
 860
 861 (defun encode-symbol (symbol)
 862   (cons (symbol-name symbol)
 863         (package-name (symbol-package symbol))))
 864
 865 (defmethod brief-problem-output ((glitch testsuite-problem-mixin))
 866   (if (test-method glitch)
 867       (list (encode-symbol (testsuite glitch))
 868             (encode-symbol (test-method glitch)))
 869       (encode-symbol (testsuite glitch))))
 870
 871 (defmethod brief-problem-output ((glitch test-configuration-problem-mixin))
 872   (test-problem-message glitch))
 873
 874 (defun collect-testsuite-summary-for-log (result kind)
 875   (let ((list (slot-value result (intern (symbol-name kind)
 876                                          (find-package :lift)))))
 877     (mapcar #'brief-problem-output list)))
 878
 879 #+(or)
 880 (collect-testsuite-summary-for-log lift:*test-result* :skipped-testsuites)
 881
 882 ;;;;;
 883
 884 #+allegro
 885 (defun with-profile-report-fn
 886     (name style fn body &key
 887      (log-name *log-path*)
 888      (count-calls-p *count-calls-p*)
 889      (timeout nil)
 890      (destination nil destination-supplied?))
 891   (assert (member style '(nil :time :space :count-only)))
 892   (when style
 893     (cancel-current-profile :force? t))
 894   (let* ((seconds 0.0) (conses 0)
 895          error
 896          results
 897          report-string
 898          (profile-fn (make-profiled-function fn)))
 899     (unwind-protect
 900          (multiple-value-bind (result measures errorp)
 901              (while-measuring (t measure-seconds measure-space)
 902                (handler-bind
 903                    ((timeout-error (lambda (_) (declare (ignore _))))
 904                     (error (lambda (c) (error c))))
 905                  (with-timeout (timeout)
 906                    (funcall profile-fn style count-calls-p))))
 907            (setf seconds (first measures) conses (second measures)
 908                  results result error errorp))
 909       ;; cleanup / ensure we get report
 910       (when (and style (> (current-profile-sample-count) 0))
 911         (generate-profile-log-entry log-name name seconds conses results error)
 912         (let ((pathname (if destination-supplied?
 913                             destination
 914                             (unique-filename
 915                              (merge-pathnames
 916                               (make-pathname
 917                                :type "prof"
 918                                :name (format nil "~a-~a-" name style))
 919                               log-name)))))
 920           (setf report-string
 921                 (write-profile-report pathname name style body
 922                                       seconds conses error count-calls-p)))))
 923     (values results report-string)))
 924
 925 (defun write-profile-report (pathname name style body seconds conses
 926                              error count-calls-p)
 927   (format t "~&Profiling output being sent to ~a" pathname)
 928   (let (report-string
 929         (output-stream (cond ((null pathname)
 930                               (make-string-output-stream))
 931                              ((eq pathname t)
 932                               *standard-output*)
 933                              (t
 934                               (open pathname
 935                                     :direction :output
 936                                     :if-does-not-exist :create
 937                                     :if-exists :append)))))
 938     (unwind-protect
 939          (progn
 940            (format output-stream "~&Profile data for ~a" name)
 941            (format output-stream "~&Date: ~a" (date-stamp :include-time? t))
 942            (summarize-test-environment nil output-stream nil)
 943            (format output-stream "~&  Total time: ~,2F; Total space: ~:d \(~:*~d\)"
 944                    seconds conses)
 945            (format output-stream "~%~%")
 946            (when error
 947              (format output-stream "~&Error occurred during profiling: ~a~%~%" error))
 948            (let ((*standard-output* output-stream))
 949              (when *current-test*
 950                (write-profile-information *current-test*)))
 951            (when body
 952              (format output-stream "~&Profiling: ~%")
 953              (let ((*print-length* 10)
 954                    (*print-level* 10))
 955                (dolist (form body)
 956                  (pprint form output-stream)))
 957              (format output-stream "~%~%"))
 958            (when (or (eq :time style)
 959                      (eq :space style))
 960              (show-flat-profile output-stream)
 961              (show-call-graph output-stream)
 962              (when count-calls-p
 963                (show-call-counts output-stream)))
 964            #+allegro
 965            (when *functions-to-profile*
 966              (loop for thing in *functions-to-profile* do
 967                   (let ((*standard-output* output-stream)
 968                         (*print-readably* nil))
 969                     (handler-case
 970                         (cond ((thing-names-generic-function-p thing)
 971                                (format output-stream "~%~%Disassemble generic-function ~s:~%"
 972                                        thing)
 973                                (prof:disassemble-profile thing)
 974                                (mapc
 975                                 (lambda (m)
 976                                   (format t "~2%~a~%"
 977                                           (make-string 60 :initial-element #\-))
 978                                   (format t "~&Method: ~a~2%" m)
 979                                   (prof:disassemble-profile (clos:method-function m)))
 980                                 (clos:generic-function-methods
 981                                  (symbol-function thing))))
 982                               (t
 983                                (format output-stream "~%~%Disassemble function ~s:~%"
 984                                        thing)
 985                                (prof:disassemble-profile thing)))
 986                       (error (c)
 987                         (format
 988                          output-stream "~2%Error ~a while trying to disassemble-profile ~s~2%"
 989                          c thing)))))))
 990       (cond ((null pathname)
 991              (setf report-string (get-output-stream-string output-stream)))
 992             ((not (eq pathname t))
 993              (when output-stream (close output-stream)))))
 994     report-string))
 995
 996 ;; stolen from cl-markdown and modified
 997 (defun thing-names-generic-function-p (thing)
 998   (and (symbolp thing)
 999        (fboundp thing)
1000        (typep (symbol-function thing) 'standard-generic-function)))
1001
1002 (defmethod save-configuration-file ((result test-result) destination)
1003   (with-open-file (stream destination
1004                           :direction :output
1005                           :if-exists :supersede
1006                           :if-does-not-exist :create)
1007     (html-header
1008      stream
1009      "test configuration file"
1010      (test-result-property result :style-sheet))
1011     (format stream "~&<h1>Test configuration</h1>~%")
1012     (format stream "~&<pre>~%")
1013     (save-configuration-file (results-for result) stream)
1014     (format stream "~&</pre>~%")
1015     (html-footer stream)))
1016
1017 (defmethod save-configuration-file ((pathname t) stream)
1018     (with-open-file (*current-configuration-stream* pathname
1019                                                     :direction :input
1020                                                     :if-does-not-exist :error)
1021       (let ((form nil))
1022         (loop while (not (eq (setf form (read *current-configuration-stream*
1023                                               nil :eof nil)) :eof))
1024            do
1025            ;; special handling for include
1026            (cond ((and (consp form) (eql (first form) :include))
1027                   (destructuring-bind (name &rest args)
1028                       form
1029                     (declare (ignore name))
1030                     (format stream "~&~%;; begin - include ~a~%"
1031                             (first args))
1032                     (save-configuration-file
1033                      (merge-pathnames (ensure-string (first args))
1034                                       *current-configuration-stream*)
1035                      stream)
1036                     (format stream "~&;; end - include ~a~%~%"
1037                             (first args))))
1038                  (t
1039                   (print form stream)))))))
1040
1041 (defmethod extra-info (kind suite name)
1042   (declare (ignore kind suite name))
1043   nil)
1044
1045 (defmethod extra-info ((kind (eql :expected-errors)) suite name)
1046   (test-case-option suite name :expected-error))
1047
1048 (defmethod extra-info ((kind (eql :expected-failures)) suite name)
1049   (test-case-option suite name :expected-failure))
1050
1051 (defun build-issues-report (result kind stream)
1052   (format stream
1053           "~&<h2><a href=\"~a.html\">Test ~a summary</a></h2>~%"
1054           kind kind)
1055   (with-open-file (out (merge-pathnames (format nil "~a.html" kind)
1056                                         stream)
1057                        :direction :output
1058                        :if-exists :supersede
1059                        :if-does-not-exist :create)
1060     (html-header
1061      out
1062      (format nil "~a summary" kind)
1063      (test-result-property result :style-sheet))
1064     (format out "~&<h1>~a summary</h1>~%" kind)
1065     (loop for (string . issues) in (build-issues-list result kind) do
1066        (format out "~%~%<h2>~a</h2>~%~%" string)
1067        (format out "~&<ul>~%")
1068        (loop for issue in issues do
1069             (destructuring-bind (_1 suite name _2) issue
1070               (declare (ignore _1 _2))
1071               (format out "~&<li><span>~a</span> <a href=\"~a\"><span>~a</span></a>~@[, <span>~a</span>~]</li>~&"
1072                       suite (details-link suite name) name
1073                       (extra-info kind suite name))))
1074        (format out "~&</ul>~%"))
1075     (html-footer out)))
1076
1077 (defun test-case-skipped-p (result suite-name case-name)
1078   (or (find suite-name (skipped-testsuites result))
1079       (find-if (lambda (couplet)
1080                  (and (eq (first couplet) suite-name)
1081                       (eq (second couplet) case-name)))
1082                (skipped-test-cases result))))
1083
1084 ;;;; brief
1085
1086 (defmethod start-report-output (result stream (format (eql :brief)))
1087   (format stream "~&Test ~a"
1088           (or (test-result-property result :title) "report")))
1089
1090 (defmethod summarize-test-result (result stream (format (eql :brief)))
1091   (format stream"~&Test results for: ~a~%"
1092           (results-for result)))
1093
1094 (defmethod summarize-test-environment (result stream (format (eql :brief)))
1095   (format stream "~&Lisp: ~a" (lisp-version-string))
1096   (format stream ", Machine: ~a ~a ~a, Date: ~a"
1097           (machine-type) (machine-version) (machine-instance)
1098           (date-stamp :include-time? t))
1099   (let ((complete-success? (and (null (errors result))
1100                                 (null (failures result)))))
1101     (cond (complete-success?
1102            (format stream"~&~A Successful test~:P"
1103                    (length (tests-run result))))
1104           (t
1105            (format stream "~&~A Test~:P~[~:;, ~:*~A Failure~:P~]~[~:;, ~:*~A Error~:P~]"
1106                    (length (tests-run result))
1107                    (length (failures result))
1108                    (length (errors result)))))
1109     (when (expected-errors result)
1110       (format stream ", ~a expected error~:p" (length (expected-errors result))))
1111     (when (expected-failures result)
1112       (format stream ", ~a expected failure~:p"
1113               (length (expected-failures result))))
1114     (when (skipped-test-cases result)
1115       (format stream ", ~a skipped case~:p"
1116               (length (skipped-test-cases result))))))
1117
1118 (defmethod summarize-test-problems (result stream  (format (eql :brief)))
1119   (loop for (tag cases) in
1120        `((:skipped ,(skipped-test-cases result))
1121          (:expected-failures ,(expected-failures result))
1122          (:expected-errors ,(expected-errors result))
1123          (:failures ,(failures result))
1124          (:errors  ,(errors result))) do
1125        (when cases
1126          (format stream "~&~a~%" tag)
1127          (report-tests-by-suite
1128           format
1129           (mapcar #'problem-summarization cases)
1130           stream tag))))
1131
1132 (defmethod report-test-suite-by-suite
1133     ((format (eql :brief)) stream remaining current-suite suite kind)
1134   (declare (ignore stream remaining current-suite suite kind))
1135   )
1136
1137 (defmethod report-test-case-by-suite
1138     ((format (eql :brief)) stream suite test-name datum kind)
1139   (declare (ignore datum kind))
1140   (format stream "~&  :suite ' ~a :name ' ~a~%" suite test-name))
1141
1142 (defmethod report-test-case-by-suite
1143     ((format (eql :brief)) stream (suite (eql :configuration)) test-name datum kind)
1144   (declare (ignore test-name kind))
1145   (let ((problem (getf datum :problem)))
1146     (format stream "~&  ~20a: ~a~%"
1147             (test-problem-kind problem)
1148             (test-problem-message problem))))
1149
1150 (defmethod finish-report-tests-by-suite
1151     ((format (eql :brief)) stream current-suite)
1152   (declare (ignore stream current-suite))
1153   )
1154
1155 ;;;
1156
1157 (defmethod result-summary-tag ((problem t) (style (eql :brief)))
1158   ".")
1159
1160 (defmethod result-summary-tag ((problem test-problem-mixin) (style (eql :brief)))
1161   "P")
1162
1163 (defmethod result-summary-tag ((problem test-failure-mixin) (style (eql :brief)))
1164   "F")
1165
1166 (defmethod result-summary-tag ((problem test-error-mixin) (style (eql :brief)))
1167   "E")
1168
1169 (defmethod result-summary-tag ((problem testsuite-serious-condition) (style (eql :brief)))
1170   "X")
1171
1172 (defmethod result-summary-tag ((problem test-serious-condition) (style (eql :brief)))
1173   "x")
1174
1175 (defmethod result-summary-tag ((problem test-expected-failure) (style (eql :brief)))
1176   "f")
1177
1178 (defmethod result-summary-tag ((problem test-expected-error) (style (eql :brief)))
1179   "e")
1180
1181 ;;
1182
1183 (defmethod result-summary-tag ((problem t) (style t))
1184   "Pass")
1185
1186 (defmethod result-summary-tag ((problem test-problem-mixin) (style t))
1187   "Problem")
1188
1189 (defmethod result-summary-tag ((problem test-failure-mixin) (style t))
1190   "Fail")
1191
1192 (defmethod result-summary-tag ((problem test-error-mixin) (style t))
1193   "Error")
1194
1195 (defmethod result-summary-tag ((problem testsuite-serious-condition) (style t))
1196   "Serious error in test suite")
1197
1198 (defmethod result-summary-tag ((problem test-serious-condition) (style t))
1199   "Serious error in test")
1200
1201 (defmethod result-summary-tag ((problem test-expected-failure) (style t))
1202   "Expected failure")
1203
1204 (defmethod result-summary-tag ((problem test-expected-error) (style t))
1205   "Expected error")