Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Newer
Older
100644 1350 lines (1156 sloc) 54.005 kB
5be7639 @avodonosov first commit
avodonosov authored
1 (defpackage #:test-grid (:use :cl))
2
3 (in-package #:test-grid)
4
5 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
6
7 #|
8
9 TODO:
10 - information about test run:
11 + lisp-version-string,
12 + lib-world,
8a2e2a0 @avodonosov update the TODO comment.
avodonosov authored
13 + author contact (get it from some settings file),
5be7639 @avodonosov first commit
avodonosov authored
14 + date,
15 + run-duration
16 + organize database file format
17 + better decision for library name representation.
18 This representation is used in the:
19 - libtest method parameter (eql specialized)
20 - in the database and testrun datastructure.
21 Possible alternatives:
22 a keyword
23 good for READ (package independent),
24 good for EQL specializer
25 good for GETF when working with the database
26 a symbol from the test-grid package
27 - good for EQL specializer
28 - package dependent in READ
29 - good for GETF when working with the database
30 - adds one more (unnecessary) way to represent a library
31 in addition the specified for ASDF and Quicklisp
32 or a downcased string
33 - needs special handling in libtest eql specialization
34 - good ro READ (package independent)
35 - needs care to work with GETF when working with the database
06cb006 @avodonosov fixed some typos in the TODO comment
avodonosov authored
36 + Generate a sufficiently large database so that we can
5be7639 @avodonosov first commit
avodonosov authored
37 evaluate our reporting solution. We may generate
06cb006 @avodonosov fixed some typos in the TODO comment
avodonosov authored
38 fake test results programmatically to make this task
5be7639 @avodonosov first commit
avodonosov authored
39 easier.
40 - simpliest reporting to allow overview of library test statuses
a8e8a13 @avodonosov Implemented online storage for libraries test logs, hosted on Google …
avodonosov authored
41 - Test Runs report: every test run as a row in a table
5be7639 @avodonosov first commit
avodonosov authored
42 + legend or a tooltip in the report for test statuses
43 + color for statuses
ec59872 @avodonosov TODO comment about finalizing the terminology about our main data obj…
avodonosov authored
44 + use the online blob URL in the report
fa1c4e1 @avodonosov Pivot reports. First working version; no comments, data cell is rende…
avodonosov authored
45 - A pivot -like table report of library test results, allowing
95e993b @avodonosov updated the main TODO comment.
avodonosov authored
46 rows/columns to be any of quicklisp distro, lisp version
47 library name. With grouping and sorging.
3a160d3 @avodonosov Better (most likely final) formatting for the test-reports-overview.html
avodonosov authored
48 - CSV export of the database to use it then with spreadsheets,
95e993b @avodonosov updated the main TODO comment.
avodonosov authored
49 google fusion tables, etc. Initial intent
50 was to format it as a pivot for various projections
51 (by quicklisp releases, by platform, etc).
52 But neither google docs spreadsheet, nor google fusion
53 table allow as to format results as we want
54 (the main problem, it is impossible to use
55 a custom aggregation function for pivot
56 cells, because standard aggregation functions
57 are numeric, but we want a report cell
58 to represent test result(s) for a particular
59 library, i.e. :ok, :fail, :no-resource).
5be7639 @avodonosov first commit
avodonosov authored
60 5h
3a160d3 @avodonosov Better (most likely final) formatting for the test-reports-overview.html
avodonosov authored
61 - Test that the test-duration field value
62 (Common Lisp rational) can be read
63 by spreadsheet software (MS/Open Offices,
64 Google Spreadsheets).
06cb006 @avodonosov fixed some typos in the TODO comment
avodonosov authored
65 - an informer which may be embedded into a library
66 project page, with reports about the test statuses
5be7639 @avodonosov first commit
avodonosov authored
67 for this single library on various platforms with
68 various quicklisp versions
3a160d3 @avodonosov Better (most likely final) formatting for the test-reports-overview.html
avodonosov authored
69 - an overview page with brief explanation of all
70 the above reports and links to the reports.
71 - change
72 "represents every test run as a separate row"
73 to
74 "represents every <tt>test-grid:run-tests</tt> as a separate row"
75 (after user will know this command from the main project description)
76 ?
77 - Description of CSV report may link to an example
78 of the CSV report imported to a Google Spreadsheet
79 with pivot calculating avearage duration of
80 tests for every library.
81 - spell check
5be7639 @avodonosov first commit
avodonosov authored
82 - simple UI (command line) with guiding messages
83 for the user who runs the tests. Spend as little
84 efforts as possible on this task, to release quickly.
85 4h
86 - readme with explanation of the project goal and
87 how to use it
88 5h
a8e8a13 @avodonosov Implemented online storage for libraries test logs, hosted on Google …
avodonosov authored
89 - change db format
c023819 @avodonosov test run as plist (:descr <descr> :run-results <run-results>) instead…
avodonosov authored
90 + test run as plist (:descr <descr> :run-results <run-results>)
a8e8a13 @avodonosov Implemented online storage for libraries test logs, hosted on Google …
avodonosov authored
91 instead of just (<descr> <run-results>)
9dd75c2 @avodonosov data format: instead of storing librari name as a key for the library…
avodonosov authored
92 + run-results as a list instead of plist; libname
93 which was a plist key is now a property of the lib-result
94 object. It is more convenient for standard mapping functions,
95 instead of current do-lib-results.
5be7639 @avodonosov first commit
avodonosov authored
96 - add more libraries: total number of 20 libraries
97 is enough for the beginning
e62cd8c @avodonosov update the TODO comment.
avodonosov authored
98 + when loading of a library or library test system
5be7639 @avodonosov first commit
avodonosov authored
99 fails, ensure we have the error description in the output
100 0.5h
8a2e2a0 @avodonosov update the TODO comment.
avodonosov authored
101 + The "thank you" message: where exactly to submit test results?
5be7639 @avodonosov first commit
avodonosov authored
102 Specify an email or issue tracker of the cl-test-grid project.
8a2e2a0 @avodonosov update the TODO comment.
avodonosov authored
103 + how to store public (central) database and failed library
5be7639 @avodonosov first commit
avodonosov authored
104 outputs (files).
105 An appealing way is to store it in the same git repository
106 on github, but with the std-out files the repository will
107 quickly grow to an unconvenient size (for new people the
108 checkout procedure will be too long to be considered
109 convenient)
110 5h
8a2e2a0 @avodonosov update the TODO comment.
avodonosov authored
111 Solution: files are stored in Google App Engine blob store.
a8e8a13 @avodonosov Implemented online storage for libraries test logs, hosted on Google …
avodonosov authored
112 - run the tests on all the implementations available for us.
4055e27 @avodonosov Added cl-base64 to the tests.
avodonosov authored
113 - usocket test suite might need manual configuration,
114 see their README. Distinguish the case
115 when the manual configuration hasn't been
116 performed and return :no-resource status.
117 - For all the libraries which need manual configuration
696936b @avodonosov Added iterate and metabang-bind.
avodonosov authored
118 (cffi, usocket) provide guiding message to the
4055e27 @avodonosov Added cl-base64 to the tests.
avodonosov authored
119 user how to configure them.
3a160d3 @avodonosov Better (most likely final) formatting for the test-reports-overview.html
avodonosov authored
120 - finalize the decision what command user runs
121 to performs the tests. Describe this main command
122 in the README (in the first paragraph).
4055e27 @avodonosov Added cl-base64 to the tests.
avodonosov authored
123
5be7639 @avodonosov first commit
avodonosov authored
124 ==================================================
125 ========== Milestone: release 0 ============
126 ==================================================
ec59872 @avodonosov TODO comment about finalizing the terminology about our main data obj…
avodonosov authored
127 - finalize the terminology we use in the code
128 to refer our main data:
129 - test status for a particular library
130 - library test result object (includes the status
131 as well as log length, the key of the log
132 in the online blob store, probably the
133 library test duration)
134 - list of library test results in a particular test
135 run
136 - test run description, consists of lisp name,
137 libraries set (think quicklisp distro),
138 the user contacts, total test run duration,
139 etc.
7ab792d @avodonosov Added trivial-backtrace to the tests. (Always fails; it tries to crea…
avodonosov authored
140 - watchdog for hanging tests
5be7639 @avodonosov first commit
avodonosov authored
141 + more abstract accessor to parts of DB info instead of
142 getf by properties: run-descr, run-results.
143 1h
144 + safe-read database
145 + create a project with asdf system
146 0.5h
147 + DB file path based on the asdf system location
148 0.5h
149 + accumulate failed library output
150 1h
151 - DB file formatting should be equal in all lisps,
152 so that diff shows only new records.
153 (use pprint ?)
154 4h
155 - a way to specify lib-wold as a quicklisp version with some
156 library versions overriden (checkout this particular
157 libraries from the scm), so that library author can quickly
158 get test result for his changes (fixes) in scm.
159 An implementation idea to consider: almost every scm allows
160 to download asnapshot via http, so the quicklisp http machinery may
161 be reused here, whithout running a shell command for
162 checkout.
163 24h
164 - should we save library log to a file only if the tests failed,
165 or always? (now we save log in any case)
166 - During run-libtests, probably we should redirect the library
167 output to file directly, without caching it in memory
168 - it is more convenient when you are watching the testing
169 process, you can observe the file being populated with
170 logs (because some libraries, like flexi-streams, take
171 time about minute to finish, and if during this minute
172 nithing happens it is not user-friendly)
173 |#
174
175 (defgeneric libtest (library-name)
176 (:documentation "Define a method for this function
b279089 @avodonosov Fixed return value of the run-testlibs - if logs upload to the blobst…
avodonosov authored
177 with LIBRARY-NAME eql-specialized for for every library added
5be7639 @avodonosov first commit
avodonosov authored
178 to the test grid.
179
180 The method should run test suite and return the resulting
181 status. Status is one of three values:
182 :OK - all tests passed,
183 :FAIL - some test failed,
184 :NO-RESOURCE - test suite can not be run because some required
185 resource is absent in the environment. For example, CFFI library
186 test suite needs a small C library compiled to DLL. User must
187 do it manually. In case the DLL is absent, the LIBTEST method
188 for CFFI returns :NO-RESOURCE.
189
190 For convenience, T may be returned instead of :OK and NIL instead of :FAIL."))
191
192 (defun normalize-status (status)
193 "Normilzies test resul status - converts T to :OK and NIL to :FAIL."
194 (case status
195 ((t :ok) :ok)
196 ((nil :fail) :fail)
197 (otherwise status)))
198
4055e27 @avodonosov Added cl-base64 to the tests.
avodonosov authored
199 (defparameter *all-libs* '(:alexandria :babel :trivial-features :cffi
200 :cl-ppcre :usocket :flexi-streams :bordeaux-threads
44b1c75 @avodonosov Added parenscript
avodonosov authored
201 :cl-base64 :trivial-backtrace :puri :anaphora
696936b @avodonosov Added iterate and metabang-bind.
avodonosov authored
202 :parenscript :trivial-garbage :iterate :metabang-bind)
5be7639 @avodonosov first commit
avodonosov authored
203 "All the libraries currently supported by the test-grid.")
204
205 (defun clean-rt ()
206 "Helper function to assist running test suites created using the RT
207 test framework. The problem is that RT uses global storage for all
208 the tests; in result if we previously loaded any test system,
209 after loading another test system the global test RT test suite
210 contains the tests of _both_ libraries."
211 (let ((rem-all-tests (and (find-package '#:rt)
212 (find-symbol (symbol-name '#:rem-all-tests) '#:rt))))
213 (when rem-all-tests (funcall rem-all-tests))))
214
215 (defmethod libtest ((library-name (eql :alexandria)))
216
217 ;; The test framework used: rt.
218 (clean-rt)
219 (asdf:clear-system :alexandria-tests)
220
221 (quicklisp:quickload :alexandria-tests)
222
223 (flet (
224 ;; the run-tests local function is copy/pasted
225 ;; from alexandria-tests.asd
226 (run-tests (&rest args)
227 (apply (intern (string '#:run-tests) '#:alexandria-tests) args)))
228
229 (let ((a (run-tests :compiled nil))
230 (b (run-tests :compiled t)))
231 (and a b))))
232
233 (defmethod libtest ((library-name (eql :babel)))
234
235 ;; The test framework used: stefil.
236
237 (quicklisp:quickload :babel-tests)
238
239 (let ((result (funcall (intern (string '#:run) '#:babel-tests))))
240 (zerop
241 (length (funcall (intern (string '#:failure-descriptions-of) '#:hu.dwim.stefil)
242 result)))))
243
244 (defmethod libtest ((library-name (eql :trivial-features)))
245
246 ;; The test framework used: rt.
247 (clean-rt)
248 (asdf:clear-system :trivial-features-tests)
249
250 (quicklisp:quickload :trivial-features-tests)
251
252 ;; copy/past from trivial-features-tests.asd
253 (let ((*package* (find-package 'trivial-features-tests)))
254 (funcall (find-symbol (symbol-name '#:do-tests)))))
255
256 (defmethod libtest ((library-name (eql :cffi)))
257
258 ;; The test framework used: rt.
259 (clean-rt)
260 (asdf:clear-system :cffi-tests)
261
262 (handler-case (quicklisp:quickload :cffi-tests)
263 ;; CFFI tests work with a small test C
264 ;; library. The user is expected to compile
265 ;; the library. If the library is not available,
266 ;; CFFI tests signal cffi:load-foreign-library-error.
267 (t (e)
268 (when (eq (type-of e)
269 (find-symbol (symbol-name '#:load-foreign-library-error) '#:cffi))
270 (return-from libtest :no-resource))))
271
272 (flet (
273 ;; copy/paste from cffi-tests.asd
274 (run-tests (&rest args)
275 (apply (intern (string '#:run-cffi-tests) '#:cffi-tests) args)))
276
277 (let ((a (run-tests :compiled nil))
278 (b (run-tests :compiled t)))
279 (and a b))))
280
281 (defmethod libtest ((library-name (eql :cl-ppcre)))
282
283 ;; The test framework used: custom.
284
285 ;; Workaround the quicklisp issue #225 -
286 ;; https://github.com/quicklisp/quicklisp-projects/issues/225 -
287 ;; first load cl-ppcre-unicode, because otherwise
288 ;; current quicklisp can not find cl-ppcre-unicode-test
289 (quicklisp:quickload :cl-ppcre-unicode)
290 (quicklisp:quickload :cl-ppcre-unicode-test)
291
292 ;; copy/paste from cl-ppcre-unicode.asd
293 (funcall (intern (symbol-name :run-all-tests) (find-package :cl-ppcre-test))
294 :more-tests (intern (symbol-name :unicode-test) (find-package :cl-ppcre-test))))
295
296 (defmethod libtest ((library-name (eql :usocket)))
297
298 ;; The test framework used: rt.
299 (clean-rt)
300 (asdf:clear-system :usocket-test)
301
302 ; (asdf:operate 'asdf:load-op :usocket-test :force t)
303
304 (quicklisp:quickload :usocket-test)
305
306 ;; TODO: usocket test suite might need manual configuration,
307 ;; see their README. Distinguish the case
308 ;; when the manual configuration hasn't been
309 ;; performed and return :no-resource status.
4055e27 @avodonosov Added cl-base64 to the tests.
avodonosov authored
310 ;;
5be7639 @avodonosov first commit
avodonosov authored
311 ;; (setf usocket-test::*common-lisp-net*
312 ;; (or usocket-test::*common-lisp-net*
313 ;; "74.115.254.14"))
314
315 ;; copy/paste from usocket-test.asd
316 (funcall (intern "DO-TESTS" "USOCKET-TEST")))
317
318
319 (defmethod libtest ((library-name (eql :flexi-streams)))
320
321 ;; The test framework used: custom.
322
323 (quicklisp:quickload :flexi-streams-test)
324
325 ;; copy/paste from flexi-streams.asd
326 (funcall (intern (symbol-name :run-all-tests)
327 (find-package :flexi-streams-test))))
328
d4fc132 @avodonosov added cl-json
avodonosov authored
329 (defun run-fiveam-suite (fiveam-test-spec)
330 "Runs the specified test suite created with the FiveAM
331 test framework. Returns T if all the tests succeeded and
332 NIL otherwise. The FIVEAM-TEST-SPEC specifies the tests
333 suite according to the FiveAM convention."
334 (let ((run (intern (string '#:run) :fiveam))
335 (explain (intern (string '#:explain) :fiveam))
336 (detailed-text-explainer (intern (string '#:detailed-text-explainer) :fiveam))
337 (test-failure-type (intern (string '#:test-failure) :fiveam)))
338
339 (let ((results (funcall run fiveam-test-spec)))
340 (funcall explain (make-instance detailed-text-explainer) results *standard-output*)
341 (zerop (count-if (lambda (res)
342 (typep res test-failure-type))
343 results)))))
344
5be7639 @avodonosov first commit
avodonosov authored
345 (defmethod libtest ((library-name (eql :bordeaux-threads)))
346
347 ;; The test framework used: fiveam.
348
349 (quicklisp:quickload :bordeaux-threads-test)
d4fc132 @avodonosov added cl-json
avodonosov authored
350
351 (run-fiveam-suite :bordeaux-threads))
5be7639 @avodonosov first commit
avodonosov authored
352
4055e27 @avodonosov Added cl-base64 to the tests.
avodonosov authored
353 (defmethod libtest ((library-name (eql :cl-base64)))
354
355 ;; The test framework used: ptester.
356
357 (quicklisp:quickload :cl-base64-tests)
358
359 (funcall (intern (symbol-name '#:do-tests)
360 (find-package '#:cl-base64-tests))))
361
696936b @avodonosov Added iterate and metabang-bind.
avodonosov authored
362 (defun lift-tests-ok-p (lift-tests-result)
363 "Helper function to work with Lift test framework.
364 Examines the tests result object and retuns T is all
365 the tests are successull and NIL otherwise."
366 (let ((errors (intern (symbol-name '#:errors) :lift))
367 (expected-errors (intern (symbol-name '#:expected-errors) :lift))
368 (failures (intern (symbol-name '#:failures) :lift))
369 (expected-failures (intern (symbol-name '#:expected-failures) :lift)))
370 (zerop
371 (+ (length (set-difference (funcall errors lift-tests-result)
372 (funcall expected-errors lift-tests-result)))
373 (length (set-difference (funcall failures lift-tests-result)
374 (funcall expected-failures lift-tests-result)))))))
375
376 (defun run-lift-tests (suite-name)
377 "Helper function to work with the Lift test framework.
378 Runs the specified Lift test suite and returns T
379 if all the tests succeeded and NIL othersize."
380 (let ((result (funcall (intern (symbol-name '#:run-tests) :lift)
381 :suite suite-name)))
382 (describe result *standard-output*)
383 (lift-tests-ok-p result)))
384
7ab792d @avodonosov Added trivial-backtrace to the tests. (Always fails; it tries to crea…
avodonosov authored
385 (defmethod libtest ((library-name (eql :trivial-backtrace)))
386
387 ;; The test framework used: lift.
388
389 (quicklisp:quickload :trivial-backtrace-test)
696936b @avodonosov Added iterate and metabang-bind.
avodonosov authored
390
391 (run-lift-tests :trivial-backtrace-test))
7ab792d @avodonosov Added trivial-backtrace to the tests. (Always fails; it tries to crea…
avodonosov authored
392
1639b53 @avodonosov Added puri. A typo fixed in the LIBTEST for trivial-backtrace. Decide…
avodonosov authored
393 (defmethod libtest ((library-name (eql :puri)))
394
395 ;; The test framework used: ptester.
396
397 (quicklisp:quickload :puri-tests)
398
399 ;; copy/paste from puri.asd
400 (funcall (intern (symbol-name '#:do-tests)
401 (find-package :puri-tests))))
402
1d6be7b @avodonosov Added anaphora
avodonosov authored
403 (defmethod libtest ((library-name (eql :anaphora)))
404
405 ;; The test framework used: rt.
406 (clean-rt)
407 (asdf:clear-system :anaphora-test)
408
409 (quicklisp:quickload :anaphora-test)
410
411 ;; copy/paste from anaphora.asd
412 (funcall (intern "DO-TESTS" :rt)))
413
44b1c75 @avodonosov Added parenscript
avodonosov authored
414 (defmethod libtest ((library-name (eql :parenscript)))
415 ;; The test framework used: eos (similar to FiveAM).
416
417 ;; asdf:test-op is not provided for parenscript,
418 ;; only a separate package ps-test with public
419 ;; function run-tests.
420
421 ;; The test suites to run determined by looking
422 ;; into the function run-tests in the file test.lisp.
423 (let* ((run (intern (string '#:run) :eos))
424 (test-failure-type (intern (string '#:test-failure) :eos))
425 (results (append (funcall run (intern (string '#:output-tests) :ps-test))
426 (funcall run (intern (string '#:package-system-tests) :ps-test)))))
427 (zerop (count-if (lambda (res)
428 (typep res test-failure-type))
429 results))))
430
d7c17f3 @avodonosov Added trivial-garbage.
avodonosov authored
431 (defmethod libtest ((library-name (eql :trivial-garbage)))
432
433 ;; The test framework used: rt.
434 (clean-rt)
435 (asdf:clear-system :trivial-garbage) ; yes, trivial-garbage but not trivial-garbage-tests,
436 ; because the trivial-garbage-tests system is defined
437 ; in the same trivial-garbage.asd and neither
438 ; asdf nor quicklisp can't find trivial-garbage-tests.
439
440 (quicklisp:quickload :trivial-garbage); trivial-garbage but not trivial-garbage-tests,
441 ; for the same reasons as explained above.
442 (asdf:operate 'asdf:load-op :trivial-garbage-tests)
443
444 (funcall (find-symbol (string '#:do-tests) '#:rtest)))
1d6be7b @avodonosov Added anaphora
avodonosov authored
445
696936b @avodonosov Added iterate and metabang-bind.
avodonosov authored
446 (defmethod libtest ((library-name (eql :iterate)))
447
448 ;; The test framework used: rt.
449 (clean-rt)
450 (asdf:clear-system :iterate-tests)
451 (asdf:clear-system :iterate)
452
453 (quicklisp:quickload :iterate-tests)
454
455 (funcall (intern "DO-TESTS" (find-package #+sbcl "SB-RT"
456 #-sbcl "REGRESSION-TEST"))))
457
458 (defmethod libtest ((library-name (eql :metabang-bind)))
459
460 ;; The test framework used: lift.
461
d4fc132 @avodonosov added cl-json
avodonosov authored
462 ;; metabang-bind-test includes binding syntax
463 ;; for regular-expression and corresponding
464 ;; tests; but this functionality is only
465 ;; loaded if cl-ppcre is loaded first.
466 ;; (this conditional loading is achieaved
467 ;; with asdf-system-connections).
696936b @avodonosov Added iterate and metabang-bind.
avodonosov authored
468 (quicklisp:quickload :cl-ppcre)
469 (quicklisp:quickload :metabang-bind-test)
470
471 (run-lift-tests :metabang-bind-test))
472
d4fc132 @avodonosov added cl-json
avodonosov authored
473 (defmethod libtest ((library-name (eql :cl-json)))
474 ;; The test framework used: fiveam.
475 (quicklisp:quickload :cl-json.test)
476 (run-fiveam-suite (intern (symbol-name '#:json) :json-test)))
477
478
5be7639 @avodonosov first commit
avodonosov authored
479 (defun run-libtest (lib)
480 (let* ((orig-std-out *standard-output*)
481 (buf (make-string-output-stream))
482 (*standard-output* buf)
d88a518 @d35h finally finished function get-user-email, added new property in resul…
d35h authored
483 (*error-output* buf)
484 (start-time (get-internal-real-time)))
5be7639 @avodonosov first commit
avodonosov authored
485
b279089 @avodonosov Fixed return value of the run-testlibs - if logs upload to the blobst…
avodonosov authored
486 (format orig-std-out
696936b @avodonosov Added iterate and metabang-bind.
avodonosov authored
487 "Running tests for ~A. *STANDARD-OUTPUT* and *ERROR-OUTPUT* are redirected.~%"
5be7639 @avodonosov first commit
avodonosov authored
488 lib)
489 (finish-output orig-std-out)
490
491 (let ((status (handler-case (normalize-status (libtest lib))
492 (t () :fail))))
493 (when (eq :fail status)
494 (format t "~A tests failed." lib))
495 (let ((output (get-output-stream-string buf)))
9dd75c2 @avodonosov data format: instead of storing librari name as a key for the library…
avodonosov authored
496 (list :libname lib
497 :status status :output output
d88a518 @d35h finally finished function get-user-email, added new property in resul…
d35h authored
498 :log-char-length (length output)
499 :test-duration (/ (- (get-internal-real-time) start-time)
500 internal-time-units-per-second))))))
5be7639 @avodonosov first commit
avodonosov authored
501
4cea853 @avodonosov Use ql:quickload instead of asdf:operate when loading the GAE blobsto…
avodonosov authored
502 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
503 ;; Utils
504 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
505 (defun do-plist-impl (plist handler)
506 (do* ((cur-pos plist (cddr cur-pos))
507 (prop (first cur-pos) (first cur-pos))
508 (val (second cur-pos) (second cur-pos)))
509 ((null prop))
510 (funcall handler prop val)))
511
512 (defmacro do-plist ((key val plist &optional result) &body body)
513 `(block nil
514 (do-plist-impl ,plist (lambda (,key ,val) ,@body))
515 ,result))
516
517 (defun plist-comparator (&rest props-and-preds)
518 (lambda (plist-a plist-b)
519 (do-plist (prop pred props-and-preds)
520 ;; iterate over all the property/predicate pairs
521 ;; "compare" the values of the current property
522 ;; in both plists
523 (let ((val-a (getf plist-a prop))
524 (val-b (getf plist-b prop)))
525 (if (funcall pred val-a val-b)
526 (return t))
527 ;; Ok, val-a is not less than val-b (as defined by our predicate).
528 ;; Lets check if they are equal. If the reverse comparation [val-b less val-a]
529 ;; is also false, then they are equal, and we proceed to the next
530 ;; property/predicate pair.
531 (when (funcall pred val-b val-a)
532 (return nil))))))
533
534 ;; examples:
535 #|
536 (let ((less (plist-comparator :a '< :b 'string<)))
537 (and (funcall less '(:a 1 :b "x") '(:a 2 :b "y"))
538 (funcall less '(:a 2 :b "x") '(:a 2 :b "y"))
539 (not (funcall less '(:a 3 :b "x") '(:a 2 :b "y")))))
540
541 (equalp
542 (sort '((:a 1 :b "x")
543 (:a 2 :b "y")
544 (:a 2 :b "y")
545 (:a 3 :b "z"))
546 (plist-comparator :a '< :b 'string<))
547 '((:A 1 :B "x") (:A 2 :B "y") (:A 2 :B "y") (:A 3 :B "z")))
548 |#
549
9dd75c2 @avodonosov data format: instead of storing librari name as a key for the library…
avodonosov authored
550 (defun getter (prop)
551 #'(lambda (plist)
552 (getf plist prop)))
4cea853 @avodonosov Use ql:quickload instead of asdf:operate when loading the GAE blobsto…
avodonosov authored
553
fa1c4e1 @avodonosov Pivot reports. First working version; no comments, data cell is rende…
avodonosov authored
554 (defun list< (predicates l1 l2)
555 "Compares two lists L1 and L2 of equal lenght,
556 using for every pair of elements a corresponding predicate
557 from the PREDICATES list (of the same length). Returns
558 T if L1 is less than (according the PREDICATES) L2.
559 Othersise returns NIL."
560 (if (null predicates)
561 nil
562 (let ((pred (car predicates))
563 (elem1 (car l1))
564 (elem2 (car l2)))
565 (if (funcall pred elem1 elem2)
566 t
567 ;; Ok, elem1 is not less than elem2 (as defined by our predicate).
568 ;; Lets check if they are equal. If the reverse comparation [elem2 less elem1]
569 ;; is also false, then they are equal, and we proceed to the next
570 ;; property/predicate pair.
571 (if (funcall pred elem2 elem1)
572 nil
573 (list< (cdr predicates)
574 (cdr l1)
575 (cdr l2)))))))
576
577 #|
578 Examples:
579
580 (and
581 (list< '(< <) '(1 2) '(2 2))
582 (not (list< '(< <) '(1 2) '(1 2)))
583 (list< '(< <) '(1 2) '(1 3))
584 (not (list< '(string< string<)
585 '("quicklisp-fake-2011-00-02" "ccl-fake-1")
586 '("quicklisp-fake-2011-00-01" "clisp-fake-1"))))
587 |#
588
589 (defun hash-table-keys (hash-table)
590 (let (keys)
591 (maphash #'(lambda (key val)
592 (declare (ignore val))
593 (push key keys))
594 hash-table)
595 keys))
596
4cea853 @avodonosov Use ql:quickload instead of asdf:operate when loading the GAE blobsto…
avodonosov authored
597 ;; copy/paste from
598 ;; http://www.gigamonkeys.com/book/practical-an-mp3-browser.html
599 (defmacro with-safe-io-syntax (&body body)
600 `(with-standard-io-syntax
601 (let ((*read-eval* nil))
602 ,@body)))
603
604 (defun safe-read (&rest args)
605 (with-safe-io-syntax (apply #'read args)))
606
607 (defun safe-read-file (file)
608 (with-open-file (in file
609 :direction :input
610 :element-type 'character ;'(unsigned-byte 8) + flexi-stream
611 )
612 (safe-read in)))
613
614 ;; copy/paste from
615 ;; http://cl-user.net/asp/-1MB/sdataQ0mpnsnLt7msDQ3YNypX8yBX8yBXnMq=/sdataQu3F$sSHnB==
616 (defun file-string (path)
617 "Sucks up an entire file from PATH into a freshly-allocated string,
618 returning two values: the string and the number of bytes read."
619 (with-open-file (s path)
620 (let* ((len (file-length s))
621 (data (make-string len)))
622 (values data (read-sequence data s)))))
623
624 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1195d22 @avodonosov Fix the last merge
avodonosov authored
625 ;; Settings
626 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
0f16035 @d35h fixed return value of function get-user-email
d35h authored
627
1195d22 @avodonosov Fix the last merge
avodonosov authored
628 (defun get-settings-file()
629 (merge-pathnames (user-homedir-pathname) "cl-test-grid-settings.lisp"))
630
631 (defun prompt-for-email ()
632 (format *query-io* "~a: " "Please enter your email for questions about this, test, your environment, adds")
633 (force-output *query-io*)
634 (string-trim " " (read-line *query-io*)))
635
e2fbbf3 @d35h fixed function name get-user-email and now it returns user email
d35h authored
636 (defun get-user-email ()
0f16035 @d35h fixed return value of function get-user-email
d35h authored
637 (LET ((USER-EMAIL nil))
638 (handler-case
639 (if (STRING= "" (setf user-email(GETF (SAFE-READ-FILE (GET-SETTINGS-FILE)
640 ) :USER-EMAIL)))
d88a518 @d35h finally finished function get-user-email, added new property in resul…
d35h authored
641 (FORMAT t "Warning! Empty email is specified in the settings file ~a~%" (get-settings-file)))
0f16035 @d35h fixed return value of function get-user-email
d35h authored
642 (t ()
643 (PROGN
644 (write-to-file (list :user-email (setf user-email (prompt-for-email)))
645 (get-settings-file)))))
646 user-email))
1195d22 @avodonosov Fix the last merge
avodonosov authored
647
648 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
4cea853 @avodonosov Use ql:quickload instead of asdf:operate when loading the GAE blobsto…
avodonosov authored
649 ;; Test Runs
650 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
5be7639 @avodonosov first commit
avodonosov authored
651
652 (defun run-descr (run)
653 "The description part of the test run."
c023819 @avodonosov test run as plist (:descr <descr> :run-results <run-results>) instead…
avodonosov authored
654 (getf run :descr))
5be7639 @avodonosov first commit
avodonosov authored
655
656 (defun run-results (run)
657 "The list of test suite statuses for every library in the specified test run."
c023819 @avodonosov test run as plist (:descr <descr> :run-results <run-results>) instead…
avodonosov authored
658 (getf run :results))
5be7639 @avodonosov first commit
avodonosov authored
659
a8e8a13 @avodonosov Implemented online storage for libraries test logs, hosted on Google …
avodonosov authored
660 (defun (setf run-results) (new-run-results test-run)
c023819 @avodonosov test run as plist (:descr <descr> :run-results <run-results>) instead…
avodonosov authored
661 (setf (getf test-run :results) new-run-results))
662
663 (defun make-run (description lib-results)
664 (list :descr description :results lib-results))
a8e8a13 @avodonosov Implemented online storage for libraries test logs, hosted on Google …
avodonosov authored
665
5be7639 @avodonosov first commit
avodonosov authored
666 (defun fmt-time (universal-time &optional destination)
667 "The preferred time format used in the cl-test-grid project."
668 (multiple-value-bind (sec min hour date month year)
669 (decode-universal-time universal-time 0)
670 (funcall #'format
671 destination
672 "~2,'0D~2,'0D~2,'0D~2,'0D~2,'0D~2,'0D"
673 year month date hour min sec)))
674
0a04998 @avodonosov Clarified a little bit more the comment about why hunchentoot is not …
avodonosov authored
675 (defun pretty-fmt-time (universal-time &optional destination)
676 "The human-readable time format, used in reports."
677 (multiple-value-bind (sec min hour date month year)
678 (decode-universal-time universal-time 0)
679 (funcall #'format
680 destination
681 "~2,'0D-~2,'0D-~2,'0D ~2,'0D:~2,'0D:~2,'0D"
682 year month date hour min sec)))
683
5be7639 @avodonosov first commit
avodonosov authored
684 (defun make-run-descr ()
685 "Generate a description for a test run which might be
686 performed in the current lisp system."
687 (list :lisp (asdf::implementation-identifier)
688 :lib-world (format nil "quicklisp ~A"
689 (ql-dist:version (ql-dist:dist "quicklisp")))
690 :time (get-universal-time)
691 :run-duration :unknown
0f16035 @d35h fixed return value of function get-user-email
d35h authored
692 :contact (list :email (get-user-email))))
5be7639 @avodonosov first commit
avodonosov authored
693
694 (defun name-run-directory (run-descr)
695 "Generate name for the directory where test run
696 data (libraries test suites output and the run results) will be saved."
697 (format nil
698 "~A-~A"
699 (fmt-time (getf run-descr :time))
700 (getf run-descr :lisp)))
701
702 (defun test-output-base-dir ()
703 (merge-pathnames "test-runs/"
704 test-grid-config:*src-base-dir*))
705
706 (defun run-directory (run-descr)
707 (merge-pathnames (make-pathname
708 :directory (list :relative (name-run-directory run-descr))
709 :name nil
710 :type nil)
711 (test-output-base-dir)))
712
a8e8a13 @avodonosov Implemented online storage for libraries test logs, hosted on Google …
avodonosov authored
713 (defun lib-log-file (test-run-directory lib-name)
714 (merge-pathnames (string-downcase lib-name)
715 test-run-directory))
716
5be7639 @avodonosov first commit
avodonosov authored
717 (defun save-lib-log (lib-name log test-run-directory)
a8e8a13 @avodonosov Implemented online storage for libraries test logs, hosted on Google …
avodonosov authored
718 (let ((lib-log-file (lib-log-file test-run-directory lib-name)))
9dd75c2 @avodonosov data format: instead of storing librari name as a key for the library…
avodonosov authored
719 (with-open-file (out lib-log-file
720 :direction :output
721 :if-exists :overwrite
722 :if-does-not-exist :create)
723 (write-sequence log out))))
5be7639 @avodonosov first commit
avodonosov authored
724
725 (defun write-to-file (obj file)
726 "Write to file the lisp object OBJ in a format acceptable to READ."
727 (with-open-file (out file
728 :direction :output
729 :if-exists :supersede
730 :if-does-not-exist :create)
731 (pprint obj out))
732 obj)
733
a8e8a13 @avodonosov Implemented online storage for libraries test logs, hosted on Google …
avodonosov authored
734 (defun run-info-file (test-run-directory)
735 (merge-pathnames "test-run-info.lisp"
736 test-run-directory))
737
5be7639 @avodonosov first commit
avodonosov authored
738 (defun save-run-info (test-run directory)
a8e8a13 @avodonosov Implemented online storage for libraries test logs, hosted on Google …
avodonosov authored
739 (let ((run-file (run-info-file directory)))
740 (write-to-file test-run run-file)))
741
742 (defun gae-blobstore-dir ()
743 (merge-pathnames "gae-blobstore/lisp-client/" test-grid-config:*src-base-dir*))
744
745 (defparameter *gae-blobstore-base-url* "http://cl-test-grid.appspot.com")
746
747 (defun get-blobstore ()
748 (pushnew (truename (gae-blobstore-dir)) asdf:*central-registry* :test #'equal)
4cea853 @avodonosov Use ql:quickload instead of asdf:operate when loading the GAE blobsto…
avodonosov authored
749 (ql:quickload '#:test-grid-gae-blobstore)
a8e8a13 @avodonosov Implemented online storage for libraries test logs, hosted on Google …
avodonosov authored
750 (funcall (intern (string '#:make-blob-store) '#:test-grid-gae-blobstore)
751 :base-url *gae-blobstore-base-url*))
752
753 (defun submit-logs (test-run-dir)
754 (let* ((blobstore (get-blobstore))
755 (run-info (safe-read-file (run-info-file test-run-dir)))
9dd75c2 @avodonosov data format: instead of storing librari name as a key for the library…
avodonosov authored
756 ;; prepare parameters for the SUBMIT-FILES blobstore function
757 (submit-params (mapcar #'(lambda (lib-result)
758 (let ((libname (getf lib-result :libname)))
759 (cons libname
760 (lib-log-file test-run-dir libname))))
761 (run-results run-info))))
762 ;; submit files to the blobstore and receive
763 ;; their blobkeys in response
764 (let ((libname-to-blobkey-alist
765 (test-grid-blobstore:submit-files blobstore
766 submit-params)))
a8e8a13 @avodonosov Implemented online storage for libraries test logs, hosted on Google …
avodonosov authored
767 ;; Now store the blobkeys for every library in the run-info.
768 ;; Note, we destructively modify parts of the previously
769 ;; read run-info.
770 (flet ((get-blob-key (lib)
771 (or (cdr (assoc lib libname-to-blobkey-alist))
9dd75c2 @avodonosov data format: instead of storing librari name as a key for the library…
avodonosov authored
772 (error "blobstore didn't returned blob key for the log of the ~A libary" lib))))
773 (setf (run-results run-info)
774 (mapcar #'(lambda (lib-result)
775 (setf (getf lib-result :log-blob-key)
776 (get-blob-key (getf lib-result :libname)))
777 lib-result)
778 (run-results run-info))))
779 ;; finally, save the updated run-info with blobkeys
780 ;; to the file. Returns the run-info.
781 (save-run-info run-info test-run-dir))))
782
5be7639 @avodonosov first commit
avodonosov authored
783 (defun run-libtests (&optional (libs *all-libs*))
784 (let* ((run-descr (make-run-descr))
785 (run-dir (run-directory run-descr))
786 (lib-results))
787 (ensure-directories-exist run-dir)
788 (dolist (lib libs)
789 (let ((lib-result (run-libtest lib)))
790 (save-lib-log lib (getf lib-result :output) run-dir)
791 (remf lib-result :output)
9dd75c2 @avodonosov data format: instead of storing librari name as a key for the library…
avodonosov authored
792 (push lib-result lib-results)))
5be7639 @avodonosov first commit
avodonosov authored
793 (setf (getf run-descr :run-duration)
794 (- (get-universal-time)
795 (getf run-descr :time)))
c023819 @avodonosov test run as plist (:descr <descr> :run-results <run-results>) instead…
avodonosov authored
796 (let ((run (make-run run-descr lib-results)))
5be7639 @avodonosov first commit
avodonosov authored
797 (save-run-info run run-dir)
9dd75c2 @avodonosov data format: instead of storing librari name as a key for the library…
avodonosov authored
798 (format t "The test results were saved to this directory: ~%~A.~%"
799 (truename run-dir))
5bffbe5 @avodonosov fixed regresson introduced when implementing GAE blobstore: the funct…
avodonosov authored
800 (format t "~%Submitting libraries test logs to the online blobstore...~%")
801 (handler-case
b279089 @avodonosov Fixed return value of the run-testlibs - if logs upload to the blobst…
avodonosov authored
802 (progn
803 (setf run (submit-logs run-dir))
5bffbe5 @avodonosov fixed regresson introduced when implementing GAE blobstore: the funct…
avodonosov authored
804 (format t "The log files are successfully uploaded to the online blobstore.
1195d22 @avodonosov Fix the last merge
avodonosov authored
805
696936b @avodonosov Added iterate and metabang-bind.
avodonosov authored
806 Please submit the test run results file
1195d22 @avodonosov Fix the last merge
avodonosov authored
807 ~A
696936b @avodonosov Added iterate and metabang-bind.
avodonosov authored
808 to the cl-test-grid issue tracker:
1195d22 @avodonosov Fix the last merge
avodonosov authored
809 https://github.com/cl-test-grid/cl-test-grid/issues
810
696936b @avodonosov Added iterate and metabang-bind.
avodonosov authored
811 (we are working on automating the test results upload).~%"
b279089 @avodonosov Fixed return value of the run-testlibs - if logs upload to the blobst…
avodonosov authored
812 (truename (run-info-file run-dir))))
5bffbe5 @avodonosov fixed regresson introduced when implementing GAE blobstore: the funct…
avodonosov authored
813 (t (e) (format t "Error occured while uploading the libraries test logs to the online store: ~A: ~A.
696936b @avodonosov Added iterate and metabang-bind.
avodonosov authored
814 Please submit manually the full content of the results directory
1195d22 @avodonosov Fix the last merge
avodonosov authored
815 ~A
696936b @avodonosov Added iterate and metabang-bind.
avodonosov authored
816 to the cl-test-grid issue tracker:
1195d22 @avodonosov Fix the last merge
avodonosov authored
817 https://github.com/cl-test-grid/cl-test-grid/issues~%"
5bffbe5 @avodonosov fixed regresson introduced when implementing GAE blobstore: the funct…
avodonosov authored
818 (type-of e)
819 e
820 (truename run-dir))))
821 (format t "~%Thank you for the participation!~%")
822 run)))
efe7ab8 @d35h added function get-user-email. reads from file if file is absent then…
d35h authored
823
5be7639 @avodonosov first commit
avodonosov authored
824 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
825 ;; Database
826 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
827 (defparameter *db* '(:version 0 :runs ()))
828
829 (defvar *standard-db-file*
830 (merge-pathnames "db.lisp"
831 test-grid-config:*src-base-dir*))
832
833 (defun add-run (run-info &optional (db *db*))
834 (push run-info (getf db :runs)))
835
85e3774 @avodonosov Store the reports generated in the repository, in the directory repor…
avodonosov authored
836 (defun save-db (&optional (db *db*) (stream-or-path *standard-db-file*))
5be7639 @avodonosov first commit
avodonosov authored
837 (with-open-file (out stream-or-path
838 :direction :output
839 :element-type 'character ;'(unsigned-byte 8) + flexi-stream
840 :if-exists :overwrite
841 :if-does-not-exist :create)
842 (write db :stream out)))
843
844 (defun read-db (&optional (stream-or-path *standard-db-file*))
845 (with-open-file (in stream-or-path
846 :direction :input
847 :element-type 'character ;'(unsigned-byte 8) + flexi-stream
848 )
849 (safe-read in)))
850
851 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
852 ;; Reports
853 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
854
855 (defun generate-fake-run-results ()
856 "Generate fake test run result enought to test our reports."
857 (flet ((random-status ()
858 (let ((r (random 1.0)))
859 (cond ((< r 0.43)
860 :ok)
861 ((< r 0.86)
862 :fail)
863 (t :no-resource)))))
864 (let ((runs '()))
865 (dolist (lisp '("sbcl-fake-1" "sbcl-fake-2" "clisp-fake-1" "ccl-fake-1" "abcl-fake-2"))
866 (dolist (lib-world '("quicklisp-fake-2011-00-01" "quicklisp-fake-2011-00-02" "quicklisp-fake-2011-00-03"))
867 (let ((run-descr (list :lisp lisp
868 :lib-world lib-world
869 :time (get-universal-time)
870 :run-duration (+ 100 (random 90))
871 :contact (list :email
872 (nth (random 3) '("avodonosov@yandex.ru"
873 "other-user@gmail.com"
874 "foo@gmail.com")))))
875 (lib-results '()))
876 (dolist (lib *all-libs*)
9dd75c2 @avodonosov data format: instead of storing librari name as a key for the library…
avodonosov authored
877 (push (list :libname lib :status (random-status) :log-char-length 50)
878 lib-results))
c023819 @avodonosov test run as plist (:descr <descr> :run-results <run-results>) instead…
avodonosov authored
879 (push (make-run run-descr lib-results) runs))))
5be7639 @avodonosov first commit
avodonosov authored
880 runs)))
881
00e5da5 @avodonosov more correct name for the summary-table report: test-runs-report
avodonosov authored
882 (defvar *test-runs-report-template*
883 (merge-pathnames "test-runs-report-template.html"
5be7639 @avodonosov first commit
avodonosov authored
884 test-grid-config:*src-base-dir*))
00e5da5 @avodonosov more correct name for the summary-table report: test-runs-report
avodonosov authored
885
5be7639 @avodonosov first commit
avodonosov authored
886 (defun vertical-html (libname)
887 (let ((maybeBr "")
888 (libname (string libname)))
889 (with-output-to-string (out)
890 (loop for char across libname
891 do (princ maybeBr out)
892 (princ (if (char= char #\-) #\| char) out)
893 (setf maybeBr "<br/>")))))
894
895 ;; example:
896 #|
897 (string= (vertical-html "cl-abc")
898 "c<br/>l<br/>|<br/>a<br/>b<br/>c")
899 |#
900
ec59872 @avodonosov TODO comment about finalizing the terminology about our main data obj…
avodonosov authored
901 ;; todo: this should be a blobstore method, but
902 ;; until we move the reporting to a separate
903 ;; asdf system, we don't want the dependency
904 ;; on blobstore here.
905 (defun blob-uri (blob-key)
906 (format nil "~A/blob?key=~A"
907 *gae-blobstore-base-url* blob-key))
908
909 (defun lib-log-local-uri (test-run lib-result)
910 (format nil "file://~A~A"
5be7639 @avodonosov first commit
avodonosov authored
911 (run-directory (run-descr test-run))
ec59872 @avodonosov TODO comment about finalizing the terminology about our main data obj…
avodonosov authored
912 (string-downcase (getf lib-result :libname))))
913
914 (defun lib-log-uri (test-run lib-result)
e75f5e9 @avodonosov Avoid compile warning about unused variable.
avodonosov authored
915 (declare (ignore test-run))
ec59872 @avodonosov TODO comment about finalizing the terminology about our main data obj…
avodonosov authored
916 (let ((blob-key (getf lib-result :log-blob-key)))
917 (if blob-key
918 (blob-uri blob-key)
919 "javascript:alert('The blobstore key is not specified, seems like the library log was not submitted to the online storage')")))
5be7639 @avodonosov first commit
avodonosov authored
920
921 (defun single-letter-status (normalized-status)
922 (case normalized-status
923 (:ok "O")
924 (:fail "F")
925 (:no-resource "R")
926 (otherwise normalized-status)))
927
928 (defun status-css-class (normalized-status)
929 (case normalized-status
930 (:ok "ok-status")
931 (:fail "fail-status")
932 (:no-resource "no-resource-status")
933 (otherwise "")))
49f4d4c @d35h add function export-to-csv
d35h authored
934
9dd75c2 @avodonosov data format: instead of storing librari name as a key for the library…
avodonosov authored
935 (defun render-single-letter-status (test-run lib-test-result)
cd2a46d @avodonosov test runs report: if a library wasn't run in particulare test run, re…
avodonosov authored
936 (if (null lib-test-result)
937 "&nbsp;"
938 (let ((status (normalize-status (getf lib-test-result :status))))
939 (format nil "<a class=\"test-status ~A\" href=\"~A\">~A</a>"
940 (status-css-class status)
941 (lib-log-uri test-run lib-test-result)
942 (single-letter-status status)))))
5be7639 @avodonosov first commit
avodonosov authored
943
5f37895 @avodonosov more correct name for the summary-table report: test-runs-report
avodonosov authored
944 (defun test-runs-table-html (&optional
945 (db *db*)
946 (status-renderer 'render-single-letter-status))
5be7639 @avodonosov first commit
avodonosov authored
947 (with-output-to-string (out)
948 (write-line "<table cellspacing=\"1\" class=\"tablesorter\">" out)
949
b94ab6b @avodonosov test runs report: added Start Time column.
avodonosov authored
950 (princ "<thead><tr style=\"vertical-align: bottom;\"><th>Start Time</th><th>Lib World</th><th>Lisp</th><th>Runner</th>" out)
5be7639 @avodonosov first commit
avodonosov authored
951 (dolist (lib *all-libs*)
952 (format out "<th>~A</th>" (vertical-html lib)))
953 (write-line "</tr></thead>" out)
954
955 (write-line "<tbody>" out)
956 (dolist (run (getf db :runs))
957 (let ((run-descr (run-descr run))
958 (lib-statuses (run-results run)))
b94ab6b @avodonosov test runs report: added Start Time column.
avodonosov authored
959 (format out "<tr><td>~A</td><td>~A</td><td>~A</td><td>~A</td>"
0a04998 @avodonosov Clarified a little bit more the comment about why hunchentoot is not …
avodonosov authored
960 (pretty-fmt-time (getf run-descr :time))
9dd75c2 @avodonosov data format: instead of storing librari name as a key for the library…
avodonosov authored
961 (getf run-descr :lib-world)
962 (getf run-descr :lisp)
963 (getf (getf run-descr :contact) :email))
964 (dolist (lib *all-libs*)
965 (format out "<td>~A</td>"
966 (funcall status-renderer run (find lib lib-statuses
967 :key (getter :libname)))))
968 (write-line "</tr>" out)))
5be7639 @avodonosov first commit
avodonosov authored
969 (write-line "</tbody>" out)
970 (write-line "</table>" out)))
971
5f37895 @avodonosov more correct name for the summary-table report: test-runs-report
avodonosov authored
972 (defun fmt-test-runs-report (html-table)
00e5da5 @avodonosov more correct name for the summary-table report: test-runs-report
avodonosov authored
973 (let* ((template (file-string *test-runs-report-template*))
5be7639 @avodonosov first commit
avodonosov authored
974 (placeholder "{THE-TABLE}")
975 (pos (or (search placeholder template)
ccf71e3 @avodonosov Fixed one forgotten *report-template* variable after it was renamed t…
avodonosov authored
976 (error "Can't find the placeholder ~A in the report template file ~A" placeholder *test-runs-report-template*))))
5be7639 @avodonosov first commit
avodonosov authored
977 (concatenate 'string
978 (subseq template 0 pos)
979 html-table
980 (subseq template (+ pos (length placeholder))))))
981
5f37895 @avodonosov more correct name for the summary-table report: test-runs-report
avodonosov authored
982 (defun test-runs-report (&optional (db *db*))
983 (fmt-test-runs-report (test-runs-table-html db)))
984
9dd75c2 @avodonosov data format: instead of storing librari name as a key for the library…
avodonosov authored
985 (defun export-to-csv (out &optional (db *db*))
d88a518 @d35h finally finished function get-user-email, added new property in resul…
d35h authored
986 (format out "Lib World,Lisp,Runner,LibName,Status,TestDuration~%")
49f4d4c @d35h add function export-to-csv
d35h authored
987 (dolist (run (getf db :runs))
9dd75c2 @avodonosov data format: instead of storing librari name as a key for the library…
avodonosov authored
988 (let ((run-descr (run-descr run)))
989 (dolist (lib-result (run-results run))
d88a518 @d35h finally finished function get-user-email, added new property in resul…
d35h authored
990 (format out "~a,~a,~a,~a,~a,~a~%"
9dd75c2 @avodonosov data format: instead of storing librari name as a key for the library…
avodonosov authored
991 (getf run-descr :lib-world)
992 (getf run-descr :lisp)
993 (getf (getf run-descr :contact) :email)
994 (string-downcase (getf lib-result :libname))
d88a518 @d35h finally finished function get-user-email, added new property in resul…
d35h authored
995 (getf lib-result :status)
996 (getf lib-result :test-duration))))))
49f4d4c @d35h add function export-to-csv
d35h authored
997
fa1c4e1 @avodonosov Pivot reports. First working version; no comments, data cell is rende…
avodonosov authored
998 ;; ========= Pivot Reports ==================
999
1000 (defun build-joined-index (db)
1001 (let ((all-results (make-hash-table :test 'equal)))
1002 (dolist (run (getf db :runs))
1003 (let* ((run-descr (run-descr run))
1004 (lisp (getf run-descr :lisp))
1005 (lib-world (getf run-descr :lib-world)))
1006 (dolist (lib-result (run-results run))
1007 (let ((libname (getf lib-result :libname)))
1008 (push lib-result
1009 (gethash (list lisp lib-world libname) all-results))))))
1010 all-results))
1011
1012
1013 #|
1014 HTML table properties:
1015 - rows and cols are not equal: html tables are row-first - TR includes TDs
1016
1017 Only the deepest level row and col fields will have corresponding
1018 TR and TD cells in the table data (we do not consider the table
1019 column headers now).
1020
1021 And the TD cells are included in a TR.
1022
1023 Algorithm sketch:
1024 Iterate over all row properties and their values in rows.
1025 For every deepest level combination create a TR (if
1026 any values exist for this combination).
1027
1028 Iterate over all the col properties and their values.
1029 For every deepest level combination create a TD.
1030
1031 partitioning structure
1032 -----------------------------
1033 field1 | field2
1034 -----------------------------
1035 field1 val1 (count)
1036 field2 val1 (count)
1037 field2 val2 (count)
1038 field1 val2 (count)
1039 field2 val1 (count)
1040 field2 val3 (count)
1041 field1 val3 (count)
1042 field2 val2 (count)
1043
1044
1045 <tr> <td> <td> <td>
1046 <tr> <td> <td>
1047 <tr> <td>
1048 <tr> <td> <td>
1049 <tr> <td> <td>
1050 <tr> <td>
1051 <tr> <td> <td> <td>
1052 <tr> <td> <td>
1053 <tr> <td> <td> <td>
1054 <tr> <td> <td>
1055 <tr> <td>
1056
1057 |#
1058
1059 (defun make-fields-values-setter (fields)
1060 "Creates a function which destructively modifies
1061 the specified fields in the index key passed to it
1062 as a parameter"
1063 (let ((index-key-setters (list :lisp #'(lambda (index-key lisp)
1064 (setf (first index-key) lisp))
1065 :lib-world #'(lambda (index-key lib-world)
1066 (setf (second index-key) lib-world))
1067 :libname #'(lambda (index-key libname)
1068 (setf (third index-key) libname)))))
1069 (flet ((field-setter (field)
1070 (or (getf index-key-setters field)
1071 (error "field ~A is unknown" field))))
1072 (let ((setters (mapcar #'field-setter fields)))
1073 #'(lambda (index-key field-vals)
1074 (mapc #'(lambda (setter field-val)
1075 (funcall setter index-key field-val))
1076 setters
1077 field-vals)
1078 index-key)))))
1079
1080 (defun make-fields-values-getter (fields)
1081 (let ((index-key-getters (list :lisp #'first
1082 :lib-world #'second
1083 :libname #'third)))
1084 (flet ((field-getter (field)
1085 (or (getf index-key-getters field)
1086 (error "field ~A is unknown" field))))
1087 (let ((getters (mapcar #'field-getter fields)))
1088 #'(lambda (index-key)
1089 (mapcar #'(lambda (getter)
1090 (funcall getter index-key))
1091 getters))))))
1092
1093 (defun calc-rows-and-cols (joined-index rows-fields cols-fields)
1094 (let ((rows-fields-getter (make-fields-values-getter rows-fields))
1095 (rows-fields-setter (make-fields-values-setter rows-fields))
1096 (rows (make-hash-table :test #'equal))
1097 (cols-fields-getter (make-fields-values-getter cols-fields))
1098 (cols-fields-setter (make-fields-values-setter cols-fields))
1099 (cols (make-hash-table :test #'equal)))
1100 (maphash #'(lambda (index-key index-value)
1101 (declare (ignore index-value))
1102 (setf (gethash (funcall rows-fields-getter index-key)
1103 rows)
1104 t)
1105 (setf (gethash (funcall cols-fields-getter index-key)
1106 cols)
1107 t))
1108 joined-index)
1109 (values (hash-table-keys rows)
1110 (hash-table-keys cols)
1111 #'(lambda (index-key row-addr col-addr)
1112 (funcall rows-fields-setter index-key row-addr)
1113 (funcall cols-fields-setter index-key col-addr)))))
1114
1115 (defstruct (header-print-helper :conc-name)
1116 (span 0 :type fixnum)
1117 (printed nil))
1118
1119 (defun subaddrs (row-address)
1120 (nreverse (maplist #'reverse (reverse row-address))))
1121
1122 (defun calc-spans (row-or-col-addrs)
1123 (let ((helpers (make-hash-table :test #'equal)))
1124 (dolist (row-or-col-addr row-or-col-addrs)
1125 (dolist (subaddr (subaddrs row-or-col-addr))
1126 (let ((helper (or (gethash subaddr helpers)
1127 (setf (gethash subaddr helpers)
1128 (make-header-print-helper)))))
1129 (incf (span helper)))))
1130 helpers))
1131
1132 (defun print-row-header (row-addr row-spans out)
1133 (dolist (subaddr (subaddrs row-addr))
1134 (let ((helper (gethash subaddr row-spans)))
1135 (when (not (printed helper))
1136 (format out "<td rowspan=\"~A\">~A</td>" (span helper) (car (last subaddr)))
1137 (setf (printed helper) t)))))
1138
1139 (defun print-table-headers (row-field-count col-field-count cols out)
1140 (let ((col-spans (calc-spans cols)))
1141 (dotimes (header-row-num col-field-count)
1142 (princ "<tr>" out)
1143 (dotimes (row-header row-field-count)
1144 (princ "<td>&nbsp;</td>" out))
1145 (dolist (col-addr cols)
1146 (let* ((cell-addr (subseq col-addr 0 (1+ header-row-num)))
1147 (helper (gethash cell-addr col-spans)))
1148 (when (not (printed helper))
1149 (format out "<td colspan=\"~A\">~A</td>" (span helper) (car (last cell-addr)))
1150 (setf (printed helper) t))))
1151 (format out "</tr>~%"))))
1152
1153 (defun pivot-table-html (out
1154 joined-index
1155 row-fields row-fields-sort-predicates
1156 col-fields col-fields-sort-predicates)
1157 (princ "<table border=\"1\">" out)
1158 (let (rows
1159 cols
1160 index-key-setter
1161 (row-comparator #'(lambda (rowa rowb)
1162 (list< row-fields-sort-predicates
1163 rowa rowb)))
1164 (col-comparator #'(lambda (cola colb)
1165 (list< col-fields-sort-predicates
1166 cola colb))))
1167
1168 (setf (values rows cols index-key-setter)
1169 (calc-rows-and-cols joined-index row-fields col-fields))
1170
1171 (setf rows (sort rows row-comparator)
1172 cols (sort cols col-comparator))
1173
1174 (print-table-headers (length row-fields) (length col-fields) cols out)
1175 (let ((row-spans (calc-spans rows))
1176 (index-key (make-sequence 'list (+ (length row-fields)
1177 (length col-fields)))))
1178 (dolist (row rows)
1179 (princ "<tr>" out)
1180 (print-row-header row row-spans out)
1181 (dolist (col cols)
1182 (funcall index-key-setter index-key row col)
1183 (let ((data (gethash index-key joined-index)))
1184 (format out "<td>~A</td>" data)))
1185 (format out "</tr>~%"))))
1186 (princ "</table>" out))
1187
1188 (defun print-pivot-reports (db)
1189 (let ((joined-index (build-joined-index db))
1190 (reports-dir (reports-dir)))
1191 (flet ((print-report (filename
1192 row-fields row-fields-sort-predicates
1193 col-fields col-fields-sort-predicates)
1194 (with-open-file (out (merge-pathnames filename reports-dir)
1195 :direction :output
1196 :element-type 'character ;'(unsigned-byte 8) + flexi-stream
1197 :if-exists :supersede
1198 :if-does-not-exist :create)
1199 (pivot-table-html out
1200 joined-index
1201 row-fields row-fields-sort-predicates
1202 col-fields col-fields-sort-predicates))))
1203
1204 (print-report "pivot_ql_lisp-lib.html"
1205 '(:lib-world) (list #'string<)
1206 '(:lisp :libname) (list #'string< #'string<))
1207 (print-report "pivot_ql_lib-lisp.html"
1208 '(:lib-world) (list #'string<)
1209 '(:libname :lisp) (list #'string< #'string<))
1210
1211 (print-report "pivot_lisp_lib-ql.html"
1212 '(:lisp) (list #'string<)
1213 '(:libname :lib-world) (list #'string< #'string<))
1214 (print-report "pivot_lisp_ql-lib.html"
1215 '(:lisp) (list #'string<)
1216 '(:lib-world :libname) (list #'string< #'string<))
1217
1218 (print-report "pivot_lib_lisp-ql.html"
1219 '(:libname) (list #'string<)
1220 '(:lisp :lib-world) (list #'string< #'string<))
1221 (print-report "pivot_lib_ql-lisp.html"
1222 '(:libname) (list #'string<)
1223 '(:lib-world :lisp) (list #'string< #'string<))
1224
1225 (print-report "pivot_ql-lisp_lib.html"
1226 '(:lib-world :lisp) (list #'string<)
1227 '(:libname) (list #'string< #'string<))
1228 (print-report "pivot_ql-lib_lisp.html"
1229 '(:lib-world :libname) (list #'string<)
1230 '(:lisp) (list #'string< #'string<))
1231
1232 (print-report "pivot_lisp-lib_ql.html"
1233 '(:lisp :libname) (list #'string<)
1234 '(:lib-world) (list #'string< #'string<))
1235 (print-report "pivot_lisp-ql_lib.html"
1236 '(:lisp :lib-world) (list #'string<)
1237 '(:libname) (list #'string< #'string<))
1238
1239 (print-report "pivot_lib-lisp_ql.html"
1240 '(:libname :lisp) (list #'string<)
1241 '(:lib-world) (list #'string< #'string<))
1242 (print-report "pivot_lib-ql_lisp.html"
1243 '(:libname :lib-world) (list #'string<)
1244 '(:lisp) (list #'string< #'string<)))))
1245
85e3774 @avodonosov Store the reports generated in the repository, in the directory repor…
avodonosov authored
1246 (defun generate-reports (&optional (db *db*))
1247
1248 (with-open-file (out (merge-pathnames "test-runs-report.html"
1249 (reports-dir))
1250 :direction :output
1251 :if-exists :supersede
1252 :if-does-not-exist :create)
d88a518 @d35h finally finished function get-user-email, added new property in resul…
d35h authored
1253 (write-sequence (test-runs-report db) out))
85e3774 @avodonosov Store the reports generated in the repository, in the directory repor…
avodonosov authored
1254
1255 (with-open-file (out (merge-pathnames "export.csv"
1256 (reports-dir))
1257 :direction :output
1258 :if-exists :supersede
1259 :if-does-not-exist :create)
fa1c4e1 @avodonosov Pivot reports. First working version; no comments, data cell is rende…
avodonosov authored
1260 (export-to-csv out))
1261
1262 (print-pivot-reports db))
85e3774 @avodonosov Store the reports generated in the repository, in the directory repor…
avodonosov authored
1263
1264 (defun reports-dir ()
1265 (merge-pathnames "reports-generated/"
1266 test-grid-config:*src-base-dir*))
1267
5be7639 @avodonosov first commit
avodonosov authored
1268 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1269
1270 #|
1271
1272 Quicklisp download statistics:
1273
1274 http://blog.quicklisp.org/2010/11/project-download-statistics.html
1275
696936b @avodonosov Added iterate and metabang-bind.
avodonosov authored
1276 colunmns: download count, has common-lisp test suite (as of quicklisp 2011-07-30).
5be7639 @avodonosov first commit
avodonosov authored
1277
1278 714 + alexandria
1279 596 + babel
1280 520 + trivial-features
1281 503 + cffi
1282 450 + cl-ppcre
1283 423 - trivial-gray-streams
1284 404 + usocket
1285 403 + flexi-streams
1286 398 + bordeaux-threads
1287 393 - slime
4055e27 @avodonosov Added cl-base64 to the tests.
avodonosov authored
1288 386 - cl+ssl (thre is a test.lisp, but it's not automated, and no (asdf:operate (op asdf:test-op) ...)
1289 371 - chunga
1290 370 + cl-base64
7ab792d @avodonosov Added trivial-backtrace to the tests. (Always fails; it tries to crea…
avodonosov authored
1291 361 - cl-fad
1292 339 - md5
1293 327 - quicklisp-slime-helper
1294 323 + trivial-backtrace
1639b53 @avodonosov Added puri. A typo fixed in the LIBTEST for trivial-backtrace. Decide…
avodonosov authored
1295 321 - rfc2388 (there is a test.lisp, but there is no asdf:test-op, and the code in test.lisp
7ab792d @avodonosov Added trivial-backtrace to the tests. (Always fails; it tries to crea…
avodonosov authored
1296 doesn't return fail/ok status, it jsut prints something to the console)
0a04998 @avodonosov Clarified a little bit more the comment about why hunchentoot is not …
avodonosov authored
1297 317 - hunchentoot (there are tests and asdf:test-op, but I am affrait it might take
7622116 @avodonosov Clarified a little the comment about why hunchentoot is not included.
avodonosov authored
1298 lot of work to automate it: test-op starts server and doesn't
0a04998 @avodonosov Clarified a little bit more the comment about why hunchentoot is not …
avodonosov authored
1299 stop; I am also afraid it might hang sometimes; implementation
1639b53 @avodonosov Added puri. A typo fixed in the LIBTEST for trivial-backtrace. Decide…
avodonosov authored
1300 would also require checking for single-threaded lisps
1301 (by hunchentoot::*supports-threadss-p* ?)
7622116 @avodonosov Clarified a little the comment about why hunchentoot is not included.
avodonosov authored
1302 and returning :no-resource. Leave hunchentoot for a later
1639b53 @avodonosov Added puri. A typo fixed in the LIBTEST for trivial-backtrace. Decide…
avodonosov authored
1303 stage)
1304 293 - salza2
1305 289 + puri
1d6be7b @avodonosov Added anaphora
avodonosov authored
1306 285 - closer-mop (no asdf:test-op. there is a folder "test" with some file jeffs-code.lisp,
1307 but it's a code to reproduce some particular issue. It does not seem
1308 to be intended for automated regression testing of closer-mop)
1309 225 + anaphora
44b1c75 @avodonosov Added parenscript
avodonosov authored
1310 224 + parenscript
d7c17f3 @avodonosov Added trivial-garbage.
avodonosov authored
1311 221 - cl-who
1312 207 + trivial-garbage
696936b @avodonosov Added iterate and metabang-bind.
avodonosov authored
1313 201 + iterate
1314 193 - cl-vectors
1315 190 - zpng
1316 177 - asdf-system-connections
1317 174 - zpb-ttf
1318 173 + uffi But the test suite is non trivial (for example, it defines asdf:compile-op
1319 for C files using make). Probably that's why quickisp does not
1320 make the uffi-tests.asd availabel for ql:quickload. A study is needed about
1321 how to include this system, therefore I avoid it for now.
1322 173 + metabang-bind
1323 170 - split-sequence
1324 164 - vecto (there is a test.lisp, but it's not automated, intended for manual run and eye-testing of the resulting images)
1325 163 + cl-json
d4fc132 @avodonosov added cl-json
avodonosov authored
1326 ------------------------ << I am here
696936b @avodonosov Added iterate and metabang-bind.
avodonosov authored
1327 162 + cl-containers
1328 161 + metatilities-base
1329 159 - fare-utils
1330 156 + weblocks (do these tests start hunchentoot? seems no, it creates mock objects for request, response, etc.)
d4fc132 @avodonosov added cl-json
avodonosov authored
1331 156 - fare-matcher (no test-op, but there is fare-matcher-test.asd with one test defined using stefil)
696936b @avodonosov Added iterate and metabang-bind.
avodonosov authored
1332 148 - drakma
1333 144 + cl-cont
1334 143 - closure-common
1335 140 + moptilities
1336 138 - f-underscore
1337 137 + trivial-timeout
1338 136 + metatilities
1339 135 + clsql (big test suite, requires database server(s). Runs test on the
1340 DB servers you specified in the configiration. Therefore
1341 we need to think how to represent results - we can't
1342 just collect results under the same name "clsql", because
d4fc132 @avodonosov added cl-json
avodonosov authored
1343 different agents might have tested different servers.
1344 Conclusion: very useful test suite to include into
1345 our test set, but we will do it later).
696936b @avodonosov Added iterate and metabang-bind.
avodonosov authored
1346 133 + cxml (but how to run it? seems like it requires some .xml
1347 files which are not in the repository, so it probably
1348 is not fully automated).
5be7639 @avodonosov first commit
avodonosov authored
1349 |#
Something went wrong with that request. Please try again.