4 ;; full output for all tests on separate pages per suite? whatever.
8 For
*standard-input
*: an input stream
10 For
*error-output
*, *standard-output
*, and
*trace-output
*: an output stream.
12 For
*debug-io
*, *query-io
*: a bidirectional stream.
17 (setf (test-result-property *test-result
* :style-sheet
) "test-style.css")
18 (setf (test-result-property *test-result
* :title
) "Test Results X")
19 (setf (test-result-property *test-result
* :if-exists
) :supersede
)
20 (test-result-report *test-result
* #p
"/tmp/report.html" :html
))
23 (setf (test-result-property *test-result
* :style-sheet
) "test-style.css")
24 (setf (test-result-property *test-result
* :title
) "Merge LUBM 8000")
25 (setf (test-result-property *test-result
* :if-exists
) :error
)
26 (test-result-report *test-result
* #p
"/tmp/report.sav" :save
))
28 (run-tests :suite
'(lift-test test-cursors
))
30 (run-tests :suite
'lift-test-ensure
)
32 (test-result-property *test-result
* :title
)
36 in start-test
(result test name
)
37 (push `(,name
,(current-values test
)) (tests-run result
))
39 if fails
/ errors
, will get problem appended
41 current-values comes from prototype stuff
43 use property-list format
54 do-testing with testsuite-run
60 <fn
> (= testsuite-run
)
67 start-test - push
, name
, value onto test-placeholder
*
71 end-test - setf
:end-time
*
72 (add test-data to tests-run of result
)
75 foreach method in suite
, run-test-internal
76 if children
, foreach direct-subclass
, run-tests-internal
79 do-testing with run-test-internal
82 ;; when it doubt, add a special
83 (defvar *report-environment
* nil
84 "Used internally by LIFT reports.")
86 (defun make-report-environment ()
89 ;; env variables need to be part saved in result
91 (defgeneric test-result-report
(result output format
92 &key package
&allow-other-keys
)
95 (defgeneric html-report-pathname
(pathname))
97 (defmethod html-report-pathname (pathname)
99 (make-pathname :name
(pathname-name pathname
)
101 :defaults
(namestring (unique-directory pathname
)))
104 (defmethod test-result-report :around
105 (result output
(format (eql :html
))
107 &key
&allow-other-keys
)
108 (let ((output (html-report-pathname output
)))
109 (ensure-directories-exist output
)
110 (apply #'call-next-method result output format args
)))
112 (defmethod test-result-report (result output format
114 &key
(package *package
*) &allow-other-keys
)
115 (let ((*report-environment
* (make-report-environment))
116 (*package
* (or (find-package package
) *package
*)))
117 (cond ((or (stringp output
)
119 (with-open-file (stream
122 :if-does-not-exist
:create
123 :if-exists
(or (test-result-property
126 (%test-result-report-stream result stream format
)))
128 (%test-result-report-stream result output format
))
130 (error "Don't know how to send a report to ~s" output
)))))
132 (defun %test-result-report-stream
(result stream format
)
133 (start-report-output result stream format
)
134 (summarize-test-result result stream format
)
135 (summarize-test-environment result stream format
)
136 (when (or (failures result
) (errors result
)
137 (expected-failures result
) (expected-errors result
))
138 (summarize-test-problems result stream format
))
139 (summarize-tests-run result stream format
)
140 (end-report-output result stream format
)
141 (generate-detailed-reports result stream format
))
143 (defmethod start-report-output (result stream format
)
144 (declare (ignore result stream format
))
147 (defmethod summarize-test-result (result stream format
)
148 (declare (ignore format
))
149 (format stream
"~&Test results for: ~a~%"
150 (results-for result
))
151 (let ((complete-success?
(and (null (errors result
))
152 (null (failures result
)))))
153 (cond (complete-success?
154 (format stream
"~&~A Successful test~:P~%"
155 (length (tests-run result
))))
157 (format stream
"~&~A Test~:P~[~:;, ~:*~A Failure~:P~]~[~:;, ~:*~A Error~:P~].~%"
158 (length (tests-run result
))
159 (length (failures result
))
160 (length (errors result
)))))))
162 (defmethod summarize-test-environment (result stream format
)
163 (declare (ignore result stream format
))
166 (defmethod summarize-test-problems (result stream format
)
167 (declare (ignore result stream format
))
170 (defmethod generate-detailed-reports (result stream format
)
171 (declare (ignore result stream format
))
174 (defmethod summarize-tests-run (result stream format
)
175 (declare (ignore result stream format
)))
177 (defmethod end-report-output (result stream format
)
178 (declare (ignore result stream format
))
182 (defun summarize-test-environment (result stream format
)
183 (loop for symbol in
(sort `((*lift-dribble-pathname
*)
184 (*lift-debug-output
* interpret-lift-stream
)
185 (*lift-standard-output
* interpret-lift-stream
)
186 (*test-break-on-errors?
*)
187 (*test-do-children?
*)
188 (*lift-equality-test
*)
189 (*test-print-length
*)
191 (*lift-if-dribble-exists
*))
192 'string-lessp
:key
'first
) do
197 ;; some cruft stolen from cl-markdown
199 '((name (:author
:description
:copyright
:keywords
:date
))
200 (http-equiv (:refresh
:expires
))))
202 (defmethod start-report-output (result stream
(format (eql :html
)))
205 (test-result-property result
:title
)
206 (test-result-property result
:style-sheet
)))
208 (defmethod html-header (stream title style-sheet
)
209 (format stream
"~&<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.0 Strict//EN\"
210 \"http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd\">")
211 (format stream
"~&<html>~&<head>")
213 (format stream
"~&<title>~a</title>" title
))
215 (unless (search ".css" style-sheet
)
216 (setf style-sheet
(concatenate 'string style-sheet
".css")))
217 (format stream
"~&<link type='text/css' href='~a' rel='stylesheet' />"
219 (format stream
"~&</head>~&<body>"))
221 (defmethod summarize-test-result (result stream
(format (eql :html
)))
222 (format stream
"~&<div id=\"summary\">")
223 (format stream
"~&<h1>Test results for: ~a</h1>~%"
224 (results-for result
))
225 (let ((complete-success?
(and (null (errors result
))
226 (null (failures result
)))))
227 (cond (complete-success?
228 (format stream
"~&<h2>~A Successful test~:P</h2>~%"
229 (length (tests-run result
))))
232 "~&<h2>~A Test~:P~[~:;, ~:*~A Failure~:P~]~[~:;, ~:*~A Error~:P~].</h2>~%"
233 (length (tests-run result
))
234 (length (failures result
))
235 (length (errors result
)))))
237 (when (or (expected-errors result
) (expected-failures result
))
238 (format stream
"~&<h3>~[~:;~:*Expected failure~p: ~:*~a~]~[~:;, ~]~[~:;~:*Expected error~p: ~:*~a~]</h3>~%"
239 (length (expected-failures result
))
240 ;; zero if only one or the other (so we don't need a separator...)
241 (* (length (expected-failures result
))
242 (length (expected-errors result
)))
243 (length (expected-errors result
))))
245 (when (and (slot-boundp result
'end-time-universal
)
246 (numberp (end-time-universal result
))
247 (numberp (start-time-universal result
)))
248 (format stream
"~&<h3>Testing took: ~:d seconds</h3>"
249 (- (end-time-universal result
)
250 (start-time-universal result
))))
252 (when (and (numberp (real-end-time result
))
253 (numberp (real-start-time result
)))
254 (format stream
"~&Time: ~,2f real-time"
255 (/ (- (real-end-time result
) (real-start-time result
))
256 internal-time-units-per-second
))))
257 (format stream
"~&</div>"))
259 (defmethod summarize-test-environment (result stream
(format (eql :html
)))
260 (declare (ignore result
))
261 (format stream
"~&<div id=\"environment\">")
263 (format stream
"~&</div>"))
265 (defmethod summarize-test-problems (result stream
(format (eql :html
)))
266 (format stream
"~&<div id=\"problem-summary\">")
267 (format stream
"~&<h2>Problem Summary:</h2>")
268 (when (failures result
)
269 (summarize-test-problems-of-type
270 (failures result
) stream
"failure-summary" "Failures"))
271 (when (errors result
)
272 (summarize-test-problems-of-type
273 (errors result
) stream
"error-summary" "Errors"))
274 (when (expected-failures result
)
275 (summarize-test-problems-of-type
276 (expected-failures result
)
277 stream
"expected-failure-summary" "Expected Failures"))
278 (when (expected-errors result
)
279 (summarize-test-problems-of-type
280 (expected-errors result
) stream
"expected-failure-summary"
282 (format stream
"~&</div>"))
284 (defmethod summarize-test-problems-of-type
285 (problems stream id heading
)
286 (format stream
"~&<div id=\"id\">" id
)
287 (format stream
"~&<h3>~a</h3>" heading
)
288 (report-tests-by-suite
289 (mapcar (lambda (problem)
290 `(,(type-of (testsuite problem
))
291 ,(test-method problem
)
292 (:problem
,problem
)))
294 (format stream
"~&</div>"))
296 (defmethod summarize-tests-run (result stream
(format (eql :html
)))
297 (format stream
"~&<div id=\"results\">")
298 (format stream
"~&<h2>Tests Run:</h2>")
299 (report-tests-by-suite (tests-run result
) stream
)
300 (format stream
"~&</div>"))
302 (defun report-tests-by-suite (tests stream
)
303 (let ((current-suite nil
))
304 (loop for rest
= (sort
305 ;; FIXME - this is a hack intended to show tests
306 ;; in the order they were run (even if it works, it's
307 ;; bound to be fragile)
309 #+(or) (nreverse (copy-list tests
))
310 'string-lessp
:key
'first
) then
(rest rest
)
312 for
(suite test-name datum
) = (first rest
) do
313 (unless (eq current-suite suite
)
315 (format stream
"</div>"))
316 (setf current-suite suite
)
317 (format stream
"~&<div class=\"testsuite\">")
318 (let* ((this-suite-end (or
321 (not (eq current-suite
(first datum
))))
324 (error-count (count-if
326 (and (getf (third datum
) :problem
)
327 (typep (getf (third datum
) :problem
)
330 :end this-suite-end
))
331 (failure-count (count-if
333 (and (getf (third datum
) :problem
)
334 (typep (getf (third datum
) :problem
)
337 :end this-suite-end
))
338 (extra-class (cond ((and (= error-count
0) (= failure-count
0))
339 'testsuite-all-passed
)
341 'testsuite-some-errors
)
343 'testsuite-some-failures
))))
344 (format stream
"~&<div class=\"testsuite-title\"><table class=\"~a\"><tr><td>~a</td>" extra-class suite
)
345 (format stream
"<td class=\"testsuite-test-count\">~:d test~:p</td>"
347 (format stream
"<td class=\"testsuite-summary\">")
348 (cond ((and (= error-count
0) (= failure-count
0))
349 (format stream
"all passed"))
351 (format stream
"~[~:;~:*~:d failure~:p~]"
353 (when (and (> error-count
0) (> failure-count
0))
354 (format stream
", "))
355 (format stream
"~[~:;~:*~a error~:p~]"
357 (format stream
"</td></tr></table>")
358 (format stream
"</div>")))
359 (format stream
"~&<div class=\"test-case\">")
360 (let ((problem (getf datum
:problem
)))
361 (cond ((typep problem
'test-failure
)
362 (format stream
"~&<span class=\"test-name\"><a href=\"~a\" title=\"details\">~a</a></span>"
363 (details-link stream suite test-name
)
366 "~&<span class=\"test-failure\">failure</span>" ))
367 ((typep problem
'test-error
)
368 (format stream
"~&<span class=\"test-name\"><a href=\"~a\" title=\"details\">~a [during ~a]</a></span>"
369 (details-link stream suite test-name
)
372 (format stream
"~&<span class=\"test-error\">error</span>"))
374 (format stream
"~&<span class=\"test-name\">~a</span>"
376 (let ((seconds (getf datum
:seconds
))
377 (conses (getf datum
:conses
)))
379 (format stream
"<span class=\"test-time\">~,3f</span>"
382 (format stream
"<span class=\"test-space\">~:d</span>"
384 (format stream
"~&</div>")))
386 (format stream
"</div>"))))
388 (defun get-details-links-table ()
389 (let ((hash (getf *report-environment
* :details-links
)))
391 (setf (getf *report-environment
* :details-links
)
392 (make-hash-table :test
'equal
)))))
395 (get-details-links-table)
397 (defun details-link (stream suite name
)
398 (declare (ignore stream
))
399 (let* ((hash (get-details-links-table)))
400 (or (gethash (cons suite name
) hash
)
402 (incf (getf *report-environment
* :details-links-count
0))
403 (setf (gethash (cons suite name
) hash
)
405 :name
(format nil
"details-~a"
406 (getf *report-environment
* :details-links-count
))
409 (defmethod end-report-output (result stream
(format (eql :html
)))
410 (let ((style-sheet (test-result-property result
:style-sheet
)))
413 (copy-file (asdf:system-relative-pathname
414 'lift
"resources/test-style.css")
416 :name
(pathname-name style-sheet
)
417 :type
(pathname-type style-sheet
)
418 :defaults
(pathname stream
))
419 :if-exists
:supersede
))))
420 (html-footer stream
))
422 (defun html-footer (stream)
423 (format stream
"<div id=\"footer\">")
424 (format stream
"~&generated on ~a"
426 (excl:locale-print-time
428 :fmt
"%B %d, %Y %T GMT%z" :stream nil
)
430 (get-universal-time))
431 (format stream
"</div>")
432 (format stream
"~&</body></html>"))
434 (defmethod generate-detailed-reports (result stream
(format (eql :html
)))
435 (loop for
(suite test-name datum
) in
(tests-run result
)
436 when
(getf datum
:problem
) do
437 (let ((output-pathname (merge-pathnames
438 (details-link stream suite test-name
)
440 (ensure-directories-exist output-pathname
)
441 (let ((*print-right-margin
* 64))
442 (with-open-file (out output-pathname
444 :if-does-not-exist
:create
445 :if-exists
:supersede
)
448 (format nil
"Test ~a details | ~a"
449 test-name
(test-result-property result
:title
))
450 (test-result-property result
:style-sheet
))
451 (format out
"~&<h2>Test ~a details</h2>" test-name
)
452 (format out
"~&<a href=\"~a\">Back</a>"
453 (namestring (make-pathname :name
(pathname-name stream
)
454 :type
(pathname-type stream
))))
455 (format out
"~&<pre>")
458 (with-output-to-string (s)
459 (print-test-problem "" (getf datum
:problem
) s t
))
460 :width
(test-result-property
461 *test-result
* :print-width
60)))
462 (format out
"~&</pre>")
463 (html-footer out
))))))
466 (defmethod summarize-test-environment (result stream format
)
467 (loop for symbol in
(sort `((*lift-dribble-pathname
*)
468 (*lift-debug-output
* interpret-lift-stream
)
469 (*lift-standard-output
* interpret-lift-stream
)
470 (*test-break-on-errors?
*)
471 (*test-do-children?
*)
472 (*lift-equality-test
*)
473 (*test-print-length
*)
475 (*lift-if-dribble-exists
*))
476 'string-lessp
:key
'first
) do
480 (defun wrap-encode-pre (string &key
(width 80))
481 ;; Copied from CL-Markdown
482 ;; Copied from HTML-Encode
483 ;;?? this is very consy
485 (declare (simple-string string
))
486 (let ((output (make-array (truncate (length string
) 2/3)
487 :element-type
'character
491 (with-output-to-string (out output
)
492 (loop for char across string
494 ((#\
&) (incf column
) (write-string "&" out
))
495 ((#\
<) (incf column
) (write-string "<" out
))
496 ((#\
>) (incf column
) (write-string ">" out
))
497 ((#\Tab
#\Space
#\Return
#\Newline
)
498 (cond ((or (>= column width
)
499 (char= char
#\Return
)
500 (char= char
#\Newline
))
503 ((char= char
#\Space
)
505 (write-char char out
))
508 (write-string " " out
))))
509 (t (incf column
) (write-char char out
)))))
510 (coerce output
'simple-string
)))
514 (defmethod summarize-test-result (result stream
(format (eql :describe
)))
515 (describe result stream
))
517 (defmethod summarize-tests-run (result stream
(format (eql :describe
)))
518 (declare (ignore result stream
))
523 (defmethod summarize-test-result (result stream
(format (eql :save
)))
524 (flet ((add-property (name)
525 (when (slot-boundp result name
)
526 (format stream
"~&\(~s ~a\)"
527 (intern (symbol-name name
) :keyword
)
528 (slot-value result name
)))))
529 (format stream
"\(~%")
530 (add-property 'results-for
)
531 (format stream
"~&\(:date-time ~a\)" (get-universal-time))
532 (add-property 'real-start-time-universal
)
533 (add-property 'start-time-universal
)
534 (add-property 'end-time-universal
)
535 (add-property 'real-end-time-universal
)
536 (format stream
"~&\(:tests-run ")
537 (loop for
(suite name data
) in
538 ;; FIXME - this is a hack intended to show tests
539 ;; in the order they were run (even if it works, it's
540 ;; bound to be fragile)
541 (copy-list (tests-run result
)) do
542 (summarize-single-test format suite name data
:stream stream
))
543 (format stream
"~&\)")
544 (format stream
"~&\)")))
548 (setf (test-result-property *test-result
* :if-exists
) :supersede
)
549 (test-result-report *test-result
* #p
"/tmp/report.save" :save
))
551 (defun symbol->turtle
(symbol)
554 (loop for char across
(string-downcase (symbol-name symbol
))
555 when
(char= char
#\-
) do
(setf upcase? t
)
556 else collect
(if upcase?
557 (prog1 (char-upcase char
)
562 (defun turtlefy (thing)
565 (pathname (namestring thing
))
568 (integer (format nil
"\"~a\"^^xsd:integer" thing
))
569 (double-float (format nil
"\"~f\"^^xsd:double" thing
))
570 (single-float (format nil
"\"~f\"^^xsd:single" thing
))))
571 (symbol (symbol-name thing
))
572 (t (format nil
"\"~a\"" thing
))))
574 (defun ensure-symbol (thing)
577 (string (intern thing
))))
580 (symbol->turtle
'real-start-time-universal
)
582 (defun date->turtle
(&key
(datetime (get-universal-time)) (include-time? nil
))
584 (second minute hour day month year day-of-the-week
)
585 (decode-universal-time datetime
)
586 (declare (ignore day-of-the-week
))
587 (let ((date-part (format nil
"~d-~2,'0d-~2,'0d" year month day
))
588 (time-part (and include-time?
589 (format nil
"T-~2,'0d:~2,'0d:~2,'0d"
590 hour minute second
)))
591 (data-type (if include-time?
592 "xsd:dateTime" "xsd:date")))
593 (concatenate 'string
"\"" date-part time-part
"\"" "^^" data-type
))))
595 ;; http://www.dajobe.org/2004/01/turtle/
596 (defmethod summarize-test-result (result stream
(format (eql :turtle
)))
597 (labels ((convert-value (value type
)
599 (string (turtlefy value
))
600 (symbol (ensure-symbol value
))
601 (date (date->turtle
:datetime value
))
602 (dateTime (date->turtle
:datetime value
:include-time? t
))))
603 (add-property (name type
)
604 (let ((value (slot-value result name
)))
606 (format stream
"~&:~a ~s ;"
607 (symbol->turtle name
)
608 (convert-value value type
))))))
610 "~&@prefix xsd: <http://www.w3.org/2001/XMLSchema#> .~%")
612 "~&@prefix : <http://www.metabang.com/2007/04/lift#> .~%")
613 (format stream
"\[~%")
614 (add-property 'results-for
'string
)
615 (add-property 'real-start-time
'dateTime
)
616 (add-property 'start-time
'dateTime
)
617 (add-property 'end-time
'dateTime
)
618 (add-property 'real-end-time
'dateTime
)
619 (format stream
"~&\:testsRun (")
620 (loop for
(suite name data
) in
621 ;; FIXME - this is a hack intended to show tests
622 ;; in the order they were run (even if it works, it's
623 ;; bound to be fragile)
624 (copy-list (tests-run result
))
626 (nreverse (copy-list (tests-run result
))) do
627 (labels ((write-datum (name type
&key
(source data
))
628 (let* ((key (intern (symbol-name name
) :keyword
))
629 (value (getf source key
)))
631 (format stream
"~& :~a ~a ;"
632 (symbol->turtle name
)
633 (convert-value value type
)))))
635 (write-datum name type
:source
(getf data
:properties
))))
636 (format stream
"~&\[ ")
637 (format stream
":testSuite ~s ;" (symbol-name suite
))
638 (format stream
"~& :testName ~s ;" (symbol-name name
))
639 ;; FIXME - we could make these extensible
640 (write-datum 'start-time
'dateTime
)
641 (write-datum 'end-time
'dateTime
)
642 (write-datum 'result
'string
)
643 (write-datum 'seconds
'string
)
644 (write-datum 'conses
'string
)
645 (loop for stuff in
(getf data
:properties
) by
#'cddr do
646 (prop stuff
'string
))
647 (format stream
" \]")))
648 (format stream
" ) ~&\] . ")))
652 (setf (test-result-property *test-result
* :if-exists
) :supersede
)
653 (test-result-report *test-result
* #p
"/tmp/report.n3" :turtle
))
657 (defmacro append-to-report
((var output-to
) &body body
)
658 (let ((gclosep (gensym "closep"))
659 (gstream (gensym "stream")))
660 `(let* ((,gclosep nil
)
661 (,gstream
,output-to
)
662 (,var
(etypecase ,gstream
664 ((or pathname string
)
667 :if-does-not-exist
:create
669 :direction
:output
)))))
671 (labels ((out (key value
)
673 (let ((*print-readably
* nil
))
674 (format out
"~&\(~s ~s\)" key value
)))))
675 (declare (ignorable (function out
)))
680 (defvar *lift-report-header-hook
* nil
)
682 (defvar *lift-report-footer-hook
* nil
)
684 (defvar *lift-report-detail-hook
* nil
)
686 (defun write-report-header (stream result args
)
687 (append-to-report (out stream
)
689 (out :results-for
(results-for result
))
690 (out :arguments args
)
691 (out :features
(copy-list *features
*))
692 (out :datetime
(get-universal-time))
693 (loop for hook in
*lift-report-header-hook
* do
694 (funcall hook out result
))
695 (format out
"~&\)~%")))
697 (defun write-report-footer (stream result
)
698 (append-to-report (out stream
)
700 (out :test-case-count
(length (tests-run result
)))
701 (out :test-suite-count
(length (suites-run result
)))
702 (out :failure-count
(length (failures result
)))
703 (out :error-count
(length (errors result
)))
704 (out :expected-failure-count
(length (expected-failures result
)))
705 (out :expected-error-count
(length (expected-errors result
)))
706 (out :start-time-universal
(start-time-universal result
))
707 (when (slot-boundp result
'end-time-universal
)
708 (out :end-time-universal
(end-time-universal result
)))
709 (out :errors
(collect-testsuite-summary result
:errors
))
710 (out :failures
(collect-testsuite-summary result
:failures
))
711 (out :expected-errors
712 (collect-testsuite-summary result
:expected-errors
))
713 (out :expected-failures
714 (collect-testsuite-summary result
:expected-failures
))
715 (loop for hook in
*lift-report-footer-hook
* do
716 (funcall hook out result
))
717 (format out
"~&\)~%")))
719 (defmethod summarize-single-test :around
720 (format suite-name test-case-name data
&key stream
)
721 (append-to-report (out stream
)
722 (call-next-method format suite-name test-case-name data
:stream out
)))
724 (defmethod summarize-single-test
725 ((format (eql :save
)) suite-name test-case-name data
726 &key
(stream *standard-output
*))
727 (labels ((out (key value
)
729 (format stream
"~&\(~s ~s\)" key value
)))
730 (write-datum (name &key
(source data
))
731 (let* ((key (intern (symbol-name name
) :keyword
))
732 (value (getf source key
)))
735 (write-datum name
:source
(getf data
:properties
))))
736 (format stream
"~&\(~%")
737 (format stream
"~&\(:suite ~a\)" suite-name
)
738 (format stream
"~&\(:name ~a\)" test-case-name
)
739 ;; FIXME - we could make these extensible
740 (write-datum 'start-time-universal
)
741 (write-datum 'end-time-universal
)
742 (write-datum 'result
)
743 (write-datum 'seconds
)
744 (write-datum 'conses
)
745 (loop for stuff in
(getf data
:properties
) by
#'cddr do
747 (cond ((getf data
:problem
)
748 (let ((problem (getf data
:problem
)))
749 (out :problem-kind
(test-problem-kind problem
))
750 (out :problem-step
(test-step problem
))
751 (out :problem-condition
752 (let ((*print-readably
* nil
))
753 (format nil
"~s" (test-condition problem
))))
754 (out :problem-condition-description
755 (format nil
"~a" (test-condition problem
)))
756 (when (slot-exists-p problem
'backtrace
)
757 (out :problem-backtrace
(backtrace problem
)))))
760 (loop for hook in
*lift-report-detail-hook
* do
761 (funcall hook stream data
))
762 (format stream
"\)~%")))
766 (defun collect-testsuite-summary (result kind
)
767 (let ((list (slot-value result
(intern (symbol-name kind
)
768 (find-package :lift
)))))
769 (flet ((encode-symbol (symbol)
770 (cons (symbol-name symbol
)
771 (package-name (symbol-package symbol
)))))
772 (mapcar (lambda (glitch)
773 (list (encode-symbol (type-of (testsuite glitch
)))
774 (encode-symbol (test-method glitch
))))
778 (collect-testsuite-summary lift
:*test-result
* :failures
)