4 ;; full output for all tests on separate pages per suite? whatever.
5 ;; maybe lift should have the option to print test suite names and test case names
9 For
*standard-input
*: an input stream
11 For
*error-output
*, *standard-output
*, and
*trace-output
*: an output stream.
13 For
*debug-io
*, *query-io
*: a bidirectional stream.
18 (setf (test-result-property *test-result
* :style-sheet
) "test-style.css")
19 (setf (test-result-property *test-result
* :title
) "Test Results X")
20 (setf (test-result-property *test-result
* :if-exists
) :supersede
)
21 (test-result-report *test-result
* #p
"/tmp/report.html" :html
))
23 (run-tests :suite
'(lift-test test-cursors
))
25 (run-tests :suite
'lift-test-ensure
)
27 (test-result-property *test-result
* :title
)
31 in start-test
(result test name
)
32 (push `(,name
,(current-values test
)) (tests-run result
))
34 if fails
/ errors
, will get problem appended
36 current-values comes from prototype stuff
38 use property-list format
49 do-testing with testsuite-run
55 <fn
> (= testsuite-run
)
59 foreach method in suite
, run-test-internal
60 if children
, foreach direct-subclass
, run-tests-internal
63 start-test - push
, name
, value onto test-placeholder
*
67 end-test - setf
:end-time
*
68 (add test-data to tests-run of result
)
71 do-testing with run-test-internal
75 ;; when it doubt, add a special
76 (defvar *report-environment
* nil
77 "Used internally by LIFT reports.")
79 (defun make-report-environment ()
82 ;; env variables need to be part saved in result
84 (defun test-result-report (result output format
)
85 (let ((*report-environment
* (make-report-environment)))
86 (cond ((or (stringp output
)
88 (with-open-file (stream
91 :if-does-not-exist
:create
92 :if-exists
(or (test-result-property
95 (%test-result-report-stream result stream format
)))
97 (%test-result-report-stream result output format
))
99 (error "Don't know how to send a report to ~s" output
)))))
101 (defun %test-result-report-stream
(result stream format
)
102 (start-report-output result stream format
)
103 (summarize-test-result result stream format
)
104 (summarize-test-environment result stream format
)
105 (when (or (failures result
) (errors result
)
106 (expected-failures result
) (expected-errors result
))
107 (summarize-test-problems result stream format
))
108 (summarize-tests-run result stream format
)
109 (end-report-output result stream format
)
110 (generate-detailed-reports result stream format
))
112 (defmethod start-report-output (result stream format
)
113 (declare (ignore result stream format
))
116 (defmethod summarize-test-result (result stream format
)
117 (declare (ignore format
))
118 (format stream
"~&Test results for: ~a~%"
119 (results-for result
))
120 (let ((complete-success?
(and (null (errors result
))
121 (null (failures result
)))))
122 (cond (complete-success?
123 (format stream
"~&~A Successful test~:P~%"
124 (length (tests-run result
))))
126 (format stream
"~&~A Test~:P~[~:;, ~:*~A Failure~:P~]~[~:;, ~:*~A Error~:P~].~%"
127 (length (tests-run result
))
128 (length (failures result
))
129 (length (errors result
)))))))
131 (defmethod summarize-test-environment (result stream format
)
132 (declare (ignore result stream format
))
135 (defmethod summarize-test-problems (result stream format
)
136 (declare (ignore result stream format
))
139 (defmethod generate-detailed-reports (result stream format
)
140 (declare (ignore result stream format
))
143 (defmethod summarize-tests-run (result stream format
)
144 (declare (ignore result stream format
)))
146 (defmethod end-report-output (result stream format
)
147 (declare (ignore result stream format
))
151 (defun summarize-test-environment (result stream format
)
152 (loop for symbol in
(sort `((*lift-dribble-pathname
*)
153 (*lift-debug-output
* interpret-lift-stream
)
154 (*lift-standard-output
* interpret-lift-stream
)
155 (*test-break-on-errors?
*)
156 (*test-do-children?
*)
157 (*lift-equality-test
*)
158 (*test-print-length
*)
160 (*lift-if-dribble-exists
*))
161 'string-lessp
:key
'first
) do
166 ;; some cruft stolen from cl-markdown
168 '((name (:author
:description
:copyright
:keywords
:date
))
169 (http-equiv (:refresh
:expires
))))
171 (defmethod start-report-output (result stream
(format (eql :html
)))
174 (test-result-property result
:title
)
175 (test-result-property result
:style-sheet
)))
177 (defmethod html-header (stream title style-sheet
)
178 (format stream
"~&<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.0 Strict//EN\"
179 \"http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd\">")
180 (format stream
"~&<html>~&<head>")
182 (format stream
"~&<title>~a</title>" title
))
184 (unless (search ".css" style-sheet
)
185 (setf style-sheet
(concatenate 'string style-sheet
".css")))
186 (format stream
"~&<link type='text/css' href='~a' rel='stylesheet' />"
188 (format stream
"~&</head>~&<body>"))
190 (defmethod summarize-test-result (result stream
(format (eql :html
)))
191 (format stream
"~&<div id=\"summary\">")
192 (format stream
"~&<h1>Test results for: ~a</h1>~%"
193 (results-for result
))
194 (let ((complete-success?
(and (null (errors result
))
195 (null (failures result
)))))
196 (cond (complete-success?
197 (format stream
"~&<h2>~A Successful test~:P</h2>~%"
198 (length (tests-run result
))))
201 "~&<h2>~A Test~:P~[~:;, ~:*~A Failure~:P~]~[~:;, ~:*~A Error~:P~].</h2>~%"
202 (length (tests-run result
))
203 (length (failures result
))
204 (length (errors result
)))))
206 (when (or (expected-errors result
) (expected-failures result
))
207 (format stream
"~&<h3>~[~:;~:*Expected failure~p: ~:*~a~]~[~:;, ~]~[~:;~:*Expected error~p: ~:*~a~]</h3>~%"
208 (length (expected-failures result
))
209 ;; zero if only one or the other (so we don't need a separator...)
210 (* (length (expected-failures result
))
211 (length (expected-errors result
)))
212 (length (expected-errors result
))))
214 (when (and (numberp (end-time-universal result
))
215 (numberp (start-time-universal result
)))
216 (format stream
"~&<h3>Testing took: ~:d seconds</h3>"
217 (- (end-time-universal result
)
218 (start-time-universal result
))))
220 (when (and (numberp (real-end-time result
))
221 (numberp (real-start-time result
)))
222 (format stream
"~&Time: ~,2f real-time"
223 (/ (- (real-end-time result
) (real-start-time result
))
224 internal-time-units-per-second
))))
225 (format stream
"~&</div>"))
227 (defmethod summarize-test-environment (result stream
(format (eql :html
)))
228 (declare (ignore result
))
229 (format stream
"~&<div id=\"environment\">")
231 (format stream
"~&</div>"))
233 (defmethod summarize-test-problems (result stream
(format (eql :html
)))
234 (format stream
"~&<div id=\"problem-summary\">")
235 (format stream
"~&<h2>Problem Summary:</h2>")
236 (when (failures result
)
237 (summarize-test-problems-of-type
238 (failures result
) stream
"failure-summary" "Failures"))
239 (when (errors result
)
240 (summarize-test-problems-of-type
241 (errors result
) stream
"error-summary" "Errors"))
242 (when (expected-failures result
)
243 (summarize-test-problems-of-type
244 (expected-failures result
)
245 stream
"expected-failure-summary" "Expected Failures"))
246 (when (expected-errors result
)
247 (summarize-test-problems-of-type
248 (expected-errors result
) stream
"expected-failure-summary"
250 (format stream
"~&</div>"))
252 (defmethod summarize-test-problems-of-type
253 (problems stream id heading
)
254 (format stream
"~&<div id=\"id\">" id
)
255 (format stream
"~&<h3>~a</h3>" heading
)
256 (report-tests-by-suite
257 (mapcar (lambda (problem)
258 `(,(type-of (testsuite problem
))
259 ,(test-method problem
)
260 (:problem
,problem
)))
262 (format stream
"~&</div>"))
264 (defmethod summarize-tests-run (result stream
(format (eql :html
)))
265 (format stream
"~&<div id=\"results\">")
266 (format stream
"~&<h2>Tests Run:</h2>")
267 (report-tests-by-suite (tests-run result
) stream
)
268 (format stream
"~&</div>"))
270 (defun report-tests-by-suite (tests stream
)
271 (let ((current-suite nil
))
272 (loop for rest
= (sort
273 ;; FIXME - this is a hack intended to show tests
274 ;; in the order they were run (even if it works, it's
275 ;; bound to be fragile)
277 #+(or) (nreverse (copy-list tests
))
278 'string-lessp
:key
'first
) then
(rest rest
)
280 for
(suite test-name datum
) = (first rest
) do
281 (unless (eq current-suite suite
)
283 (format stream
"</div>"))
284 (setf current-suite suite
)
285 (format stream
"~&<div class=\"testsuite\">")
286 (let* ((this-suite-end (or
289 (not (eq current-suite
(first datum
))))
292 (error-count (count-if
294 (and (getf (third datum
) :problem
)
295 (typep (getf (third datum
) :problem
)
298 :end this-suite-end
))
299 (failure-count (count-if
301 (and (getf (third datum
) :problem
)
302 (typep (getf (third datum
) :problem
)
305 :end this-suite-end
))
306 (extra-class (cond ((and (= error-count
0) (= failure-count
0))
307 'testsuite-all-passed
)
309 'testsuite-some-errors
)
311 'testsuite-some-failures
))))
312 (format stream
"~&<div class=\"testsuite-title\"><table class=\"~a\"><tr><td>~a</td>" extra-class suite
)
313 (format stream
"<td class=\"testsuite-test-count\">~:d test~:p</td>"
315 (format stream
"<td class=\"testsuite-summary\">")
316 (cond ((and (= error-count
0) (= failure-count
0))
317 (format stream
"all passed"))
319 (format stream
"~[~:;~:*~:d failure~:p~]"
321 (when (and (> error-count
0) (> failure-count
0))
322 (format stream
", "))
323 (format stream
"~[~:;~:*~a error~:p~]"
325 (format stream
"</td></tr></table>")
326 (format stream
"</div>")))
327 (format stream
"~&<div class=\"test-case\">")
328 (let ((problem (getf datum
:problem
)))
329 (cond ((typep problem
'test-failure
)
330 (format stream
"~&<span class=\"test-name\"><a href=\"~a\" title=\"details\">~a</a></span>"
331 (details-link stream suite test-name
)
334 "~&<span class=\"test-failure\">failure</span>" ))
335 ((typep problem
'test-error
)
336 (format stream
"~&<span class=\"test-name\"><a href=\"~a\" title=\"details\">~a [during ~a]</a></span>"
337 (details-link stream suite test-name
)
340 (format stream
"~&<span class=\"test-error\">error</span>"))
342 (format stream
"~&<span class=\"test-name\">~a</span>"
344 (let ((seconds (getf datum
:seconds
))
345 (conses (getf datum
:conses
)))
347 (format stream
"<span class=\"test-time\">~,3f</span>"
350 (format stream
"<span class=\"test-space\">~:d</span>"
352 (format stream
"~&</div>")))
354 (format stream
"</div>"))))
356 (defun get-details-links-table ()
357 (let ((hash (getf *report-environment
* :details-links
)))
359 (setf (getf *report-environment
* :details-links
)
360 (make-hash-table :test
'equal
)))))
363 (get-details-links-table)
365 (defun details-link (stream suite name
)
366 (declare (ignore stream
))
367 (let* ((hash (get-details-links-table)))
368 (or (gethash (cons suite name
) hash
)
370 (incf (getf *report-environment
* :details-links-count
0))
371 (setf (gethash (cons suite name
) hash
)
373 :name
(format nil
"details-~a"
374 (getf *report-environment
* :details-links-count
))
377 (defmethod end-report-output (result stream
(format (eql :html
)))
378 (let ((style-sheet (test-result-property result
:style-sheet
)))
381 (copy-file (asdf:system-relative-pathname
382 'lift
"resources/test-style.css")
384 :name
(pathname-name style-sheet
)
385 :type
(pathname-type style-sheet
)
386 :defaults
(pathname stream
))
387 :if-exists
:supersede
))))
388 (html-footer stream
))
390 (defun html-footer (stream)
391 (format stream
"<div id=\"footer\">")
392 (format stream
"~&generated on ~a"
394 (excl:locale-print-time
396 :fmt
"%B %d, %Y %T GMT%z" :stream nil
)
398 (get-universal-time))
399 (format stream
"</div>")
400 (format stream
"~&</body></html>"))
402 (defmethod generate-detailed-reports (result stream
(format (eql :html
)))
403 (loop for
(suite test-name datum
) in
(tests-run result
)
404 when
(getf datum
:problem
) do
405 (let ((*print-right-margin
* 64))
406 (let ((output-pathname (merge-pathnames
407 (details-link stream suite test-name
)
409 (ensure-directories-exist output-pathname
)
410 (with-open-file (out output-pathname
412 :if-does-not-exist
:create
413 :if-exists
:supersede
)
416 (format nil
"Test ~a details | ~a"
417 test-name
(test-result-property result
:title
))
418 (test-result-property result
:style-sheet
))
419 (format out
"~&<h2>Test ~a details</h2>" test-name
)
420 (format out
"~&<a href=\"~a\">Back</a>"
421 (namestring (make-pathname :name
(pathname-name stream
)
422 :type
(pathname-type stream
))))
423 (format out
"~&<pre>")
426 (with-output-to-string (s)
427 (print-test-problem "" (getf datum
:problem
) s
))))
428 (format out
"~&</pre>")
429 (html-footer out
))))))
432 (defmethod summarize-test-environment (result stream format
)
433 (loop for symbol in
(sort `((*lift-dribble-pathname
*)
434 (*lift-debug-output
* interpret-lift-stream
)
435 (*lift-standard-output
* interpret-lift-stream
)
436 (*test-break-on-errors?
*)
437 (*test-do-children?
*)
438 (*lift-equality-test
*)
439 (*test-print-length
*)
441 (*lift-if-dribble-exists
*))
442 'string-lessp
:key
'first
) do
446 (defun encode-pre (string)
447 ;; Copied from CL-Markdown
448 ;; Copied from HTML-Encode
449 ;;?? this is very consy
451 (declare (simple-string string
))
452 (let ((output (make-array (truncate (length string
) 2/3)
453 :element-type
'character
456 (with-output-to-string (out output
)
457 (loop for char across string
459 ((#\
&) (write-string "&" out
))
460 ((#\
<) (write-string "<" out
))
461 ((#\
>) (write-string ">" out
))
462 (t (write-char char out
)))))
463 (coerce output
'simple-string
)))
467 (defmethod summarize-test-result (result stream
(format (eql :describe
)))
468 (describe result stream
))
470 (defmethod summarize-tests-run (result stream
(format (eql :describe
)))
471 (declare (ignore result stream
))
476 (defmethod summarize-test-result (result stream
(format (eql :save
)))
477 (flet ((add-property (name)
478 (format stream
"~&\(~s ~a\)"
479 (intern (symbol-name name
) :keyword
)
480 (slot-value result name
))))
481 (format stream
"\(~%")
482 (add-property 'results-for
)
483 (format stream
"~&\(:date-time ~a\)" (get-universal-time))
484 (add-property 'real-start-time-universal
)
485 (add-property 'start-time-universal
)
486 (add-property 'end-time-universal
)
487 (add-property 'real-end-time-universal
)
488 (format stream
"~&\(:tests-run ")
489 (loop for
(suite name data
) in
490 ;; FIXME - this is a hack intended to show tests
491 ;; in the order they were run (even if it works, it's
492 ;; bound to be fragile)
493 (copy-list (tests-run result
))
495 (nreverse (copy-list (tests-run result
))) do
496 (labels ((out (name &key
(source data
)
498 (let* ((key (intern (symbol-name name
) :keyword
))
499 (value (getf source key
)))
500 (when (or value print-if-nil?
)
501 (format stream
"~&\(~s ~a\)" key value
))))
503 (out name
:source
(getf data
:properties
))))
504 (format stream
"\(~%")
505 (format stream
"~&\(:suite ~a\)" suite
)
506 (format stream
"~&\(:name ~a\)" name
)
507 ;; FIXME - we could make these extensible
508 (out 'start-time-universal
)
509 (out 'end-time-universal
)
513 (loop for stuff in
(getf data
:properties
) by
#'cddr do
515 (format stream
"~&\)")))
516 (format stream
"~&\)")
517 (format stream
"~&\)")))
520 (compile 'summarize-test-result
)
524 (setf (test-result-property *test-result
* :if-exists
) :supersede
)
525 (test-result-report *test-result
* #p
"/tmp/report.save" :save
))
527 (defun symbol->turtle
(symbol)
530 (loop for char across
(string-downcase (symbol-name symbol
))
531 when
(char= char
#\-
) do
(setf upcase? t
)
532 else collect
(if upcase?
533 (prog1 (char-upcase char
)
538 (defun turtlefy (thing)
541 (pathname (namestring thing
))
544 (integer (format nil
"\"~a\"^^xsd:integer" thing
))
545 (double-float (format nil
"\"~f\"^^xsd:double" thing
))
546 (single-float (format nil
"\"~f\"^^xsd:single" thing
))))
547 (symbol (symbol-name thing
))
548 (t (format nil
"\"~a\"" thing
))))
550 (defun ensure-symbol (thing)
553 (string (intern thing
))))
556 (symbol->turtle
'real-start-time-universal
)
558 (defun date->turtle
(&key
(datetime (get-universal-time)) (include-time? nil
))
560 (second minute hour day month year day-of-the-week
)
561 (decode-universal-time datetime
)
562 (declare (ignore day-of-the-week
))
563 (let ((date-part (format nil
"~d-~2,'0d-~2,'0d" year month day
))
564 (time-part (and include-time?
565 (format nil
"T-~2,'0d:~2,'0d:~2,'0d"
566 hour minute second
)))
567 (data-type (if include-time?
568 "xsd:dateTime" "xsd:date")))
569 (concatenate 'string
"\"" date-part time-part
"\"" "^^" data-type
))))
571 ;; http://www.dajobe.org/2004/01/turtle/
572 (defmethod summarize-test-result (result stream
(format (eql :turtle
)))
573 (labels ((convert-value (value type
)
575 (string (turtlefy value
))
576 (symbol (ensure-symbol value
))
577 (date (date->turtle
:datetime value
))
578 (dateTime (date->turtle
:datetime value
:include-time? t
))))
579 (add-property (name type
)
580 (let ((value (slot-value result name
)))
582 (format stream
"~&:~a ~s ;"
583 (symbol->turtle name
)
584 (convert-value value type
))))))
586 "~&@prefix xsd: <http://www.w3.org/2001/XMLSchema#> .~%")
588 "~&@prefix : <http://www.metabang.com/2007/04/lift#> .~%")
589 (format stream
"\[~%")
590 (add-property 'results-for
'string
)
591 (add-property 'real-start-time
'dateTime
)
592 (add-property 'start-time
'dateTime
)
593 (add-property 'end-time
'dateTime
)
594 (add-property 'real-end-time
'dateTime
)
595 (format stream
"~&\:testsRun (")
596 (loop for
(suite name data
) in
597 ;; FIXME - this is a hack intended to show tests
598 ;; in the order they were run (even if it works, it's
599 ;; bound to be fragile)
600 (copy-list (tests-run result
))
602 (nreverse (copy-list (tests-run result
))) do
603 (labels ((out (name type
&key
(source data
))
604 (let* ((key (intern (symbol-name name
) :keyword
))
605 (value (getf source key
)))
607 (format stream
"~& :~a ~a ;"
608 (symbol->turtle name
)
609 (convert-value value type
)))))
611 (out name type
:source
(getf data
:properties
))))
612 (format stream
"~&\[ ")
613 (format stream
":testSuite ~s ;" (symbol-name suite
))
614 (format stream
"~& :testName ~s ;" (symbol-name name
))
615 ;; FIXME - we could make these extensible
616 (out 'start-time
'dateTime
)
617 (out 'end-time
'dateTime
)
618 (out 'result
'string
)
619 (out 'seconds
'string
)
620 (out 'conses
'string
)
621 (loop for stuff in
(getf data
:properties
) by
#'cddr do
622 (prop stuff
'string
))
623 (format stream
" \]")))
624 (format stream
" ) ~&\] . ")))
628 (setf (test-result-property *test-result
* :if-exists
) :supersede
)
629 (test-result-report *test-result
* #p
"/tmp/report.n3" :turtle
))