0000: 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;;==============
0010: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0020: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0030: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0040: 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 43 6f 70 79 ========.;; Copy
0050: 72 69 67 68 74 20 32 30 30 36 2d 32 30 31 33 2c right 2006-2013,
0060: 20 4d 61 74 74 68 65 77 20 57 65 6c 6c 61 6e 64 Matthew Welland
0070: 2e 0a 3b 3b 20 0a 3b 3b 20 20 54 68 69 73 20 70 ..;; .;; This p
0080: 72 6f 67 72 61 6d 20 69 73 20 6d 61 64 65 20 61 rogram is made a
0090: 76 61 69 6c 61 62 6c 65 20 75 6e 64 65 72 20 74 vailable under t
00a0: 68 65 20 47 4e 55 20 47 50 4c 20 76 65 72 73 69 he GNU GPL versi
00b0: 6f 6e 20 32 2e 30 20 6f 72 0a 3b 3b 20 20 67 72 on 2.0 or.;; gr
00c0: 65 61 74 65 72 2e 20 53 65 65 20 74 68 65 20 61 eater. See the a
00d0: 63 63 6f 6d 70 61 6e 79 69 6e 67 20 66 69 6c 65 ccompanying file
00e0: 20 43 4f 50 59 49 4e 47 20 66 6f 72 20 64 65 74 COPYING for det
00f0: 61 69 6c 73 2e 0a 3b 3b 20 0a 3b 3b 20 20 54 68 ails..;; .;; Th
0100: 69 73 20 70 72 6f 67 72 61 6d 20 69 73 20 64 69 is program is di
0110: 73 74 72 69 62 75 74 65 64 20 57 49 54 48 4f 55 stributed WITHOU
0120: 54 20 41 4e 59 20 57 41 52 52 41 4e 54 59 3b 20 T ANY WARRANTY;
0130: 77 69 74 68 6f 75 74 20 65 76 65 6e 20 74 68 65 without even the
0140: 0a 3b 3b 20 20 69 6d 70 6c 69 65 64 20 77 61 72 .;; implied war
0150: 72 61 6e 74 79 20 6f 66 20 4d 45 52 43 48 41 4e ranty of MERCHAN
0160: 54 41 42 49 4c 49 54 59 20 6f 72 20 46 49 54 4e TABILITY or FITN
0170: 45 53 53 20 46 4f 52 20 41 20 50 41 52 54 49 43 ESS FOR A PARTIC
0180: 55 4c 41 52 0a 3b 3b 20 20 50 55 52 50 4f 53 45 ULAR.;; PURPOSE
0190: 2e 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ..;;============
01a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
01b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
01c0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
01d0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 3b 3b 3d 3d ==========..;;==
01e0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
01f0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0200: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0210: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0220: 3d 3d 3d 3d 0a 3b 3b 20 54 65 73 74 73 0a 3b 3b ====.;; Tests.;;
0230: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0240: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0250: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0260: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0270: 3d 3d 3d 3d 3d 3d 0a 0a 28 75 73 65 20 73 71 6c ======..(use sql
0280: 69 74 65 33 20 73 72 66 69 2d 31 20 70 6f 73 69 ite3 srfi-1 posi
0290: 78 20 72 65 67 65 78 20 72 65 67 65 78 2d 63 61 x regex regex-ca
02a0: 73 65 20 73 72 66 69 2d 36 39 20 64 6f 74 2d 6c se srfi-69 dot-l
02b0: 6f 63 6b 69 6e 67 20 74 63 70 20 64 69 72 65 63 ocking tcp direc
02c0: 74 6f 72 79 2d 75 74 69 6c 73 29 0a 28 69 6d 70 tory-utils).(imp
02d0: 6f 72 74 20 28 70 72 65 66 69 78 20 73 71 6c 69 ort (prefix sqli
02e0: 74 65 33 20 73 71 6c 69 74 65 33 3a 29 29 0a 28 te3 sqlite3:)).(
02f0: 72 65 71 75 69 72 65 2d 6c 69 62 72 61 72 79 20 require-library
0300: 73 74 6d 6c 29 0a 0a 28 64 65 63 6c 61 72 65 20 stml)..(declare
0310: 28 75 6e 69 74 20 74 65 73 74 73 29 29 0a 28 64 (unit tests)).(d
0320: 65 63 6c 61 72 65 20 28 75 73 65 73 20 6c 6f 63 eclare (uses loc
0330: 6b 2d 71 75 65 75 65 29 29 0a 28 64 65 63 6c 61 k-queue)).(decla
0340: 72 65 20 28 75 73 65 73 20 64 62 29 29 0a 28 64 re (uses db)).(d
0350: 65 63 6c 61 72 65 20 28 75 73 65 73 20 74 64 62 eclare (uses tdb
0360: 29 29 0a 28 64 65 63 6c 61 72 65 20 28 75 73 65 )).(declare (use
0370: 73 20 63 6f 6d 6d 6f 6e 29 29 0a 3b 3b 20 28 64 s common)).;; (d
0380: 65 63 6c 61 72 65 20 28 75 73 65 73 20 64 63 6f eclare (uses dco
0390: 6d 6d 6f 6e 29 29 20 3b 3b 20 6e 65 65 64 65 64 mmon)) ;; needed
03a0: 20 66 6f 72 20 74 68 65 20 73 74 65 70 73 20 70 for the steps p
03b0: 72 6f 63 65 73 73 69 6e 67 0a 28 64 65 63 6c 61 rocessing.(decla
03c0: 72 65 20 28 75 73 65 73 20 69 74 65 6d 73 29 29 re (uses items))
03d0: 0a 28 64 65 63 6c 61 72 65 20 28 75 73 65 73 20 .(declare (uses
03e0: 72 75 6e 63 6f 6e 66 69 67 29 29 0a 3b 3b 20 28 runconfig)).;; (
03f0: 64 65 63 6c 61 72 65 20 28 75 73 65 73 20 73 64 declare (uses sd
0400: 62 29 29 0a 28 64 65 63 6c 61 72 65 20 28 75 73 b)).(declare (us
0410: 65 73 20 73 65 72 76 65 72 29 29 0a 0a 28 69 6e es server))..(in
0420: 63 6c 75 64 65 20 22 63 6f 6d 6d 6f 6e 5f 72 65 clude "common_re
0430: 63 6f 72 64 73 2e 73 63 6d 22 29 0a 28 69 6e 63 cords.scm").(inc
0440: 6c 75 64 65 20 22 6b 65 79 5f 72 65 63 6f 72 64 lude "key_record
0450: 73 2e 73 63 6d 22 29 0a 28 69 6e 63 6c 75 64 65 s.scm").(include
0460: 20 22 64 62 5f 72 65 63 6f 72 64 73 2e 73 63 6d "db_records.scm
0470: 22 29 0a 28 69 6e 63 6c 75 64 65 20 22 72 75 6e ").(include "run
0480: 5f 72 65 63 6f 72 64 73 2e 73 63 6d 22 29 0a 28 _records.scm").(
0490: 69 6e 63 6c 75 64 65 20 22 74 65 73 74 5f 72 65 include "test_re
04a0: 63 6f 72 64 73 2e 73 63 6d 22 29 0a 0a 3b 3b 20 cords.scm")..;;
04b0: 43 61 6c 6c 20 74 68 69 73 20 6f 6e 65 20 74 6f Call this one to
04c0: 20 64 6f 20 61 6c 6c 20 74 68 65 20 77 6f 72 6b do all the work
04d0: 20 61 6e 64 20 67 65 74 20 61 20 73 74 61 6e 64 and get a stand
04e0: 61 72 64 69 7a 65 64 20 6c 69 73 74 20 6f 66 20 ardized list of
04f0: 74 65 73 74 73 0a 3b 3b 20 20 20 67 65 74 73 20 tests.;; gets
0500: 70 61 74 68 73 20 66 72 6f 6d 20 63 6f 6e 66 69 paths from confi
0510: 67 73 20 61 6e 64 20 66 69 6e 64 73 20 76 61 6c gs and finds val
0520: 69 64 20 74 65 73 74 73 20 0a 3b 3b 20 20 20 72 id tests .;; r
0530: 65 74 75 72 6e 73 20 68 61 73 68 20 6f 66 20 74 eturns hash of t
0540: 65 73 74 6e 61 6d 65 20 2d 2d 3e 20 66 75 6c 6c estname --> full
0550: 70 61 74 68 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 path.;;.(define
0560: 28 74 65 73 74 73 3a 67 65 74 2d 61 6c 6c 29 0a (tests:get-all).
0570: 20 20 28 6c 65 74 2a 20 28 28 74 65 73 74 2d 73 (let* ((test-s
0580: 65 61 72 63 68 2d 70 61 74 68 20 20 20 28 74 65 earch-path (te
0590: 73 74 73 3a 67 65 74 2d 74 65 73 74 73 2d 73 65 sts:get-tests-se
05a0: 61 72 63 68 2d 70 61 74 68 20 2a 63 6f 6e 66 69 arch-path *confi
05b0: 67 64 61 74 2a 29 29 29 0a 20 20 20 20 28 74 65 gdat*))). (te
05c0: 73 74 73 3a 67 65 74 2d 76 61 6c 69 64 2d 74 65 sts:get-valid-te
05d0: 73 74 73 20 28 6d 61 6b 65 2d 68 61 73 68 2d 74 sts (make-hash-t
05e0: 61 62 6c 65 29 20 74 65 73 74 2d 73 65 61 72 63 able) test-searc
05f0: 68 2d 70 61 74 68 29 29 29 0a 0a 28 64 65 66 69 h-path)))..(defi
0600: 6e 65 20 28 74 65 73 74 73 3a 67 65 74 2d 74 65 ne (tests:get-te
0610: 73 74 73 2d 73 65 61 72 63 68 2d 70 61 74 68 20 sts-search-path
0620: 63 66 67 64 61 74 29 0a 20 20 28 6c 65 74 20 28 cfgdat). (let (
0630: 28 70 61 74 68 73 20 28 6c 65 74 20 28 28 73 65 (paths (let ((se
0640: 63 74 69 6f 6e 20 28 69 66 20 63 66 67 64 61 74 ction (if cfgdat
0650: 0a 09 09 09 09 20 20 28 63 6f 6e 66 69 67 66 3a ..... (configf:
0660: 67 65 74 2d 73 65 63 74 69 6f 6e 20 63 66 67 64 get-section cfgd
0670: 61 74 20 22 74 65 73 74 73 2d 70 61 74 68 73 22 at "tests-paths"
0680: 29 0a 09 09 09 09 20 20 23 66 29 29 29 0a 09 09 )..... #f)))...
0690: 20 28 69 66 20 73 65 63 74 69 6f 6e 0a 09 09 20 (if section...
06a0: 20 20 20 20 28 6d 61 70 20 63 61 64 72 20 73 65 (map cadr se
06b0: 63 74 69 6f 6e 29 0a 09 09 20 20 20 20 20 27 28 ction)... '(
06c0: 29 29 29 29 29 0a 20 20 20 20 28 66 69 6c 74 65 ))))). (filte
06d0: 72 20 28 6c 61 6d 62 64 61 20 28 64 29 0a 09 20 r (lambda (d)..
06e0: 20 20 20 20 20 28 69 66 20 28 64 69 72 65 63 74 (if (direct
06f0: 6f 72 79 2d 65 78 69 73 74 73 3f 20 64 29 0a 09 ory-exists? d)..
0700: 09 20 20 64 0a 09 09 20 20 28 62 65 67 69 6e 0a . d... (begin.
0710: 09 09 20 20 20 20 28 69 66 20 28 63 6f 6d 6d 6f .. (if (commo
0720: 6e 3a 6c 6f 77 2d 6e 6f 69 73 65 2d 70 72 69 6e n:low-noise-prin
0730: 74 20 36 30 20 22 74 65 73 74 73 3a 67 65 74 2d t 60 "tests:get-
0740: 74 65 73 74 73 2d 73 65 61 72 63 68 2d 70 61 74 tests-search-pat
0750: 68 22 20 64 29 0a 09 09 09 28 64 65 62 75 67 3a h" d)....(debug:
0760: 70 72 69 6e 74 20 30 20 2a 64 65 66 61 75 6c 74 print 0 *default
0770: 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 57 41 52 4e -log-port* "WARN
0780: 49 4e 47 3a 20 70 72 6f 62 6c 65 6d 20 77 69 74 ING: problem wit
0790: 68 20 64 69 72 65 63 74 6f 72 79 20 22 20 64 20 h directory " d
07a0: 22 2c 20 64 72 6f 70 70 69 6e 67 20 69 74 20 66 ", dropping it f
07b0: 72 6f 6d 20 74 65 73 74 73 20 70 61 74 68 22 29 rom tests path")
07c0: 29 0a 09 09 20 20 20 20 23 66 29 29 29 0a 09 20 )... #f)))..
07d0: 20 20 20 28 61 70 70 65 6e 64 20 70 61 74 68 73 (append paths
07e0: 20 28 6c 69 73 74 20 28 63 6f 6e 63 20 2a 74 6f (list (conc *to
07f0: 70 70 61 74 68 2a 20 22 2f 74 65 73 74 73 22 29 ppath* "/tests")
0800: 29 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 )))))..(define (
0810: 74 65 73 74 73 3a 67 65 74 2d 76 61 6c 69 64 2d tests:get-valid-
0820: 74 65 73 74 73 20 74 65 73 74 2d 72 65 67 69 73 tests test-regis
0830: 74 72 79 20 74 65 73 74 73 2d 70 61 74 68 73 29 try tests-paths)
0840: 0a 20 20 28 69 66 20 28 6e 75 6c 6c 3f 20 74 65 . (if (null? te
0850: 73 74 73 2d 70 61 74 68 73 29 20 0a 20 20 20 20 sts-paths) .
0860: 20 20 74 65 73 74 2d 72 65 67 69 73 74 72 79 0a test-registry.
0870: 20 20 20 20 20 20 28 6c 65 74 20 6c 6f 6f 70 20 (let loop
0880: 28 28 68 65 64 20 28 63 61 72 20 74 65 73 74 73 ((hed (car tests
0890: 2d 70 61 74 68 73 29 29 0a 09 09 20 28 74 61 6c -paths))... (tal
08a0: 20 28 63 64 72 20 74 65 73 74 73 2d 70 61 74 68 (cdr tests-path
08b0: 73 29 29 29 0a 09 28 69 66 20 28 63 6f 6d 6d 6f s)))..(if (commo
08c0: 6e 3a 66 69 6c 65 2d 65 78 69 73 74 73 3f 20 68 n:file-exists? h
08d0: 65 64 29 0a 09 20 20 20 20 28 66 6f 72 2d 65 61 ed).. (for-ea
08e0: 63 68 20 28 6c 61 6d 62 64 61 20 28 74 65 73 74 ch (lambda (test
08f0: 2d 70 61 74 68 29 0a 09 09 09 28 6c 65 74 2a 20 -path)....(let*
0900: 28 28 74 6e 61 6d 65 20 20 20 28 6c 61 73 74 20 ((tname (last
0910: 28 73 74 72 69 6e 67 2d 73 70 6c 69 74 20 74 65 (string-split te
0920: 73 74 2d 70 61 74 68 20 22 2f 22 29 29 29 0a 09 st-path "/")))..
0930: 09 09 20 20 20 20 20 20 20 28 74 63 6f 6e 66 69 .. (tconfi
0940: 67 20 28 63 6f 6e 63 20 74 65 73 74 2d 70 61 74 g (conc test-pat
0950: 68 20 22 2f 74 65 73 74 63 6f 6e 66 69 67 22 29 h "/testconfig")
0960: 29 29 0a 09 09 09 20 20 28 69 66 20 28 61 6e 64 )).... (if (and
0970: 20 28 6e 6f 74 20 28 68 61 73 68 2d 74 61 62 6c (not (hash-tabl
0980: 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 74 65 e-ref/default te
0990: 73 74 2d 72 65 67 69 73 74 72 79 20 74 6e 61 6d st-registry tnam
09a0: 65 20 23 66 29 29 0a 09 09 09 09 20 20 20 28 63 e #f))..... (c
09b0: 6f 6d 6d 6f 6e 3a 66 69 6c 65 2d 65 78 69 73 74 ommon:file-exist
09c0: 73 3f 20 74 63 6f 6e 66 69 67 29 29 0a 09 09 09 s? tconfig))....
09d0: 20 20 20 20 20 20 28 68 61 73 68 2d 74 61 62 6c (hash-tabl
09e0: 65 2d 73 65 74 21 20 74 65 73 74 2d 72 65 67 69 e-set! test-regi
09f0: 73 74 72 79 20 74 6e 61 6d 65 20 74 65 73 74 2d stry tname test-
0a00: 70 61 74 68 29 29 29 29 0a 09 09 20 20 20 20 20 path))))...
0a10: 20 28 67 6c 6f 62 20 28 63 6f 6e 63 20 68 65 64 (glob (conc hed
0a20: 20 22 2f 2a 22 29 29 29 29 0a 09 28 69 66 20 28 "/*"))))..(if (
0a30: 6e 75 6c 6c 3f 20 74 61 6c 29 0a 09 20 20 20 20 null? tal)..
0a40: 74 65 73 74 2d 72 65 67 69 73 74 72 79 0a 09 20 test-registry..
0a50: 20 20 20 28 6c 6f 6f 70 20 28 63 61 72 20 74 61 (loop (car ta
0a60: 6c 29 28 63 64 72 20 74 61 6c 29 29 29 29 29 29 l)(cdr tal))))))
0a70: 0a 0a 28 64 65 66 69 6e 65 20 28 74 65 73 74 73 ..(define (tests
0a80: 3a 66 69 6c 74 65 72 2d 74 65 73 74 2d 6e 61 6d :filter-test-nam
0a90: 65 73 20 74 65 73 74 2d 6e 61 6d 65 73 20 74 65 es test-names te
0aa0: 73 74 2d 70 61 74 74 73 29 0a 20 20 28 64 65 6c st-patts). (del
0ab0: 65 74 65 2d 64 75 70 6c 69 63 61 74 65 73 0a 20 ete-duplicates.
0ac0: 20 20 28 66 69 6c 74 65 72 20 28 6c 61 6d 62 64 (filter (lambd
0ad0: 61 20 28 74 65 73 74 6e 61 6d 65 29 0a 09 20 20 a (testname)..
0ae0: 20 20 20 28 74 65 73 74 73 3a 6d 61 74 63 68 20 (tests:match
0af0: 74 65 73 74 2d 70 61 74 74 73 20 74 65 73 74 6e test-patts testn
0b00: 61 6d 65 20 23 66 29 29 0a 09 20 20 20 74 65 73 ame #f)).. tes
0b10: 74 2d 6e 61 6d 65 73 29 29 29 0a 0a 3b 3b 20 69 t-names)))..;; i
0b20: 74 65 6d 6d 61 70 20 69 73 20 61 20 6c 69 73 74 temmap is a list
0b30: 20 6f 66 20 74 65 73 74 6e 61 6d 65 20 70 61 74 of testname pat
0b40: 74 65 72 6e 73 20 74 6f 20 6d 61 70 73 0a 3b 3b terns to maps.;;
0b50: 20 20 20 20 20 74 65 73 74 31 20 2e 2a 2f 62 61 test1 .*/ba
0b60: 72 2f 28 5c 64 2b 29 20 66 6f 6f 2f 5c 31 0a 3b r/(\d+) foo/\1.;
0b70: 3b 20 20 20 20 20 25 20 20 20 20 20 66 6f 6f 2f ; % foo/
0b80: 28 5b 5e 2f 5d 2b 29 20 20 5c 31 2f 62 61 72 0a ([^/]+) \1/bar.
0b90: 3b 3b 0a 3b 3b 20 23 20 4e 4f 54 45 3a 20 74 68 ;;.;; # NOTE: th
0ba0: 65 20 6c 69 6e 65 20 77 69 74 68 20 74 68 65 20 e line with the
0bb0: 73 69 6e 67 6c 65 20 25 20 63 6f 75 6c 64 20 62 single % could b
0bc0: 65 20 74 68 65 20 72 65 73 75 6c 74 20 6f 66 0a e the result of.
0bd0: 3b 3b 20 23 20 20 20 20 20 20 20 69 74 65 6d 6d ;; # itemm
0be0: 61 70 20 65 6e 74 72 79 20 69 6e 20 72 65 71 75 ap entry in requ
0bf0: 69 72 65 6d 65 6e 74 73 20 28 6c 65 67 61 63 79 irements (legacy
0c00: 29 2e 20 54 68 65 20 69 74 65 6d 6d 61 70 0a 3b ). The itemmap.;
0c10: 3b 20 23 20 20 20 20 20 20 20 72 65 71 75 69 72 ; # requir
0c20: 65 6d 65 6e 74 73 20 65 6e 74 72 79 20 69 73 20 ements entry is
0c30: 64 65 70 72 65 63 61 74 65 64 0a 3b 3b 0a 28 64 deprecated.;;.(d
0c40: 65 66 69 6e 65 20 28 74 65 73 74 73 3a 67 65 74 efine (tests:get
0c50: 2d 69 74 65 6d 6d 61 70 73 20 74 63 6f 6e 66 69 -itemmaps tconfi
0c60: 67 29 0a 20 20 28 6c 65 74 20 28 28 62 61 73 65 g). (let ((base
0c70: 2d 69 74 65 6d 6d 61 70 20 20 28 63 6f 6e 66 69 -itemmap (confi
0c80: 67 66 3a 6c 6f 6f 6b 75 70 20 74 63 6f 6e 66 69 gf:lookup tconfi
0c90: 67 20 22 72 65 71 75 69 72 65 6d 65 6e 74 73 22 g "requirements"
0ca0: 20 22 69 74 65 6d 6d 61 70 22 29 29 0a 09 28 69 "itemmap"))..(i
0cb0: 74 65 6d 6d 61 70 2d 74 61 62 6c 65 20 28 63 6f temmap-table (co
0cc0: 6e 66 69 67 66 3a 67 65 74 2d 73 65 63 74 69 6f nfigf:get-sectio
0cd0: 6e 20 74 63 6f 6e 66 69 67 20 22 69 74 65 6d 6d n tconfig "itemm
0ce0: 61 70 22 29 29 29 0a 20 20 20 20 28 61 70 70 65 ap"))). (appe
0cf0: 6e 64 20 28 69 66 20 62 61 73 65 2d 69 74 65 6d nd (if base-item
0d00: 6d 61 70 0a 09 09 28 6c 69 73 74 20 28 6c 69 73 map...(list (lis
0d10: 74 20 22 25 22 20 62 61 73 65 2d 69 74 65 6d 6d t "%" base-itemm
0d20: 61 70 29 29 0a 09 09 27 28 29 29 0a 09 20 20 20 ap))...'())..
0d30: 20 28 69 66 20 69 74 65 6d 6d 61 70 2d 74 61 62 (if itemmap-tab
0d40: 6c 65 0a 09 09 69 74 65 6d 6d 61 70 2d 74 61 62 le...itemmap-tab
0d50: 6c 65 0a 09 09 27 28 29 29 29 29 29 0a 0a 3b 3b le...'()))))..;;
0d60: 20 67 69 76 65 6e 20 61 20 6c 69 73 74 20 6f 66 given a list of
0d70: 20 69 74 65 6d 6d 61 70 73 20 28 74 65 73 74 6e itemmaps (testn
0d80: 61 6d 65 20 2e 20 6d 61 70 29 2c 20 72 65 74 75 ame . map), retu
0d90: 72 6e 20 74 68 65 20 66 69 72 73 74 20 6d 61 74 rn the first mat
0da0: 63 68 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 74 ch.;;.(define (t
0db0: 65 73 74 73 3a 6c 6f 6f 6b 75 70 2d 69 74 65 6d ests:lookup-item
0dc0: 6d 61 70 20 69 74 65 6d 6d 61 70 73 20 74 65 73 map itemmaps tes
0dd0: 74 6e 61 6d 65 29 0a 20 20 28 6c 65 74 20 28 28 tname). (let ((
0de0: 62 65 73 74 2d 6d 61 74 63 68 65 73 20 28 66 69 best-matches (fi
0df0: 6c 74 65 72 20 28 6c 61 6d 62 64 61 20 28 69 74 lter (lambda (it
0e00: 65 6d 6d 61 70 29 0a 09 09 09 09 28 74 65 73 74 emmap).....(test
0e10: 73 3a 6d 61 74 63 68 20 28 63 61 72 20 69 74 65 s:match (car ite
0e20: 6d 6d 61 70 29 20 74 65 73 74 6e 61 6d 65 20 23 mmap) testname #
0e30: 66 29 29 0a 09 09 09 20 20 20 20 20 20 69 74 65 f)).... ite
0e40: 6d 6d 61 70 73 29 29 29 0a 20 20 20 20 28 69 66 mmaps))). (if
0e50: 20 28 6e 75 6c 6c 3f 20 62 65 73 74 2d 6d 61 74 (null? best-mat
0e60: 63 68 65 73 29 0a 09 23 66 0a 09 28 6c 65 74 20 ches)..#f..(let
0e70: 28 28 72 65 73 20 28 63 61 72 20 62 65 73 74 2d ((res (car best-
0e80: 6d 61 74 63 68 65 73 29 29 29 0a 09 20 20 3b 3b matches))).. ;;
0e90: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 (debug:print 0
0ea0: 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 *default-log-por
0eb0: 74 2a 20 22 72 65 73 3d 22 20 72 65 73 29 0a 09 t* "res=" res)..
0ec0: 20 20 28 63 6f 6e 64 0a 09 20 20 20 28 28 73 74 (cond.. ((st
0ed0: 72 69 6e 67 3f 20 72 65 73 29 20 72 65 73 29 20 ring? res) res)
0ee0: 3b 3b 3b 20 46 49 58 20 54 48 45 20 52 4f 4f 54 ;;; FIX THE ROOT
0ef0: 20 43 41 55 53 45 20 48 45 52 45 20 2e 2e 2e 2e CAUSE HERE ....
0f00: 0a 09 20 20 20 28 28 6e 75 6c 6c 3f 20 72 65 73 .. ((null? res
0f10: 29 20 20 20 23 66 29 0a 09 20 20 20 28 28 73 74 ) #f).. ((st
0f20: 72 69 6e 67 3f 20 28 63 64 72 20 72 65 73 29 29 ring? (cdr res))
0f30: 20 28 63 64 72 20 72 65 73 29 29 20 20 3b 3b 20 (cdr res)) ;;
0f40: 69 74 20 69 73 20 61 20 70 61 69 72 0a 09 20 20 it is a pair..
0f50: 20 28 28 73 74 72 69 6e 67 3f 20 28 63 61 64 72 ((string? (cadr
0f60: 20 72 65 73 29 29 28 63 61 64 72 20 72 65 73 29 res))(cadr res)
0f70: 29 20 3b 3b 20 69 74 20 69 73 20 61 20 6c 69 73 ) ;; it is a lis
0f80: 74 0a 09 20 20 20 28 65 6c 73 65 20 63 61 64 72 t.. (else cadr
0f90: 20 72 65 73 29 29 29 29 29 29 0a 0a 3b 3b 20 72 res))))))..;; r
0fa0: 65 74 75 72 6e 20 69 74 65 6d 73 20 67 69 76 65 eturn items give
0fb0: 6e 20 63 6f 6e 66 69 67 0a 3b 3b 0a 28 64 65 66 n config.;;.(def
0fc0: 69 6e 65 20 28 74 65 73 74 73 3a 67 65 74 2d 69 ine (tests:get-i
0fd0: 74 65 6d 73 20 74 63 6f 6e 66 69 67 29 0a 20 20 tems tconfig).
0fe0: 28 6c 65 74 20 28 28 69 74 65 6d 73 20 20 20 20 (let ((items
0ff0: 20 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 (hash-table-re
1000: 66 2f 64 65 66 61 75 6c 74 20 74 63 6f 6e 66 69 f/default tconfi
1010: 67 20 22 69 74 65 6d 73 22 20 23 66 29 29 20 3b g "items" #f)) ;
1020: 3b 20 69 74 65 6d 73 20 34 0a 09 28 69 74 65 6d ; items 4..(item
1030: 73 74 61 62 6c 65 20 28 68 61 73 68 2d 74 61 62 stable (hash-tab
1040: 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 74 le-ref/default t
1050: 63 6f 6e 66 69 67 20 22 69 74 65 6d 73 74 61 62 config "itemstab
1060: 6c 65 22 20 23 66 29 29 29 20 0a 20 20 20 20 3b le" #f))) . ;
1070: 3b 20 69 66 20 65 69 74 68 65 72 20 69 74 65 6d ; if either item
1080: 73 20 6f 72 20 69 74 65 6d 73 20 74 61 62 6c 65 s or items table
1090: 20 69 73 20 61 20 70 72 6f 63 20 72 65 74 75 72 is a proc retur
10a0: 6e 20 69 74 20 73 6f 20 74 65 73 74 20 72 75 6e n it so test run
10b0: 6e 69 6e 67 0a 20 20 20 20 3b 3b 20 70 72 6f 63 ning. ;; proc
10c0: 65 73 73 20 63 61 6e 20 6b 6e 6f 77 20 74 6f 20 ess can know to
10d0: 63 61 6c 6c 20 69 74 65 6d 73 3a 67 65 74 2d 69 call items:get-i
10e0: 74 65 6d 73 2d 66 72 6f 6d 2d 63 6f 6e 66 69 67 tems-from-config
10f0: 0a 20 20 20 20 3b 3b 20 69 66 20 65 69 74 68 65 . ;; if eithe
1100: 72 20 69 73 20 61 20 6c 69 73 74 20 61 6e 64 20 r is a list and
1110: 6e 6f 6e 65 20 69 73 20 61 20 70 72 6f 63 20 67 none is a proc g
1120: 6f 20 61 68 65 61 64 20 61 6e 64 20 63 61 6c 6c o ahead and call
1130: 20 67 65 74 2d 69 74 65 6d 73 0a 20 20 20 20 3b get-items. ;
1140: 3b 20 6f 74 68 65 72 77 69 73 65 20 72 65 74 75 ; otherwise retu
1150: 72 6e 20 23 66 20 2d 20 74 68 69 73 20 69 73 20 rn #f - this is
1160: 6e 6f 74 20 61 6e 20 69 74 65 72 61 74 65 64 20 not an iterated
1170: 74 65 73 74 0a 20 20 20 20 28 63 6f 6e 64 0a 20 test. (cond.
1180: 20 20 20 20 28 28 70 72 6f 63 65 64 75 72 65 3f ((procedure?
1190: 20 69 74 65 6d 73 29 20 20 20 20 20 20 0a 20 20 items) .
11a0: 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 (debug:print
11b0: 2d 69 6e 66 6f 20 34 20 2a 64 65 66 61 75 6c 74 -info 4 *default
11c0: 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 69 74 65 6d -log-port* "item
11d0: 73 20 69 73 20 61 20 70 72 6f 63 65 64 75 72 65 s is a procedure
11e0: 2c 20 77 69 6c 6c 20 63 61 6c 63 20 6c 61 74 65 , will calc late
11f0: 72 22 29 0a 20 20 20 20 20 20 69 74 65 6d 73 29 r"). items)
1200: 20 20 20 20 20 20 20 20 20 20 20 20 3b 3b 20 63 ;; c
1210: 61 6c 63 20 6c 61 74 65 72 0a 20 20 20 20 20 28 alc later. (
1220: 28 70 72 6f 63 65 64 75 72 65 3f 20 69 74 65 6d (procedure? item
1230: 73 74 61 62 6c 65 29 0a 20 20 20 20 20 20 28 64 stable). (d
1240: 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 ebug:print-info
1250: 34 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 4 *default-log-p
1260: 6f 72 74 2a 20 22 69 74 65 6d 73 74 61 62 6c 65 ort* "itemstable
1270: 20 69 73 20 61 20 70 72 6f 63 65 64 75 72 65 2c is a procedure,
1280: 20 77 69 6c 6c 20 63 61 6c 63 20 6c 61 74 65 72 will calc later
1290: 22 29 0a 20 20 20 20 20 20 69 74 65 6d 73 74 61 "). itemsta
12a0: 62 6c 65 29 20 20 20 20 20 20 20 3b 3b 20 63 61 ble) ;; ca
12b0: 6c 63 20 6c 61 74 65 72 0a 20 20 20 20 20 28 28 lc later. ((
12c0: 66 69 6c 74 65 72 20 28 6c 61 6d 62 64 61 20 28 filter (lambda (
12d0: 78 29 0a 09 09 28 6c 65 74 20 28 28 76 61 6c 20 x)...(let ((val
12e0: 28 63 61 72 20 78 29 29 29 0a 09 09 20 20 28 69 (car x)))... (i
12f0: 66 20 28 70 72 6f 63 65 64 75 72 65 3f 20 76 61 f (procedure? va
1300: 6c 29 20 76 61 6c 20 23 66 29 29 29 0a 09 20 20 l) val #f)))..
1310: 20 20 20 20 28 61 70 70 65 6e 64 20 28 69 66 20 (append (if
1320: 28 6c 69 73 74 3f 20 69 74 65 6d 73 29 20 69 74 (list? items) it
1330: 65 6d 73 20 27 28 29 29 0a 09 09 20 20 20 20 20 ems '())...
1340: 20 28 69 66 20 28 6c 69 73 74 3f 20 69 74 65 6d (if (list? item
1350: 73 74 61 62 6c 65 29 20 69 74 65 6d 73 74 61 62 stable) itemstab
1360: 6c 65 20 27 28 29 29 29 29 0a 20 20 20 20 20 20 le '()))).
1370: 27 68 61 76 65 2d 70 72 6f 63 65 64 75 72 65 29 'have-procedure)
1380: 0a 20 20 20 20 20 28 28 6f 72 20 28 6c 69 73 74 . ((or (list
1390: 3f 20 69 74 65 6d 73 29 28 6c 69 73 74 3f 20 69 ? items)(list? i
13a0: 74 65 6d 73 74 61 62 6c 65 29 29 20 3b 3b 20 63 temstable)) ;; c
13b0: 61 6c 63 20 6e 6f 77 0a 20 20 20 20 20 20 28 64 alc now. (d
13c0: 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 ebug:print-info
13d0: 34 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 4 *default-log-p
13e0: 6f 72 74 2a 20 22 69 74 65 6d 73 20 61 6e 64 20 ort* "items and
13f0: 69 74 65 6d 73 74 61 62 6c 65 20 61 72 65 20 6c itemstable are l
1400: 69 73 74 73 2c 20 63 61 6c 63 20 6e 6f 77 5c 6e ists, calc now\n
1410: 22 0a 09 09 09 22 20 20 20 20 69 74 65 6d 73 3a "...." items:
1420: 20 22 20 69 74 65 6d 73 20 22 20 69 74 65 6d 73 " items " items
1430: 74 61 62 6c 65 3a 20 22 20 69 74 65 6d 73 74 61 table: " itemsta
1440: 62 6c 65 29 0a 20 20 20 20 20 20 28 69 74 65 6d ble). (item
1450: 73 3a 67 65 74 2d 69 74 65 6d 73 2d 66 72 6f 6d s:get-items-from
1460: 2d 63 6f 6e 66 69 67 20 74 63 6f 6e 66 69 67 29 -config tconfig)
1470: 29 0a 20 20 20 20 20 28 65 6c 73 65 20 23 66 29 ). (else #f)
1480: 29 29 29 20 20 20 20 20 20 20 20 20 20 20 20 20 )))
1490: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 3b 3b ;;
14a0: 20 6e 6f 74 20 69 74 65 72 61 74 65 64 0a 0a 0a not iterated...
14b0: 3b 3b 20 72 65 74 75 72 6e 73 20 77 61 69 74 6f ;; returns waito
14c0: 6e 73 20 77 61 69 74 6f 72 73 20 74 63 6f 6e 66 ns waitors tconf
14d0: 69 67 64 61 74 0a 3b 3b 0a 28 64 65 66 69 6e 65 igdat.;;.(define
14e0: 20 28 74 65 73 74 73 3a 67 65 74 2d 77 61 69 74 (tests:get-wait
14f0: 6f 6e 73 20 74 65 73 74 2d 6e 61 6d 65 20 61 6c ons test-name al
1500: 6c 2d 74 65 73 74 73 2d 72 65 67 69 73 74 72 79 l-tests-registry
1510: 29 0a 20 20 20 28 6c 65 74 2a 20 28 28 63 6f 6e ). (let* ((con
1520: 66 69 67 20 20 28 74 65 73 74 73 3a 67 65 74 2d fig (tests:get-
1530: 74 65 73 74 63 6f 6e 66 69 67 20 74 65 73 74 2d testconfig test-
1540: 6e 61 6d 65 20 23 66 20 61 6c 6c 2d 74 65 73 74 name #f all-test
1550: 73 2d 72 65 67 69 73 74 72 79 20 27 72 65 74 75 s-registry 'retu
1560: 72 6e 2d 70 72 6f 63 73 29 29 29 20 3b 3b 20 61 rn-procs))) ;; a
1570: 73 73 75 6d 69 6e 67 20 6e 6f 20 70 72 6f 62 6c ssuming no probl
1580: 65 6d 73 20 77 69 74 68 20 69 6d 6d 65 64 69 61 ems with immedia
1590: 74 65 20 65 76 61 6c 75 61 74 69 6f 6e 2c 20 74 te evaluation, t
15a0: 68 69 73 20 63 6f 75 6c 64 20 62 65 20 73 69 6d his could be sim
15b0: 70 6c 69 66 69 65 64 20 28 27 72 65 74 75 72 6e plified ('return
15c0: 2d 70 72 6f 63 73 20 2d 3e 20 23 74 29 0a 20 20 -procs -> #t).
15d0: 20 20 20 28 6c 65 74 20 28 28 69 6e 73 74 72 20 (let ((instr
15e0: 28 69 66 20 63 6f 6e 66 69 67 20 0a 09 09 20 20 (if config ...
15f0: 20 20 20 20 28 63 6f 6e 66 69 67 2d 6c 6f 6f 6b (config-look
1600: 75 70 20 63 6f 6e 66 69 67 20 22 72 65 71 75 69 up config "requi
1610: 72 65 6d 65 6e 74 73 22 20 22 77 61 69 74 6f 6e rements" "waiton
1620: 22 29 0a 09 09 20 20 20 20 20 20 28 62 65 67 69 ")... (begi
1630: 6e 20 3b 3b 20 4e 6f 20 63 6f 6e 66 69 67 20 6d n ;; No config m
1640: 65 61 6e 73 20 74 68 69 73 20 69 73 20 61 20 6e eans this is a n
1650: 6f 6e 2d 65 78 69 73 74 61 6e 74 20 74 65 73 74 on-existant test
1660: 0a 09 09 09 28 64 65 62 75 67 3a 70 72 69 6e 74 ....(debug:print
1670: 2d 65 72 72 6f 72 20 30 20 2a 64 65 66 61 75 6c -error 0 *defaul
1680: 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 6e 6f 6e t-log-port* "non
1690: 2d 65 78 69 73 74 65 6e 74 20 72 65 71 75 69 72 -existent requir
16a0: 65 64 20 74 65 73 74 20 5c 22 22 20 74 65 73 74 ed test \"" test
16b0: 2d 6e 61 6d 65 20 22 5c 22 22 29 0a 09 09 09 28 -name "\"")....(
16c0: 65 78 69 74 20 31 29 29 29 29 0a 09 20 20 20 28 exit 1)))).. (
16d0: 69 6e 73 74 72 32 20 28 69 66 20 63 6f 6e 66 69 instr2 (if confi
16e0: 67 0a 09 09 20 20 20 20 20 20 20 28 63 6f 6e 66 g... (conf
16f0: 69 67 2d 6c 6f 6f 6b 75 70 20 63 6f 6e 66 69 67 ig-lookup config
1700: 20 22 72 65 71 75 69 72 65 6d 65 6e 74 73 22 20 "requirements"
1710: 22 77 61 69 74 6f 72 22 29 0a 09 09 20 20 20 20 "waitor")...
1720: 20 20 20 22 22 29 29 29 0a 20 20 20 20 20 20 20 ""))).
1730: 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 (debug:print-inf
1740: 6f 20 38 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 o 8 *default-log
1750: 2d 70 6f 72 74 2a 20 22 77 61 69 74 6f 6e 73 20 -port* "waitons
1760: 73 74 72 69 6e 67 20 69 73 20 22 20 69 6e 73 74 string is " inst
1770: 72 20 22 2c 20 77 61 69 74 6f 72 73 20 73 74 72 r ", waitors str
1780: 69 6e 67 20 69 73 20 22 20 69 6e 73 74 72 32 29 ing is " instr2)
1790: 0a 20 20 20 20 20 20 20 28 6c 65 74 20 28 28 6e . (let ((n
17a0: 65 77 77 61 69 74 6f 6e 73 0a 09 20 20 20 20 20 ewwaitons..
17b0: 20 28 73 74 72 69 6e 67 2d 73 70 6c 69 74 20 28 (string-split (
17c0: 63 6f 6e 64 0a 09 09 09 20 20 20 20 20 28 28 70 cond.... ((p
17d0: 72 6f 63 65 64 75 72 65 3f 20 69 6e 73 74 72 29 rocedure? instr)
17e0: 20 3b 3b 20 68 65 72 65 20 0a 09 09 09 20 20 20 ;; here ....
17f0: 20 20 20 28 6c 65 74 20 28 28 72 65 73 20 28 69 (let ((res (i
1800: 6e 73 74 72 29 29 29 0a 09 09 09 09 28 64 65 62 nstr))).....(deb
1810: 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 38 20 ug:print-info 8
1820: 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 *default-log-por
1830: 74 2a 20 22 77 61 69 74 6f 6e 20 70 72 6f 63 65 t* "waiton proce
1840: 64 75 72 65 20 72 65 73 75 6c 74 73 20 69 6e 20 dure results in
1850: 73 74 72 69 6e 67 20 22 20 72 65 73 20 22 20 66 string " res " f
1860: 6f 72 20 74 65 73 74 20 22 20 74 65 73 74 2d 6e or test " test-n
1870: 61 6d 65 29 0a 09 09 09 09 72 65 73 29 29 0a 09 ame).....res))..
1880: 09 09 20 20 20 20 20 28 28 73 74 72 69 6e 67 3f .. ((string?
1890: 20 69 6e 73 74 72 29 20 20 20 20 20 69 6e 73 74 instr) inst
18a0: 72 29 0a 09 09 09 20 20 20 20 20 28 65 6c 73 65 r).... (else
18b0: 20 0a 09 09 09 20 20 20 20 20 20 3b 3b 20 4e 4f .... ;; NO
18c0: 54 45 3a 20 54 68 69 73 20 69 73 20 61 63 74 75 TE: This is actu
18d0: 61 6c 6c 79 20 74 68 65 20 63 61 73 65 20 6f 66 ally the case of
18e0: 20 2a 6e 6f 2a 20 77 61 69 74 6f 6e 73 21 20 3b *no* waitons! ;
18f0: 3b 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 65 ; (debug:print-e
1900: 72 72 6f 72 20 30 20 2a 64 65 66 61 75 6c 74 2d rror 0 *default-
1910: 6c 6f 67 2d 70 6f 72 74 2a 20 22 73 6f 6d 65 74 log-port* "somet
1920: 68 69 6e 67 20 77 65 6e 74 20 77 72 6f 6e 67 20 hing went wrong
1930: 69 6e 20 70 72 6f 63 65 73 73 69 6e 67 20 77 61 in processing wa
1940: 69 74 6f 6e 73 20 66 6f 72 20 74 65 73 74 20 22 itons for test "
1950: 20 74 65 73 74 2d 6e 61 6d 65 29 0a 09 09 09 20 test-name)....
1960: 20 20 20 20 20 22 22 29 29 29 29 0a 09 20 20 20 ""))))..
1970: 20 20 28 6e 65 77 77 61 69 74 6f 72 73 0a 09 20 (newwaitors..
1980: 20 20 20 20 20 28 73 74 72 69 6e 67 2d 73 70 6c (string-spl
1990: 69 74 20 28 63 6f 6e 64 0a 09 09 09 20 20 20 20 it (cond....
19a0: 20 28 28 70 72 6f 63 65 64 75 72 65 3f 20 69 6e ((procedure? in
19b0: 73 74 72 32 29 0a 09 09 09 20 20 20 20 20 20 28 str2).... (
19c0: 6c 65 74 20 28 28 72 65 73 20 28 69 6e 73 74 72 let ((res (instr
19d0: 32 29 29 29 0a 09 09 09 09 28 64 65 62 75 67 3a 2))).....(debug:
19e0: 70 72 69 6e 74 2d 69 6e 66 6f 20 38 20 2a 64 65 print-info 8 *de
19f0: 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 fault-log-port*
1a00: 22 77 61 69 74 6f 72 20 70 72 6f 63 65 64 75 72 "waitor procedur
1a10: 65 20 72 65 73 75 6c 74 73 20 69 6e 20 73 74 72 e results in str
1a20: 69 6e 67 20 22 20 72 65 73 20 22 20 66 6f 72 20 ing " res " for
1a30: 74 65 73 74 20 22 20 74 65 73 74 2d 6e 61 6d 65 test " test-name
1a40: 29 0a 09 09 09 09 72 65 73 29 29 0a 09 09 09 20 ).....res))....
1a50: 20 20 20 20 28 28 73 74 72 69 6e 67 3f 20 69 6e ((string? in
1a60: 73 74 72 32 29 20 20 20 20 20 69 6e 73 74 72 32 str2) instr2
1a70: 29 0a 09 09 09 20 20 20 20 20 28 65 6c 73 65 20 ).... (else
1a80: 0a 09 09 09 20 20 20 20 20 20 3b 3b 20 4e 4f 54 .... ;; NOT
1a90: 45 3a 20 54 68 69 73 20 69 73 20 61 63 74 75 61 E: This is actua
1aa0: 6c 6c 79 20 74 68 65 20 63 61 73 65 20 6f 66 20 lly the case of
1ab0: 2a 6e 6f 2a 20 77 61 69 74 6f 6e 73 21 20 3b 3b *no* waitons! ;;
1ac0: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 65 72 (debug:print-er
1ad0: 72 6f 72 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c ror 0 *default-l
1ae0: 6f 67 2d 70 6f 72 74 2a 20 22 73 6f 6d 65 74 68 og-port* "someth
1af0: 69 6e 67 20 77 65 6e 74 20 77 72 6f 6e 67 20 69 ing went wrong i
1b00: 6e 20 70 72 6f 63 65 73 73 69 6e 67 20 77 61 69 n processing wai
1b10: 74 6f 6e 73 20 66 6f 72 20 74 65 73 74 20 22 20 tons for test "
1b20: 74 65 73 74 2d 6e 61 6d 65 29 0a 09 09 09 20 20 test-name)....
1b30: 20 20 20 20 22 22 29 29 29 29 29 0a 09 20 28 76 ""))))).. (v
1b40: 61 6c 75 65 73 0a 09 20 20 3b 3b 20 74 68 65 20 alues.. ;; the
1b50: 77 61 69 74 6f 6e 73 0a 09 20 20 28 66 69 6c 74 waitons.. (filt
1b60: 65 72 20 28 6c 61 6d 62 64 61 20 28 78 29 0a 09 er (lambda (x)..
1b70: 09 20 20 20 20 28 69 66 20 28 68 61 73 68 2d 74 . (if (hash-t
1b80: 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 able-ref/default
1b90: 20 61 6c 6c 2d 74 65 73 74 73 2d 72 65 67 69 73 all-tests-regis
1ba0: 74 72 79 20 78 20 23 66 29 0a 09 09 09 23 74 0a try x #f)....#t.
1bb0: 09 09 09 28 62 65 67 69 6e 0a 09 09 09 20 20 28 ...(begin.... (
1bc0: 64 65 62 75 67 3a 70 72 69 6e 74 2d 65 72 72 6f debug:print-erro
1bd0: 72 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 r 0 *default-log
1be0: 2d 70 6f 72 74 2a 20 22 74 65 73 74 20 22 20 74 -port* "test " t
1bf0: 65 73 74 2d 6e 61 6d 65 20 22 20 68 61 73 20 75 est-name " has u
1c00: 6e 72 65 63 6f 67 6e 69 73 65 64 20 77 61 69 74 nrecognised wait
1c10: 6f 6e 20 74 65 73 74 6e 61 6d 65 20 22 20 78 29 on testname " x)
1c20: 0a 09 09 09 20 20 23 66 29 29 29 0a 09 09 20 20 .... #f)))...
1c30: 6e 65 77 77 61 69 74 6f 6e 73 29 0a 09 20 20 28 newwaitons).. (
1c40: 66 69 6c 74 65 72 20 28 6c 61 6d 62 64 61 20 28 filter (lambda (
1c50: 78 29 0a 09 09 20 20 20 20 28 69 66 20 28 68 61 x)... (if (ha
1c60: 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 sh-table-ref/def
1c70: 61 75 6c 74 20 61 6c 6c 2d 74 65 73 74 73 2d 72 ault all-tests-r
1c80: 65 67 69 73 74 72 79 20 78 20 23 66 29 0a 09 09 egistry x #f)...
1c90: 09 23 74 0a 09 09 09 28 62 65 67 69 6e 0a 09 09 .#t....(begin...
1ca0: 09 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d . (debug:print-
1cb0: 65 72 72 6f 72 20 30 20 2a 64 65 66 61 75 6c 74 error 0 *default
1cc0: 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 74 65 73 74 -log-port* "test
1cd0: 20 22 20 74 65 73 74 2d 6e 61 6d 65 20 22 20 68 " test-name " h
1ce0: 61 73 20 75 6e 72 65 63 6f 67 6e 69 73 65 64 20 as unrecognised
1cf0: 77 61 69 74 6f 6e 20 74 65 73 74 6e 61 6d 65 20 waiton testname
1d00: 22 20 78 29 0a 09 09 09 20 20 23 66 29 29 29 0a " x).... #f))).
1d10: 09 09 20 20 6e 65 77 77 61 69 74 6f 72 73 29 0a .. newwaitors).
1d20: 09 20 20 63 6f 6e 66 69 67 29 29 29 29 29 0a 09 . config)))))..
1d30: 09 09 09 09 20 20 20 20 20 0a 3b 3b 20 67 69 76 .... .;; giv
1d40: 65 6e 20 77 61 69 74 69 6e 67 2d 74 65 73 74 20 en waiting-test
1d50: 74 68 61 74 20 69 73 20 77 61 69 74 69 6e 67 20 that is waiting
1d60: 6f 6e 20 77 61 69 74 6f 6e 2d 74 65 73 74 20 65 on waiton-test e
1d70: 78 74 65 6e 64 20 74 65 73 74 2d 70 61 74 74 20 xtend test-patt
1d80: 61 70 70 72 6f 70 72 69 61 74 65 6c 79 0a 3b 3b appropriately.;;
1d90: 0a 3b 3b 20 20 67 65 6e 6c 69 62 2f 74 65 73 74 .;; genlib/test
1da0: 63 6f 6e 66 69 67 20 20 20 20 20 20 20 20 20 20 config
1db0: 20 20 20 20 20 73 69 6d 2f 74 65 73 74 63 6f 6e sim/testcon
1dc0: 66 69 67 0a 3b 3b 20 20 67 65 6e 6c 69 62 2f 73 fig.;; genlib/s
1dd0: 63 68 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ch
1de0: 20 20 20 20 20 20 20 20 73 69 6d 2f 73 63 68 2f sim/sch/
1df0: 63 65 6c 6c 31 0a 3b 3b 0a 3b 3b 20 20 5b 72 65 cell1.;;.;; [re
1e00: 71 75 69 72 65 6d 65 6e 74 73 5d 20 20 20 20 20 quirements]
1e10: 20 20 20 20 20 20 20 20 20 20 20 20 20 5b 72 65 [re
1e20: 71 75 69 72 65 6d 65 6e 74 73 5d 0a 3b 3b 20 20 quirements].;;
1e30: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1e40: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1e50: 6d 6f 64 65 20 69 74 65 6d 77 61 69 74 0a 3b 3b mode itemwait.;;
1e60: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1e70: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1e80: 20 20 23 20 74 72 69 6d 20 6f 66 66 20 74 68 65 # trim off the
1e90: 20 63 65 6c 6c 20 74 6f 20 64 65 74 65 72 6d 69 cell to determi
1ea0: 6e 65 20 77 68 61 74 20 74 6f 20 72 75 6e 20 66 ne what to run f
1eb0: 6f 72 20 67 65 6e 6c 69 62 0a 3b 3b 20 20 20 20 or genlib.;;
1ec0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1ed0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 69 74 it
1ee0: 65 6d 6d 61 70 20 2f 2e 2a 0a 3b 3b 0a 3b 3b 20 emmap /.*.;;.;;
1ef0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1f00: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1f10: 20 77 61 69 74 69 6e 67 2d 74 65 73 74 20 69 73 waiting-test is
1f20: 20 77 61 69 74 69 6e 67 20 6f 6e 20 77 61 69 74 waiting on wait
1f30: 6f 6e 2d 74 65 73 74 20 73 6f 20 77 65 20 6e 65 on-test so we ne
1f40: 65 64 20 74 6f 20 63 72 65 61 74 65 20 61 20 70 ed to create a p
1f50: 61 74 74 65 72 6e 20 66 6f 72 20 77 61 69 74 6f attern for waito
1f60: 6e 2d 74 65 73 74 20 67 69 76 65 6e 20 77 61 69 n-test given wai
1f70: 74 69 6e 67 2d 74 65 73 74 20 61 6e 64 20 69 74 ting-test and it
1f80: 65 6d 6d 61 70 0a 28 64 65 66 69 6e 65 20 28 74 emmap.(define (t
1f90: 65 73 74 73 3a 65 78 74 65 6e 64 2d 74 65 73 74 ests:extend-test
1fa0: 2d 70 61 74 74 73 20 74 65 73 74 2d 70 61 74 74 -patts test-patt
1fb0: 20 77 61 69 74 69 6e 67 2d 74 65 73 74 20 77 61 waiting-test wa
1fc0: 69 74 6f 6e 2d 74 65 73 74 20 69 74 65 6d 6d 61 iton-test itemma
1fd0: 70 73 29 0a 20 20 28 6c 65 74 2a 20 28 28 69 74 ps). (let* ((it
1fe0: 65 6d 6d 61 70 20 20 20 20 20 20 20 20 20 20 28 emmap (
1ff0: 74 65 73 74 73 3a 6c 6f 6f 6b 75 70 2d 69 74 65 tests:lookup-ite
2000: 6d 6d 61 70 20 69 74 65 6d 6d 61 70 73 20 77 61 mmap itemmaps wa
2010: 69 74 6f 6e 2d 74 65 73 74 29 29 0a 09 20 28 70 iton-test)).. (p
2020: 61 74 74 73 20 20 20 20 20 20 20 20 20 20 20 20 atts
2030: 28 73 74 72 69 6e 67 2d 73 70 6c 69 74 20 74 65 (string-split te
2040: 73 74 2d 70 61 74 74 20 22 2c 22 29 29 0a 09 20 st-patt ","))..
2050: 28 77 61 69 74 69 6e 67 2d 74 65 73 74 2d 6c 65 (waiting-test-le
2060: 6e 20 28 2b 20 28 73 74 72 69 6e 67 2d 6c 65 6e n (+ (string-len
2070: 67 74 68 20 77 61 69 74 69 6e 67 2d 74 65 73 74 gth waiting-test
2080: 29 20 31 29 29 0a 09 20 28 70 61 74 74 73 2d 77 ) 1)).. (patts-w
2090: 61 69 74 6f 6e 20 20 20 20 20 28 6d 61 70 20 28 aiton (map (
20a0: 6c 61 6d 62 64 61 20 28 78 29 20 20 3b 3b 20 66 lambda (x) ;; f
20b0: 6f 72 20 65 61 63 68 20 69 6e 63 6f 6d 69 6e 67 or each incoming
20c0: 20 70 61 74 74 20 74 68 61 74 20 6d 61 74 63 68 patt that match
20d0: 65 73 20 74 68 65 20 77 61 69 74 69 6e 67 20 74 es the waiting t
20e0: 65 73 74 0a 09 09 09 09 20 20 28 6c 65 74 2a 20 est..... (let*
20f0: 28 28 6d 6f 64 70 61 74 74 20 28 69 66 20 69 74 ((modpatt (if it
2100: 65 6d 6d 61 70 20 28 64 62 3a 63 6f 6e 76 65 72 emmap (db:conver
2110: 74 2d 74 65 73 74 2d 69 74 65 6d 70 61 74 68 20 t-test-itempath
2120: 78 20 69 74 65 6d 6d 61 70 29 20 78 29 29 20 0a x itemmap) x)) .
2130: 09 09 09 09 09 20 28 6e 65 77 70 61 74 74 20 28 ..... (newpatt (
2140: 63 6f 6e 63 20 77 61 69 74 6f 6e 2d 74 65 73 74 conc waiton-test
2150: 20 22 2f 22 20 28 73 75 62 73 74 72 69 6e 67 20 "/" (substring
2160: 6d 6f 64 70 61 74 74 20 77 61 69 74 69 6e 67 2d modpatt waiting-
2170: 74 65 73 74 2d 6c 65 6e 20 28 73 74 72 69 6e 67 test-len (string
2180: 2d 6c 65 6e 67 74 68 20 6d 6f 64 70 61 74 74 29 -length modpatt)
2190: 29 29 29 29 0a 09 09 09 09 20 20 20 20 3b 3b 20 ))))..... ;;
21a0: 28 63 6f 6e 63 20 77 61 69 74 69 6e 67 2d 74 65 (conc waiting-te
21b0: 73 74 20 22 2f 2c 22 20 77 61 69 74 69 6e 67 2d st "/," waiting-
21c0: 74 65 73 74 20 22 2f 22 20 28 73 75 62 73 74 72 test "/" (substr
21d0: 69 6e 67 20 6d 6f 64 70 61 74 74 20 77 61 69 74 ing modpatt wait
21e0: 6f 6e 2d 74 65 73 74 2d 6c 65 6e 20 28 73 74 72 on-test-len (str
21f0: 69 6e 67 2d 6c 65 6e 67 74 68 20 6d 6f 64 70 61 ing-length modpa
2200: 74 74 29 29 29 29 29 0a 09 09 09 09 20 20 20 20 tt))))).....
2210: 3b 3b 20 28 70 72 69 6e 74 20 22 69 6e 20 6d 61 ;; (print "in ma
2220: 70 2c 20 78 3d 22 20 78 20 22 2c 20 6e 65 77 70 p, x=" x ", newp
2230: 61 74 74 3d 22 20 6e 65 77 70 61 74 74 29 0a 09 att=" newpatt)..
2240: 09 09 09 20 20 20 20 6e 65 77 70 61 74 74 29 29 ... newpatt))
2250: 0a 09 09 09 09 28 66 69 6c 74 65 72 20 28 6c 61 .....(filter (la
2260: 6d 62 64 61 20 28 78 29 0a 09 09 09 09 09 20 20 mbda (x)......
2270: 28 65 71 3f 20 28 73 75 62 73 74 72 69 6e 67 2d (eq? (substring-
2280: 69 6e 64 65 78 20 28 63 6f 6e 63 20 77 61 69 74 index (conc wait
2290: 69 6e 67 2d 74 65 73 74 20 22 2f 22 29 20 78 29 ing-test "/") x)
22a0: 20 30 29 29 20 3b 3b 20 69 73 20 74 68 69 73 20 0)) ;; is this
22b0: 70 61 74 74 20 70 65 72 74 69 6e 65 6e 74 20 74 patt pertinent t
22c0: 6f 20 74 68 65 20 77 61 69 74 69 6e 67 20 74 65 o the waiting te
22d0: 73 74 0a 09 09 09 09 09 70 61 74 74 73 29 29 29 st......patts)))
22e0: 0a 20 20 20 20 20 20 20 20 20 28 65 78 74 65 6e . (exten
22f0: 64 65 64 2d 74 65 73 74 2d 70 61 74 74 20 20 20 ded-test-patt
2300: 28 61 70 70 65 6e 64 20 70 61 74 74 73 20 28 69 (append patts (i
2310: 66 20 28 6e 75 6c 6c 3f 20 70 61 74 74 73 2d 77 f (null? patts-w
2320: 61 69 74 6f 6e 29 0a 20 20 20 20 20 20 20 20 20 aiton).
2330: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2340: 20 20 20 20 20 20 20 20 20 20 20 20 28 6c 69 73 (lis
2350: 74 20 28 63 6f 6e 63 20 77 61 69 74 6f 6e 2d 74 t (conc waiton-t
2360: 65 73 74 20 22 2f 25 22 29 29 20 3b 3b 20 72 65 est "/%")) ;; re
2370: 61 6c 6c 79 20 73 68 6f 75 6c 64 6e 27 74 20 61 ally shouldn't a
2380: 64 64 20 74 68 65 20 77 61 69 74 6f 6e 20 66 6f dd the waiton fo
2390: 72 63 65 66 75 6c 6c 79 20 6c 69 6b 65 20 74 68 rcefully like th
23a0: 69 73 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 is.
23b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
23c0: 20 20 20 20 20 20 20 20 70 61 74 74 73 2d 77 61 patts-wa
23d0: 69 74 6f 6e 29 29 29 0a 20 20 20 20 20 20 20 20 iton))).
23e0: 20 28 65 78 74 65 6e 64 65 64 2d 74 65 73 74 2d (extended-test-
23f0: 70 61 74 74 2d 77 69 74 68 2d 74 6f 70 6c 65 76 patt-with-toplev
2400: 65 6c 73 0a 20 20 20 20 20 20 20 20 20 20 28 66 els. (f
2410: 6f 6c 64 20 28 6c 61 6d 62 64 61 20 28 74 65 73 old (lambda (tes
2420: 74 70 61 74 74 2d 69 74 65 6d 20 61 63 63 75 6d tpatt-item accum
2430: 20 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
2440: 20 20 20 20 20 28 6c 65 74 20 28 28 6d 79 2d 6d (let ((my-m
2450: 61 74 63 68 20 28 73 74 72 69 6e 67 2d 6d 61 74 atch (string-mat
2460: 63 68 20 22 5e 28 5b 5e 25 5c 5c 2f 5d 2b 29 5c ch "^([^%\\/]+)\
2470: 5c 2f 2e 2b 24 22 20 74 65 73 74 70 61 74 74 2d \/.+$" testpatt-
2480: 69 74 65 6d 29 29 29 0a 20 20 20 20 20 20 20 20 item))).
2490: 20 20 20 20 20 20 20 20 20 20 20 20 28 63 6f 6e (con
24a0: 73 20 74 65 73 74 70 61 74 74 2d 69 74 65 6d 0a s testpatt-item.
24b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
24c0: 20 20 20 20 20 20 20 20 20 20 28 69 66 20 6d 79 (if my
24d0: 2d 6d 61 74 63 68 0a 20 20 20 20 20 20 20 20 20 -match.
24e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
24f0: 20 20 20 20 20 28 63 6f 6e 73 0a 20 20 20 20 20 (cons.
2500: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2510: 20 20 20 20 20 20 20 20 20 20 28 63 6f 6e 63 20 (conc
2520: 28 63 61 64 72 20 6d 79 2d 6d 61 74 63 68 29 20 (cadr my-match)
2530: 22 2f 22 29 0a 20 20 20 20 20 20 20 20 20 20 20 "/").
2540: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2550: 20 20 20 20 61 63 63 75 6d 29 0a 20 20 20 20 20 accum).
2560: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2570: 20 20 20 20 20 20 20 20 20 61 63 63 75 6d 29 29 accum))
2580: 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 )).
2590: 20 20 20 27 28 29 0a 20 20 20 20 20 20 20 20 20 '().
25a0: 20 20 20 20 20 20 20 65 78 74 65 6e 64 65 64 2d extended-
25b0: 74 65 73 74 2d 70 61 74 74 29 29 29 0a 20 20 20 test-patt))).
25c0: 20 28 73 74 72 69 6e 67 2d 69 6e 74 65 72 73 70 (string-intersp
25d0: 65 72 73 65 20 28 64 65 6c 65 74 65 2d 64 75 70 erse (delete-dup
25e0: 6c 69 63 61 74 65 73 20 65 78 74 65 6e 64 65 64 licates extended
25f0: 2d 74 65 73 74 2d 70 61 74 74 2d 77 69 74 68 2d -test-patt-with-
2600: 74 6f 70 6c 65 76 65 6c 73 29 20 22 2c 22 29 29 toplevels) ","))
2610: 29 0a 0a 0a 20 20 0a 3b 3b 20 74 65 73 74 73 3a )... .;; tests:
2620: 67 6c 6f 62 2d 6c 69 6b 65 2d 6d 61 74 63 68 20 glob-like-match
2630: 0a 28 64 65 66 69 6e 65 20 28 74 65 73 74 73 3a .(define (tests:
2640: 67 6c 6f 62 2d 6c 69 6b 65 2d 6d 61 74 63 68 20 glob-like-match
2650: 70 61 74 74 20 73 74 72 29 20 0a 20 20 28 6c 65 patt str) . (le
2660: 74 20 28 28 6c 69 6b 65 20 28 73 75 62 73 74 72 t ((like (substr
2670: 69 6e 67 2d 69 6e 64 65 78 20 22 25 22 20 70 61 ing-index "%" pa
2680: 74 74 29 29 29 0a 20 20 20 20 28 6c 65 74 2a 20 tt))). (let*
2690: 28 28 6e 6f 74 70 61 74 74 20 20 28 65 71 75 61 ((notpatt (equa
26a0: 6c 3f 20 28 73 75 62 73 74 72 69 6e 67 2d 69 6e l? (substring-in
26b0: 64 65 78 20 22 7e 22 20 70 61 74 74 29 20 30 29 dex "~" patt) 0)
26c0: 29 0a 09 20 20 20 28 6e 65 77 70 61 74 74 20 20 ).. (newpatt
26d0: 28 69 66 20 6e 6f 74 70 61 74 74 20 28 73 75 62 (if notpatt (sub
26e0: 73 74 72 69 6e 67 20 70 61 74 74 20 31 29 20 70 string patt 1) p
26f0: 61 74 74 29 29 0a 09 20 20 20 28 66 69 6e 70 61 att)).. (finpa
2700: 74 74 20 20 28 69 66 20 6c 69 6b 65 0a 09 09 09 tt (if like....
2710: 28 73 74 72 69 6e 67 2d 73 75 62 73 74 69 74 75 (string-substitu
2720: 74 65 20 28 72 65 67 65 78 70 20 22 25 22 29 20 te (regexp "%")
2730: 22 2e 2a 22 20 6e 65 77 70 61 74 74 20 23 66 29 ".*" newpatt #f)
2740: 0a 09 09 09 28 73 74 72 69 6e 67 2d 73 75 62 73 ....(string-subs
2750: 74 69 74 75 74 65 20 28 72 65 67 65 78 70 20 22 titute (regexp "
2760: 5c 5c 2a 22 29 20 22 2e 2a 22 20 6e 65 77 70 61 \\*") ".*" newpa
2770: 74 74 20 23 66 29 29 29 0a 09 20 20 20 28 72 65 tt #f))).. (re
2780: 73 20 20 20 20 20 20 23 66 29 29 0a 20 20 20 20 s #f)).
2790: 20 20 3b 3b 20 28 70 72 69 6e 74 20 22 74 65 73 ;; (print "tes
27a0: 74 73 3a 67 6c 6f 62 2d 6c 69 6b 65 2d 6d 61 74 ts:glob-like-mat
27b0: 63 68 20 3d 3e 20 6e 6f 74 70 61 74 74 3a 20 22 ch => notpatt: "
27c0: 20 6e 6f 74 70 61 74 74 20 22 2c 20 6e 65 77 70 notpatt ", newp
27d0: 61 74 74 3a 20 22 20 6e 65 77 70 61 74 74 20 22 att: " newpatt "
27e0: 2c 20 66 69 6e 70 61 74 74 3a 20 22 20 66 69 6e , finpatt: " fin
27f0: 70 61 74 74 29 0a 20 20 20 20 20 20 28 73 65 74 patt). (set
2800: 21 20 72 65 73 20 28 73 74 72 69 6e 67 2d 6d 61 ! res (string-ma
2810: 74 63 68 20 28 72 65 67 65 78 70 20 66 69 6e 70 tch (regexp finp
2820: 61 74 74 20 28 69 66 20 6c 69 6b 65 20 23 74 20 att (if like #t
2830: 23 66 29 29 20 73 74 72 29 29 0a 20 20 20 20 20 #f)) str)).
2840: 20 28 69 66 20 6e 6f 74 70 61 74 74 20 28 6e 6f (if notpatt (no
2850: 74 20 72 65 73 29 20 72 65 73 29 29 29 29 0a 0a t res) res))))..
2860: 3b 3b 20 69 66 20 69 74 65 6d 70 61 74 68 20 69 ;; if itempath i
2870: 73 20 23 66 20 74 68 65 6e 20 6c 6f 6f 6b 20 6f s #f then look o
2880: 6e 6c 79 20 61 74 20 74 68 65 20 74 65 73 74 6e nly at the testn
2890: 61 6d 65 20 70 61 72 74 0a 3b 3b 0a 28 64 65 66 ame part.;;.(def
28a0: 69 6e 65 20 28 74 65 73 74 73 3a 6d 61 74 63 68 ine (tests:match
28b0: 20 70 61 74 74 65 72 6e 73 20 74 65 73 74 6e 61 patterns testna
28c0: 6d 65 20 69 74 65 6d 70 61 74 68 20 23 21 6b 65 me itempath #!ke
28d0: 79 20 28 72 65 71 75 69 72 65 64 20 27 28 29 29 y (required '())
28e0: 29 0a 20 20 28 69 66 20 28 73 74 72 69 6e 67 3f ). (if (string?
28f0: 20 70 61 74 74 65 72 6e 73 29 0a 20 20 20 20 20 patterns).
2900: 20 28 6c 65 74 20 28 28 70 61 74 74 73 20 28 61 (let ((patts (a
2910: 70 70 65 6e 64 20 28 73 74 72 69 6e 67 2d 73 70 ppend (string-sp
2920: 6c 69 74 20 70 61 74 74 65 72 6e 73 20 22 2c 22 lit patterns ","
2930: 29 20 72 65 71 75 69 72 65 64 29 29 29 0a 09 28 ) required)))..(
2940: 69 66 20 28 6e 75 6c 6c 3f 20 70 61 74 74 73 29 if (null? patts)
2950: 20 3b 3b 3b 20 6e 6f 20 70 61 74 74 65 72 6e 28 ;;; no pattern(
2960: 73 29 20 6d 65 61 6e 73 20 6e 6f 20 6d 61 74 63 s) means no matc
2970: 68 0a 09 20 20 20 20 23 66 0a 09 20 20 20 20 28 h.. #f.. (
2980: 6c 65 74 20 6c 6f 6f 70 20 28 28 70 61 74 74 20 let loop ((patt
2990: 28 63 61 72 20 70 61 74 74 73 29 29 0a 09 09 20 (car patts))...
29a0: 20 20 20 20 20 20 28 74 61 6c 20 20 28 63 64 72 (tal (cdr
29b0: 20 70 61 74 74 73 29 29 29 0a 09 20 20 20 20 20 patts)))..
29c0: 20 3b 3b 20 28 70 72 69 6e 74 20 22 6c 6f 6f 70 ;; (print "loop
29d0: 3a 20 70 61 74 74 3a 20 22 20 70 61 74 74 20 22 : patt: " patt "
29e0: 2c 20 74 61 6c 20 22 20 74 61 6c 29 0a 09 20 20 , tal " tal)..
29f0: 20 20 20 20 28 69 66 20 28 73 74 72 69 6e 67 3d (if (string=
2a00: 3f 20 70 61 74 74 20 22 22 29 0a 09 09 20 20 23 ? patt "")... #
2a10: 66 20 3b 3b 20 6e 6f 74 68 69 6e 67 20 65 76 65 f ;; nothing eve
2a20: 72 20 6d 61 74 63 68 65 73 20 65 6d 70 74 79 20 r matches empty
2a30: 73 74 72 69 6e 67 20 2d 20 70 6f 6c 69 63 79 0a string - policy.
2a40: 09 09 20 20 28 6c 65 74 2a 20 28 28 70 61 74 74 .. (let* ((patt
2a50: 2d 70 61 72 74 73 20 28 73 74 72 69 6e 67 2d 6d -parts (string-m
2a60: 61 74 63 68 20 28 72 65 67 65 78 70 20 22 5e 28 atch (regexp "^(
2a70: 5b 5e 5c 5c 2f 5d 2a 29 28 5c 5c 2f 28 2e 2a 29 [^\\/]*)(\\/(.*)
2a80: 7c 29 24 22 29 20 70 61 74 74 29 29 0a 09 09 09 |)$") patt))....
2a90: 20 28 74 65 73 74 2d 70 61 74 74 20 20 28 63 61 (test-patt (ca
2aa0: 64 72 20 70 61 74 74 2d 70 61 72 74 73 29 29 0a dr patt-parts)).
2ab0: 09 09 09 20 28 69 74 65 6d 2d 70 61 74 74 20 20 ... (item-patt
2ac0: 28 63 61 64 64 64 72 20 70 61 74 74 2d 70 61 72 (cadddr patt-par
2ad0: 74 73 29 29 29 0a 09 09 20 20 20 20 3b 3b 20 73 ts)))... ;; s
2ae0: 70 65 63 69 61 6c 20 63 61 73 65 3a 20 74 65 73 pecial case: tes
2af0: 74 20 76 73 2e 20 74 65 73 74 2f 0a 09 09 20 20 t vs. test/...
2b00: 20 20 3b 3b 20 20 20 74 65 73 74 20 20 3d 3e 20 ;; test =>
2b10: 22 74 65 73 74 22 20 22 25 22 0a 09 09 20 20 20 "test" "%"...
2b20: 20 3b 3b 20 20 20 74 65 73 74 2f 20 3d 3e 20 22 ;; test/ => "
2b30: 74 65 73 74 22 20 22 22 0a 09 09 20 20 20 20 28 test" ""... (
2b40: 69 66 20 28 61 6e 64 20 28 6e 6f 74 20 28 73 75 if (and (not (su
2b50: 62 73 74 72 69 6e 67 2d 69 6e 64 65 78 20 22 2f bstring-index "/
2b60: 22 20 70 61 74 74 29 29 20 3b 3b 20 6e 6f 20 73 " patt)) ;; no s
2b70: 6c 61 73 68 20 69 6e 20 74 68 65 20 6f 72 69 67 lash in the orig
2b80: 69 6e 61 6c 0a 09 09 09 20 20 20 20 20 28 6f 72 inal.... (or
2b90: 20 28 6e 6f 74 20 69 74 65 6d 2d 70 61 74 74 29 (not item-patt)
2ba0: 0a 09 09 09 09 20 28 65 71 75 61 6c 3f 20 69 74 ..... (equal? it
2bb0: 65 6d 2d 70 61 74 74 20 22 22 29 29 29 20 20 20 em-patt "")))
2bc0: 20 20 20 3b 3b 20 73 68 6f 75 6c 64 20 61 6c 77 ;; should alw
2bd0: 61 79 73 20 62 65 20 74 72 75 65 20 74 68 61 74 ays be true that
2be0: 20 69 74 65 6d 2d 70 61 74 74 20 69 73 20 22 22 item-patt is ""
2bf0: 0a 09 09 09 28 73 65 74 21 20 69 74 65 6d 2d 70 ....(set! item-p
2c00: 61 74 74 20 22 25 22 29 29 0a 09 09 20 20 20 20 att "%"))...
2c10: 3b 3b 20 28 70 72 69 6e 74 20 22 74 65 73 74 73 ;; (print "tests
2c20: 3a 6d 61 74 63 68 20 3d 3e 20 70 61 74 74 2d 70 :match => patt-p
2c30: 61 72 74 73 3a 20 22 20 70 61 74 74 2d 70 61 72 arts: " patt-par
2c40: 74 73 20 22 2c 20 74 65 73 74 2d 70 61 74 74 3a ts ", test-patt:
2c50: 20 22 20 74 65 73 74 2d 70 61 74 74 20 22 2c 20 " test-patt ",
2c60: 69 74 65 6d 2d 70 61 74 74 3a 20 22 20 69 74 65 item-patt: " ite
2c70: 6d 2d 70 61 74 74 29 0a 09 09 20 20 20 20 28 69 m-patt)... (i
2c80: 66 20 28 61 6e 64 20 28 74 65 73 74 73 3a 67 6c f (and (tests:gl
2c90: 6f 62 2d 6c 69 6b 65 2d 6d 61 74 63 68 20 74 65 ob-like-match te
2ca0: 73 74 2d 70 61 74 74 20 74 65 73 74 6e 61 6d 65 st-patt testname
2cb0: 29 0a 09 09 09 20 20 20 20 20 28 6f 72 20 28 6e ).... (or (n
2cc0: 6f 74 20 69 74 65 6d 70 61 74 68 29 0a 09 09 09 ot itempath)....
2cd0: 09 20 28 74 65 73 74 73 3a 67 6c 6f 62 2d 6c 69 . (tests:glob-li
2ce0: 6b 65 2d 6d 61 74 63 68 20 28 69 66 20 69 74 65 ke-match (if ite
2cf0: 6d 2d 70 61 74 74 20 69 74 65 6d 2d 70 61 74 74 m-patt item-patt
2d00: 20 22 22 29 20 69 74 65 6d 70 61 74 68 29 29 29 "") itempath)))
2d10: 0a 09 09 09 23 74 0a 09 09 09 28 69 66 20 28 6e ....#t....(if (n
2d20: 75 6c 6c 3f 20 74 61 6c 29 0a 09 09 09 20 20 20 ull? tal)....
2d30: 20 23 66 0a 09 09 09 20 20 20 20 28 6c 6f 6f 70 #f.... (loop
2d40: 20 28 63 61 72 20 74 61 6c 29 28 63 64 72 20 74 (car tal)(cdr t
2d50: 61 6c 29 29 29 29 29 29 29 29 29 29 29 0a 0a 3b al)))))))))))..;
2d60: 3b 20 69 66 20 69 74 65 6d 70 61 74 68 20 69 73 ; if itempath is
2d70: 20 23 66 20 74 68 65 6e 20 6c 6f 6f 6b 20 6f 6e #f then look on
2d80: 6c 79 20 61 74 20 74 68 65 20 74 65 73 74 6e 61 ly at the testna
2d90: 6d 65 20 70 61 72 74 0a 3b 3b 0a 28 64 65 66 69 me part.;;.(defi
2da0: 6e 65 20 28 74 65 73 74 73 3a 6d 61 74 63 68 2d ne (tests:match-
2db0: 3e 73 71 6c 71 72 79 20 70 61 74 74 65 72 6e 73 >sqlqry patterns
2dc0: 29 0a 20 20 28 69 66 20 28 73 74 72 69 6e 67 3f ). (if (string?
2dd0: 20 70 61 74 74 65 72 6e 73 29 0a 20 20 20 20 20 patterns).
2de0: 20 28 6c 65 74 20 28 28 70 61 74 74 73 20 28 73 (let ((patts (s
2df0: 74 72 69 6e 67 2d 73 70 6c 69 74 20 70 61 74 74 tring-split patt
2e00: 65 72 6e 73 20 22 2c 22 29 29 29 0a 09 28 69 66 erns ",")))..(if
2e10: 20 28 6e 75 6c 6c 3f 20 70 61 74 74 73 29 20 3b (null? patts) ;
2e20: 3b 3b 20 6e 6f 20 70 61 74 74 65 72 6e 28 73 29 ;; no pattern(s)
2e30: 20 6d 65 61 6e 73 20 6e 6f 20 6d 61 74 63 68 2c means no match,
2e40: 20 77 65 20 77 69 6c 6c 20 64 6f 20 6e 6f 20 71 we will do no q
2e50: 75 65 72 79 0a 09 20 20 20 20 23 66 0a 09 20 20 uery.. #f..
2e60: 20 20 28 6c 65 74 20 6c 6f 6f 70 20 28 28 70 61 (let loop ((pa
2e70: 74 74 20 28 63 61 72 20 70 61 74 74 73 29 29 0a tt (car patts)).
2e80: 09 09 20 20 20 20 20 20 20 28 74 61 6c 20 20 28 .. (tal (
2e90: 63 64 72 20 70 61 74 74 73 29 29 0a 09 09 20 20 cdr patts))...
2ea0: 20 20 20 20 20 28 72 65 73 20 20 27 28 29 29 29 (res '()))
2eb0: 0a 09 20 20 20 20 20 20 3b 3b 20 28 70 72 69 6e .. ;; (prin
2ec0: 74 20 22 6c 6f 6f 70 3a 20 70 61 74 74 3a 20 22 t "loop: patt: "
2ed0: 20 70 61 74 74 20 22 2c 20 74 61 6c 20 22 20 74 patt ", tal " t
2ee0: 61 6c 29 0a 09 20 20 20 20 20 20 28 6c 65 74 2a al).. (let*
2ef0: 20 28 28 70 61 74 74 2d 70 61 72 74 73 20 28 73 ((patt-parts (s
2f00: 74 72 69 6e 67 2d 6d 61 74 63 68 20 28 72 65 67 tring-match (reg
2f10: 65 78 70 20 22 5e 28 5b 5e 5c 5c 2f 5d 2a 29 28 exp "^([^\\/]*)(
2f20: 5c 5c 2f 28 2e 2a 29 7c 29 24 22 29 20 70 61 74 \\/(.*)|)$") pat
2f30: 74 29 29 0a 09 09 20 20 20 20 20 28 74 65 73 74 t))... (test
2f40: 2d 70 61 74 74 20 20 28 63 61 64 72 20 70 61 74 -patt (cadr pat
2f50: 74 2d 70 61 72 74 73 29 29 0a 09 09 20 20 20 20 t-parts))...
2f60: 20 28 69 74 65 6d 2d 70 61 74 74 20 20 28 63 61 (item-patt (ca
2f70: 64 64 64 72 20 70 61 74 74 2d 70 61 72 74 73 29 dddr patt-parts)
2f80: 29 0a 09 09 20 20 20 20 20 28 74 65 73 74 2d 71 )... (test-q
2f90: 72 79 20 20 20 28 64 62 3a 70 61 74 74 2d 3e 6c ry (db:patt->l
2fa0: 69 6b 65 20 22 74 65 73 74 6e 61 6d 65 22 20 74 ike "testname" t
2fb0: 65 73 74 2d 70 61 74 74 29 29 0a 09 09 20 20 20 est-patt))...
2fc0: 20 20 28 69 74 65 6d 2d 71 72 79 20 20 20 28 64 (item-qry (d
2fd0: 62 3a 70 61 74 74 2d 3e 6c 69 6b 65 20 22 69 74 b:patt->like "it
2fe0: 65 6d 5f 70 61 74 68 22 20 69 74 65 6d 2d 70 61 em_path" item-pa
2ff0: 74 74 29 29 0a 09 09 20 20 20 20 20 28 71 72 79 tt))... (qry
3000: 20 20 20 20 20 20 20 20 28 63 6f 6e 63 20 22 28 (conc "(
3010: 22 20 74 65 73 74 2d 71 72 79 20 22 20 41 4e 44 " test-qry " AND
3020: 20 22 20 69 74 65 6d 2d 71 72 79 20 22 29 22 29 " item-qry ")")
3030: 29 29 0a 09 09 3b 3b 20 28 70 72 69 6e 74 20 22 ))...;; (print "
3040: 74 65 73 74 73 3a 6d 61 74 63 68 20 3d 3e 20 70 tests:match => p
3050: 61 74 74 2d 70 61 72 74 73 3a 20 22 20 70 61 74 att-parts: " pat
3060: 74 2d 70 61 72 74 73 20 22 2c 20 74 65 73 74 2d t-parts ", test-
3070: 70 61 74 74 3a 20 22 20 74 65 73 74 2d 70 61 74 patt: " test-pat
3080: 74 20 22 2c 20 69 74 65 6d 2d 70 61 74 74 3a 20 t ", item-patt:
3090: 22 20 69 74 65 6d 2d 70 61 74 74 29 0a 09 09 28 " item-patt)...(
30a0: 69 66 20 28 6e 75 6c 6c 3f 20 74 61 6c 29 0a 09 if (null? tal)..
30b0: 09 20 20 20 20 28 73 74 72 69 6e 67 2d 69 6e 74 . (string-int
30c0: 65 72 73 70 65 72 73 65 20 28 61 70 70 65 6e 64 ersperse (append
30d0: 20 28 72 65 76 65 72 73 65 20 72 65 73 29 28 6c (reverse res)(l
30e0: 69 73 74 20 71 72 79 29 29 20 22 20 4f 52 20 22 ist qry)) " OR "
30f0: 29 0a 09 09 20 20 20 20 28 6c 6f 6f 70 20 28 63 )... (loop (c
3100: 61 72 20 74 61 6c 29 28 63 64 72 20 74 61 6c 29 ar tal)(cdr tal)
3110: 28 63 6f 6e 73 20 71 72 79 20 72 65 73 29 29 29 (cons qry res)))
3120: 29 29 29 29 0a 20 20 20 20 20 20 23 66 29 29 0a )))). #f)).
3130: 0a 3b 3b 20 43 68 65 63 6b 20 66 6f 72 20 77 61 .;; Check for wa
3140: 69 76 65 72 20 65 6c 69 67 69 62 69 6c 69 74 79 iver eligibility
3150: 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 74 65 73 .;;.(define (tes
3160: 74 73 3a 63 68 65 63 6b 2d 77 61 69 76 65 72 2d ts:check-waiver-
3170: 65 6c 69 67 69 62 69 6c 69 74 79 20 74 65 73 74 eligibility test
3180: 64 61 74 20 70 72 65 76 2d 74 65 73 74 64 61 74 dat prev-testdat
3190: 29 0a 20 20 28 6c 65 74 2a 20 28 28 74 65 73 74 ). (let* ((test
31a0: 2d 72 65 67 69 73 74 72 79 20 28 6d 61 6b 65 2d -registry (make-
31b0: 68 61 73 68 2d 74 61 62 6c 65 29 29 0a 09 20 28 hash-table)).. (
31c0: 74 65 73 74 63 6f 6e 66 69 67 20 20 28 74 65 73 testconfig (tes
31d0: 74 73 3a 67 65 74 2d 74 65 73 74 63 6f 6e 66 69 ts:get-testconfi
31e0: 67 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 74 g (db:test-get-t
31f0: 65 73 74 6e 61 6d 65 20 74 65 73 74 64 61 74 29 estname testdat)
3200: 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 69 74 (db:test-get-it
3210: 65 6d 2d 70 61 74 68 20 74 65 73 74 64 61 74 29 em-path testdat)
3220: 20 74 65 73 74 2d 72 65 67 69 73 74 72 79 20 23 test-registry #
3230: 66 29 29 0a 09 20 28 74 65 73 74 2d 72 75 6e 64 f)).. (test-rund
3240: 69 72 20 3b 3b 20 28 73 64 62 3a 71 72 79 20 27 ir ;; (sdb:qry '
3250: 70 61 73 73 73 74 72 20 0a 09 20 20 28 64 62 3a passstr .. (db:
3260: 74 65 73 74 2d 67 65 74 2d 72 75 6e 64 69 72 20 test-get-rundir
3270: 74 65 73 74 64 61 74 29 29 20 3b 3b 20 29 0a 09 testdat)) ;; )..
3280: 20 28 70 72 65 76 2d 72 75 6e 64 69 72 20 3b 3b (prev-rundir ;;
3290: 20 28 73 64 62 3a 71 72 79 20 27 70 61 73 73 73 (sdb:qry 'passs
32a0: 74 72 20 0a 09 20 20 28 64 62 3a 74 65 73 74 2d tr .. (db:test-
32b0: 67 65 74 2d 72 75 6e 64 69 72 20 70 72 65 76 2d get-rundir prev-
32c0: 74 65 73 74 64 61 74 29 29 20 3b 3b 20 29 0a 09 testdat)) ;; )..
32d0: 20 28 77 61 69 76 65 72 73 20 20 20 20 20 28 69 (waivers (i
32e0: 66 20 74 65 73 74 63 6f 6e 66 69 67 20 28 63 6f f testconfig (co
32f0: 6e 66 69 67 66 3a 73 65 63 74 69 6f 6e 2d 76 61 nfigf:section-va
3300: 72 73 20 74 65 73 74 63 6f 6e 66 69 67 20 22 77 rs testconfig "w
3310: 61 69 76 65 72 73 22 29 20 27 28 29 29 29 0a 09 aivers") '()))..
3320: 20 28 77 61 69 76 65 72 2d 72 78 20 20 20 28 72 (waiver-rx (r
3330: 65 67 65 78 70 20 22 5e 28 5c 5c 53 2b 29 5c 5c egexp "^(\\S+)\\
3340: 73 2b 28 2e 2a 29 24 22 29 29 0a 09 20 28 64 69 s+(.*)$")).. (di
3350: 66 66 2d 72 75 6c 65 20 20 20 22 64 69 66 66 20 ff-rule "diff
3360: 25 66 69 6c 65 31 25 20 25 66 69 6c 65 32 25 22 %file1% %file2%"
3370: 29 0a 09 20 28 6c 6f 67 70 72 6f 2d 72 75 6c 65 ).. (logpro-rule
3380: 20 22 64 69 66 66 20 25 66 69 6c 65 31 25 20 25 "diff %file1% %
3390: 66 69 6c 65 32 25 20 7c 20 6c 6f 67 70 72 6f 20 file2% | logpro
33a0: 25 77 61 69 76 65 72 6e 61 6d 65 25 2e 6c 6f 67 %waivername%.log
33b0: 70 72 6f 20 25 77 61 69 76 65 72 6e 61 6d 65 25 pro %waivername%
33c0: 2e 68 74 6d 6c 22 29 29 0a 20 20 20 20 28 69 66 .html")). (if
33d0: 20 28 6e 6f 74 20 28 63 6f 6d 6d 6f 6e 3a 66 69 (not (common:fi
33e0: 6c 65 2d 65 78 69 73 74 73 3f 20 74 65 73 74 2d le-exists? test-
33f0: 72 75 6e 64 69 72 29 29 0a 09 28 62 65 67 69 6e rundir))..(begin
3400: 0a 09 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 .. (debug:print
3410: 2d 65 72 72 6f 72 20 30 20 2a 64 65 66 61 75 6c -error 0 *defaul
3420: 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 74 65 73 t-log-port* "tes
3430: 74 20 72 75 6e 20 64 69 72 65 63 74 6f 72 79 20 t run directory
3440: 69 73 20 67 6f 6e 65 2c 20 63 61 6e 6e 6f 74 20 is gone, cannot
3450: 70 72 6f 70 61 67 61 74 65 20 77 61 69 76 65 72 propagate waiver
3460: 22 29 0a 09 20 20 23 66 29 0a 09 28 62 65 67 69 ").. #f)..(begi
3470: 6e 0a 09 20 20 28 70 75 73 68 2d 64 69 72 65 63 n.. (push-direc
3480: 74 6f 72 79 20 74 65 73 74 2d 72 75 6e 64 69 72 tory test-rundir
3490: 29 0a 09 20 20 28 6c 65 74 20 28 28 72 65 73 75 ).. (let ((resu
34a0: 6c 74 20 28 69 66 20 28 6e 75 6c 6c 3f 20 77 61 lt (if (null? wa
34b0: 69 76 65 72 73 29 0a 09 09 09 20 20 20 20 23 66 ivers).... #f
34c0: 0a 09 09 09 20 20 20 20 28 6c 65 74 20 6c 6f 6f .... (let loo
34d0: 70 20 28 28 68 65 64 20 28 63 61 72 20 77 61 69 p ((hed (car wai
34e0: 76 65 72 73 29 29 0a 09 09 09 09 20 20 20 20 20 vers)).....
34f0: 20 20 28 74 61 6c 20 28 63 64 72 20 77 61 69 76 (tal (cdr waiv
3500: 65 72 73 29 29 29 0a 09 09 09 20 20 20 20 20 20 ers)))....
3510: 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 2a (debug:print 0 *
3520: 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 default-log-port
3530: 2a 20 22 49 4e 46 4f 3a 20 41 70 70 6c 79 69 6e * "INFO: Applyin
3540: 67 20 77 61 69 76 65 72 20 72 75 6c 65 20 5c 22 g waiver rule \"
3550: 22 20 68 65 64 20 22 5c 22 22 29 0a 09 09 09 20 " hed "\"")....
3560: 20 20 20 20 20 28 6c 65 74 2a 20 28 28 77 61 69 (let* ((wai
3570: 76 65 72 20 20 20 20 20 20 28 63 6f 6e 66 69 67 ver (config
3580: 66 3a 6c 6f 6f 6b 75 70 20 74 65 73 74 63 6f 6e f:lookup testcon
3590: 66 69 67 20 22 77 61 69 76 65 72 73 22 20 68 65 fig "waivers" he
35a0: 64 29 29 0a 09 09 09 09 20 20 20 20 20 28 77 70 d))..... (wp
35b0: 61 72 74 73 20 20 20 20 20 20 28 69 66 20 77 61 arts (if wa
35c0: 69 76 65 72 20 28 73 74 72 69 6e 67 2d 6d 61 74 iver (string-mat
35d0: 63 68 20 77 61 69 76 65 72 2d 72 78 20 77 61 69 ch waiver-rx wai
35e0: 76 65 72 29 20 23 66 29 29 0a 09 09 09 09 20 20 ver) #f)).....
35f0: 20 20 20 28 77 61 69 76 65 72 2d 72 75 6c 65 20 (waiver-rule
3600: 28 69 66 20 77 70 61 72 74 73 20 28 63 61 64 72 (if wparts (cadr
3610: 20 77 70 61 72 74 73 29 20 20 23 66 29 29 0a 09 wparts) #f))..
3620: 09 09 09 20 20 20 20 20 28 77 61 69 76 65 72 2d ... (waiver-
3630: 67 6c 6f 62 20 28 69 66 20 77 70 61 72 74 73 20 glob (if wparts
3640: 28 63 61 64 64 72 20 77 70 61 72 74 73 29 20 23 (caddr wparts) #
3650: 66 29 29 0a 09 09 09 09 20 20 20 20 20 28 6c 6f f))..... (lo
3660: 67 70 72 6f 2d 66 69 6c 65 20 28 69 66 20 77 61 gpro-file (if wa
3670: 69 76 65 72 0a 09 09 09 09 09 09 20 20 20 20 20 iver.......
3680: 20 28 6c 65 74 20 28 28 66 6e 61 6d 65 20 28 63 (let ((fname (c
3690: 6f 6e 63 20 68 65 64 20 22 2e 6c 6f 67 70 72 6f onc hed ".logpro
36a0: 22 29 29 29 0a 09 09 09 09 09 09 09 28 69 66 20 ")))........(if
36b0: 28 63 6f 6d 6d 6f 6e 3a 66 69 6c 65 2d 65 78 69 (common:file-exi
36c0: 73 74 73 3f 20 66 6e 61 6d 65 29 0a 09 09 09 09 sts? fname).....
36d0: 09 09 09 20 20 20 20 66 6e 61 6d 65 20 0a 09 09 ... fname ...
36e0: 09 09 09 09 09 20 20 20 20 28 62 65 67 69 6e 0a ..... (begin.
36f0: 09 09 09 09 09 09 09 20 20 20 20 20 20 28 64 65 ....... (de
3700: 62 75 67 3a 70 72 69 6e 74 20 30 20 2a 64 65 66 bug:print 0 *def
3710: 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 ault-log-port* "
3720: 49 4e 46 4f 3a 20 4e 6f 20 6c 6f 67 70 72 6f 20 INFO: No logpro
3730: 66 69 6c 65 20 22 20 66 6e 61 6d 65 20 22 20 66 file " fname " f
3740: 61 6c 6c 69 6e 67 20 62 61 63 6b 20 74 6f 20 64 alling back to d
3750: 69 66 66 22 29 0a 09 09 09 09 09 09 09 20 20 20 iff")........
3760: 20 20 20 23 66 29 29 29 0a 09 09 09 09 09 09 20 #f))).......
3770: 20 20 20 20 20 23 66 29 29 0a 09 09 09 09 20 20 #f)).....
3780: 20 20 20 3b 3b 20 69 66 20 72 75 6c 65 20 62 79 ;; if rule by
3790: 20 6e 61 6d 65 20 6f 66 20 77 61 69 76 65 72 2d name of waiver-
37a0: 72 75 6c 65 20 69 73 20 66 6f 75 6e 64 20 69 6e rule is found in
37b0: 20 74 65 73 74 63 6f 6e 66 69 67 20 2d 20 75 73 testconfig - us
37c0: 65 20 69 74 0a 09 09 09 09 20 20 20 20 20 3b 3b e it..... ;;
37d0: 20 65 6c 73 65 20 69 66 20 77 61 69 76 65 72 6e else if waivern
37e0: 61 6d 65 2e 6c 6f 67 70 72 6f 20 65 78 69 73 74 ame.logpro exist
37f0: 73 20 75 73 65 20 6c 6f 67 70 72 6f 2d 72 75 6c s use logpro-rul
3800: 65 0a 09 09 09 09 20 20 20 20 20 3b 3b 20 65 6c e..... ;; el
3810: 73 65 20 64 65 66 61 75 6c 74 20 74 6f 20 64 69 se default to di
3820: 66 66 2d 72 75 6c 65 0a 09 09 09 09 20 20 20 20 ff-rule.....
3830: 20 28 72 75 6c 65 2d 73 74 72 69 6e 67 20 28 6c (rule-string (l
3840: 65 74 20 28 28 72 75 6c 65 20 28 63 6f 6e 66 69 et ((rule (confi
3850: 67 66 3a 6c 6f 6f 6b 75 70 20 74 65 73 74 63 6f gf:lookup testco
3860: 6e 66 69 67 20 22 77 61 69 76 65 72 5f 72 75 6c nfig "waiver_rul
3870: 65 73 22 20 77 61 69 76 65 72 2d 72 75 6c 65 29 es" waiver-rule)
3880: 29 29 0a 09 09 09 09 09 09 20 20 20 20 28 69 66 ))....... (if
3890: 20 72 75 6c 65 0a 09 09 09 09 09 09 09 72 75 6c rule........rul
38a0: 65 0a 09 09 09 09 09 09 09 28 69 66 20 6c 6f 67 e........(if log
38b0: 70 72 6f 2d 66 69 6c 65 0a 09 09 09 09 09 09 09 pro-file........
38c0: 20 20 20 20 6c 6f 67 70 72 6f 2d 72 75 6c 65 0a logpro-rule.
38d0: 09 09 09 09 09 09 09 20 20 20 20 28 62 65 67 69 ....... (begi
38e0: 6e 0a 09 09 09 09 09 09 09 20 20 20 20 20 20 28 n........ (
38f0: 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 2a 64 debug:print 0 *d
3900: 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a efault-log-port*
3910: 20 22 49 4e 46 4f 3a 20 4e 6f 20 6c 6f 67 70 72 "INFO: No logpr
3920: 6f 20 66 69 6c 65 20 22 20 6c 6f 67 70 72 6f 2d o file " logpro-
3930: 66 69 6c 65 20 22 20 66 6f 75 6e 64 2c 20 75 73 file " found, us
3940: 69 6e 67 20 64 69 66 66 20 72 75 6c 65 22 29 0a ing diff rule").
3950: 09 09 09 09 09 09 09 20 20 20 20 20 20 64 69 66 ....... dif
3960: 66 2d 72 75 6c 65 29 29 29 29 29 0a 09 09 09 09 f-rule))))).....
3970: 20 20 20 20 20 3b 3b 20 28 73 74 72 69 6e 67 2d ;; (string-
3980: 73 75 62 73 74 69 74 75 74 65 20 22 25 66 69 6c substitute "%fil
3990: 65 31 25 22 20 22 66 6f 6f 66 6f 6f 2e 74 78 74 e1%" "foofoo.txt
39a0: 22 20 22 54 68 69 73 20 69 73 20 25 66 69 6c 65 " "This is %file
39b0: 31 25 20 61 6e 64 20 73 6f 20 69 73 20 74 68 69 1% and so is thi
39c0: 73 20 25 66 69 6c 65 31 25 2e 22 20 23 74 29 0a s %file1%." #t).
39d0: 09 09 09 09 20 20 20 20 20 28 70 72 6f 63 65 73 .... (proces
39e0: 73 65 64 2d 63 6d 64 20 28 73 74 72 69 6e 67 2d sed-cmd (string-
39f0: 73 75 62 73 74 69 74 75 74 65 20 0a 09 09 09 09 substitute .....
3a00: 09 09 20 20 20 20 20 22 25 66 69 6c 65 31 25 22 .. "%file1%"
3a10: 20 28 63 6f 6e 63 20 74 65 73 74 2d 72 75 6e 64 (conc test-rund
3a20: 69 72 20 22 2f 22 20 77 61 69 76 65 72 2d 67 6c ir "/" waiver-gl
3a30: 6f 62 29 0a 09 09 09 09 09 09 20 20 20 20 20 28 ob)....... (
3a40: 73 74 72 69 6e 67 2d 73 75 62 73 74 69 74 75 74 string-substitut
3a50: 65 0a 09 09 09 09 09 09 20 20 20 20 20 20 22 25 e....... "%
3a60: 66 69 6c 65 32 25 22 20 28 63 6f 6e 63 20 70 72 file2%" (conc pr
3a70: 65 76 2d 72 75 6e 64 69 72 20 22 2f 22 20 77 61 ev-rundir "/" wa
3a80: 69 76 65 72 2d 67 6c 6f 62 29 0a 09 09 09 09 09 iver-glob)......
3a90: 09 20 20 20 20 20 20 28 73 74 72 69 6e 67 2d 73 . (string-s
3aa0: 75 62 73 74 69 74 75 74 65 0a 09 09 09 09 09 09 ubstitute.......
3ab0: 20 20 20 20 20 20 20 22 25 77 61 69 76 65 72 6e "%waivern
3ac0: 61 6d 65 25 22 20 68 65 64 20 72 75 6c 65 2d 73 ame%" hed rule-s
3ad0: 74 72 69 6e 67 20 23 74 29 20 23 74 29 20 23 74 tring #t) #t) #t
3ae0: 29 29 0a 09 09 09 09 20 20 20 20 20 28 72 65 73 ))..... (res
3af0: 20 20 20 20 20 20 20 20 20 20 20 20 23 66 29 29 #f))
3b00: 0a 09 09 09 09 28 64 65 62 75 67 3a 70 72 69 6e .....(debug:prin
3b10: 74 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 t 0 *default-log
3b20: 2d 70 6f 72 74 2a 20 22 49 4e 46 4f 3a 20 77 61 -port* "INFO: wa
3b30: 69 76 65 72 20 63 6f 6d 6d 61 6e 64 20 69 73 20 iver command is
3b40: 5c 22 22 20 70 72 6f 63 65 73 73 65 64 2d 63 6d \"" processed-cm
3b50: 64 20 22 5c 22 22 29 0a 09 09 09 09 28 69 66 20 d "\"").....(if
3b60: 28 65 71 3f 20 28 73 79 73 74 65 6d 20 70 72 6f (eq? (system pro
3b70: 63 65 73 73 65 64 2d 63 6d 64 29 20 30 29 0a 09 cessed-cmd) 0)..
3b80: 09 09 09 20 20 20 20 28 69 66 20 28 6e 75 6c 6c ... (if (null
3b90: 3f 20 74 61 6c 29 0a 09 09 09 09 09 23 74 0a 09 ? tal)......#t..
3ba0: 09 09 09 09 28 6c 6f 6f 70 20 28 63 61 72 20 74 ....(loop (car t
3bb0: 61 6c 29 28 63 64 72 20 74 61 6c 29 29 29 0a 09 al)(cdr tal)))..
3bc0: 09 09 09 20 20 20 20 23 66 29 29 29 29 29 29 0a ... #f)))))).
3bd0: 09 20 20 20 20 28 70 6f 70 2d 64 69 72 65 63 74 . (pop-direct
3be0: 6f 72 79 29 0a 09 20 20 20 20 72 65 73 75 6c 74 ory).. result
3bf0: 29 29 29 29 29 0a 0a 3b 3b 20 44 6f 20 6e 6f 74 )))))..;; Do not
3c00: 20 72 70 63 20 74 68 69 73 20 6f 6e 65 2c 20 64 rpc this one, d
3c10: 6f 20 74 68 65 20 75 6e 64 65 72 6c 79 69 6e 67 o the underlying
3c20: 20 63 61 6c 6c 73 21 21 21 0a 28 64 65 66 69 6e calls!!!.(defin
3c30: 65 20 28 74 65 73 74 73 3a 74 65 73 74 2d 73 65 e (tests:test-se
3c40: 74 2d 73 74 61 74 75 73 21 20 72 75 6e 2d 69 64 t-status! run-id
3c50: 20 74 65 73 74 2d 69 64 20 73 74 61 74 65 20 73 test-id state s
3c60: 74 61 74 75 73 20 63 6f 6d 6d 65 6e 74 20 64 61 tatus comment da
3c70: 74 20 23 21 6b 65 79 20 28 77 6f 72 6b 2d 61 72 t #!key (work-ar
3c80: 65 61 20 23 66 29 29 0a 20 20 28 6c 65 74 2a 20 ea #f)). (let*
3c90: 28 28 72 65 61 6c 2d 73 74 61 74 75 73 20 73 74 ((real-status st
3ca0: 61 74 75 73 29 0a 09 20 28 6f 74 68 65 72 64 61 atus).. (otherda
3cb0: 74 20 20 20 20 28 69 66 20 64 61 74 20 64 61 74 t (if dat dat
3cc0: 20 28 6d 61 6b 65 2d 68 61 73 68 2d 74 61 62 6c (make-hash-tabl
3cd0: 65 29 29 29 0a 09 20 28 74 65 73 74 64 61 74 20 e))).. (testdat
3ce0: 20 20 20 20 28 72 6d 74 3a 67 65 74 2d 74 65 73 (rmt:get-tes
3cf0: 74 2d 69 6e 66 6f 2d 62 79 2d 69 64 20 72 75 6e t-info-by-id run
3d00: 2d 69 64 20 74 65 73 74 2d 69 64 29 29 0a 09 20 -id test-id))..
3d10: 28 74 65 73 74 2d 6e 61 6d 65 20 20 20 28 64 62 (test-name (db
3d20: 3a 74 65 73 74 2d 67 65 74 2d 74 65 73 74 6e 61 :test-get-testna
3d30: 6d 65 20 20 74 65 73 74 64 61 74 29 29 0a 09 20 me testdat))..
3d40: 28 69 74 65 6d 2d 70 61 74 68 20 20 20 28 64 62 (item-path (db
3d50: 3a 74 65 73 74 2d 67 65 74 2d 69 74 65 6d 2d 70 :test-get-item-p
3d60: 61 74 68 20 74 65 73 74 64 61 74 29 29 0a 09 20 ath testdat))..
3d70: 3b 3b 20 62 65 66 6f 72 65 20 70 72 6f 63 65 65 ;; before procee
3d80: 64 69 6e 67 20 77 65 20 6d 75 73 74 20 66 69 6e ding we must fin
3d90: 64 20 6f 75 74 20 69 66 20 74 68 65 20 70 72 65 d out if the pre
3da0: 76 69 6f 75 73 20 74 65 73 74 20 28 77 68 65 72 vious test (wher
3db0: 65 20 61 6c 6c 20 6b 65 79 73 20 6d 61 74 63 68 e all keys match
3dc0: 65 64 20 65 78 63 65 70 74 20 72 75 6e 6e 61 6d ed except runnam
3dd0: 65 29 0a 09 20 3b 3b 20 77 61 73 20 57 41 49 56 e).. ;; was WAIV
3de0: 45 44 20 69 66 20 74 68 69 73 20 74 65 73 74 20 ED if this test
3df0: 69 73 20 46 41 49 4c 0a 0a 09 20 3b 3b 20 4e 4f is FAIL... ;; NO
3e00: 54 45 53 3a 0a 09 20 3b 3b 20 20 31 2e 20 49 73 TES:.. ;; 1. Is
3e10: 20 74 68 65 20 63 61 6c 6c 20 74 6f 20 74 65 73 the call to tes
3e20: 74 3a 67 65 74 2d 70 72 65 76 69 6f 75 73 2d 72 t:get-previous-r
3e30: 75 6e 2d 72 65 63 6f 72 64 20 72 65 6d 6f 74 69 un-record remoti
3e40: 66 69 65 64 3f 0a 09 20 3b 3b 20 20 32 2e 20 41 fied?.. ;; 2. A
3e50: 64 64 20 74 65 73 74 20 66 6f 72 20 74 65 73 74 dd test for test
3e60: 63 6f 6e 66 69 67 20 77 61 69 76 65 72 20 70 72 config waiver pr
3e70: 6f 70 61 67 61 74 69 6f 6e 20 63 6f 6e 74 72 6f opagation contro
3e80: 6c 20 68 65 72 65 0a 09 20 3b 3b 0a 09 20 28 70 l here.. ;;.. (p
3e90: 72 65 76 2d 74 65 73 74 20 20 20 28 69 66 20 28 rev-test (if (
3ea0: 65 71 75 61 6c 3f 20 73 74 61 74 75 73 20 22 46 equal? status "F
3eb0: 41 49 4c 22 29 0a 09 09 09 20 20 28 72 6d 74 3a AIL").... (rmt:
3ec0: 67 65 74 2d 70 72 65 76 69 6f 75 73 2d 74 65 73 get-previous-tes
3ed0: 74 2d 72 75 6e 2d 72 65 63 6f 72 64 20 72 75 6e t-run-record run
3ee0: 2d 69 64 20 74 65 73 74 2d 6e 61 6d 65 20 69 74 -id test-name it
3ef0: 65 6d 2d 70 61 74 68 29 0a 09 09 09 20 20 23 66 em-path).... #f
3f00: 29 29 0a 09 20 28 77 61 69 76 65 64 20 20 20 28 )).. (waived (
3f10: 69 66 20 70 72 65 76 2d 74 65 73 74 0a 09 09 20 if prev-test...
3f20: 20 20 20 20 20 20 28 69 66 20 70 72 65 76 2d 74 (if prev-t
3f30: 65 73 74 20 3b 3b 20 74 72 75 65 20 69 66 20 77 est ;; true if w
3f40: 65 20 66 6f 75 6e 64 20 61 20 70 72 65 76 69 6f e found a previo
3f50: 75 73 20 74 65 73 74 20 69 6e 20 74 68 69 73 20 us test in this
3f60: 72 75 6e 20 73 65 72 69 65 73 0a 09 09 09 20 20 run series....
3f70: 20 28 6c 65 74 20 28 28 70 72 65 76 2d 73 74 61 (let ((prev-sta
3f80: 74 75 73 20 20 28 64 62 3a 74 65 73 74 2d 67 65 tus (db:test-ge
3f90: 74 2d 73 74 61 74 75 73 20 20 70 72 65 76 2d 74 t-status prev-t
3fa0: 65 73 74 29 29 0a 09 09 09 09 20 28 70 72 65 76 est))..... (prev
3fb0: 2d 73 74 61 74 65 20 20 20 28 64 62 3a 74 65 73 -state (db:tes
3fc0: 74 2d 67 65 74 2d 73 74 61 74 65 20 20 20 70 72 t-get-state pr
3fd0: 65 76 2d 74 65 73 74 29 29 0a 09 09 09 09 20 28 ev-test))..... (
3fe0: 70 72 65 76 2d 63 6f 6d 6d 65 6e 74 20 28 64 62 prev-comment (db
3ff0: 3a 74 65 73 74 2d 67 65 74 2d 63 6f 6d 6d 65 6e :test-get-commen
4000: 74 20 70 72 65 76 2d 74 65 73 74 29 29 29 0a 09 t prev-test)))..
4010: 09 09 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 .. (debug:pr
4020: 69 6e 74 20 34 20 2a 64 65 66 61 75 6c 74 2d 6c int 4 *default-l
4030: 6f 67 2d 70 6f 72 74 2a 20 22 70 72 65 76 2d 73 og-port* "prev-s
4040: 74 61 74 75 73 20 22 20 70 72 65 76 2d 73 74 61 tatus " prev-sta
4050: 74 75 73 20 22 2c 20 70 72 65 76 2d 73 74 61 74 tus ", prev-stat
4060: 65 20 22 20 70 72 65 76 2d 73 74 61 74 65 20 22 e " prev-state "
4070: 2c 20 70 72 65 76 2d 63 6f 6d 6d 65 6e 74 20 22 , prev-comment "
4080: 20 70 72 65 76 2d 63 6f 6d 6d 65 6e 74 29 0a 09 prev-comment)..
4090: 09 09 20 20 20 20 20 28 69 66 20 28 61 6e 64 20 .. (if (and
40a0: 28 65 71 75 61 6c 3f 20 70 72 65 76 2d 73 74 61 (equal? prev-sta
40b0: 74 65 20 20 22 43 4f 4d 50 4c 45 54 45 44 22 29 te "COMPLETED")
40c0: 0a 09 09 09 09 20 20 20 20 20 20 28 65 71 75 61 ..... (equa
40d0: 6c 3f 20 70 72 65 76 2d 73 74 61 74 75 73 20 22 l? prev-status "
40e0: 57 41 49 56 45 44 22 29 29 0a 09 09 09 09 20 28 WAIVED"))..... (
40f0: 69 66 20 63 6f 6d 6d 65 6e 74 0a 09 09 09 09 20 if comment.....
4100: 20 20 20 20 63 6f 6d 6d 65 6e 74 0a 09 09 09 09 comment.....
4110: 20 20 20 20 20 70 72 65 76 2d 63 6f 6d 6d 65 6e prev-commen
4120: 74 29 20 3b 3b 20 77 61 69 76 65 64 20 69 73 20 t) ;; waived is
4130: 65 69 74 68 65 72 20 74 68 65 20 63 6f 6d 6d 65 either the comme
4140: 6e 74 20 6f 72 20 23 66 0a 09 09 09 09 20 23 66 nt or #f..... #f
4150: 29 29 0a 09 09 09 20 20 20 23 66 29 0a 09 09 20 )).... #f)...
4160: 20 20 20 20 20 20 23 66 29 29 29 0a 20 20 20 20 #f))).
4170: 28 69 66 20 28 61 6e 64 20 77 61 69 76 65 64 20 (if (and waived
4180: 0a 09 20 20 20 20 20 28 74 65 73 74 73 3a 63 68 .. (tests:ch
4190: 65 63 6b 2d 77 61 69 76 65 72 2d 65 6c 69 67 69 eck-waiver-eligi
41a0: 62 69 6c 69 74 79 20 74 65 73 74 64 61 74 20 70 bility testdat p
41b0: 72 65 76 2d 74 65 73 74 29 29 0a 09 28 73 65 74 rev-test))..(set
41c0: 21 20 72 65 61 6c 2d 73 74 61 74 75 73 20 22 57 ! real-status "W
41d0: 41 49 56 45 44 22 29 29 0a 0a 20 20 20 20 28 64 AIVED")).. (d
41e0: 65 62 75 67 3a 70 72 69 6e 74 20 34 20 2a 64 65 ebug:print 4 *de
41f0: 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 fault-log-port*
4200: 22 72 65 61 6c 2d 73 74 61 74 75 73 20 22 20 72 "real-status " r
4210: 65 61 6c 2d 73 74 61 74 75 73 20 22 2c 20 77 61 eal-status ", wa
4220: 69 76 65 64 20 22 20 77 61 69 76 65 64 20 22 2c ived " waived ",
4230: 20 73 74 61 74 75 73 20 22 20 73 74 61 74 75 73 status " status
4240: 29 0a 0a 20 20 20 20 3b 3b 20 75 70 64 61 74 65 ).. ;; update
4250: 20 74 68 65 20 70 72 69 6d 61 72 79 20 72 65 63 the primary rec
4260: 6f 72 64 20 49 46 20 73 74 61 74 65 20 41 4e 44 ord IF state AND
4270: 20 73 74 61 74 75 73 20 61 72 65 20 64 65 66 69 status are defi
4280: 6e 65 64 0a 20 20 20 20 28 69 66 20 28 61 6e 64 ned. (if (and
4290: 20 73 74 61 74 65 20 73 74 61 74 75 73 29 0a 09 state status)..
42a0: 28 62 65 67 69 6e 0a 09 20 20 28 72 6d 74 3a 73 (begin.. (rmt:s
42b0: 65 74 2d 73 74 61 74 65 2d 73 74 61 74 75 73 2d et-state-status-
42c0: 61 6e 64 2d 72 6f 6c 6c 2d 75 70 2d 69 74 65 6d and-roll-up-item
42d0: 73 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 69 64 s run-id test-id
42e0: 20 69 74 65 6d 2d 70 61 74 68 20 73 74 61 74 65 item-path state
42f0: 20 72 65 61 6c 2d 73 74 61 74 75 73 20 28 69 66 real-status (if
4300: 20 77 61 69 76 65 64 20 77 61 69 76 65 64 20 63 waived waived c
4310: 6f 6d 6d 65 6e 74 29 29 0a 09 20 20 3b 3b 20 28 omment)).. ;; (
4320: 6d 74 3a 70 72 6f 63 65 73 73 2d 74 72 69 67 67 mt:process-trigg
4330: 65 72 73 20 72 75 6e 2d 69 64 20 74 65 73 74 2d ers run-id test-
4340: 69 64 20 73 74 61 74 65 20 72 65 61 6c 2d 73 74 id state real-st
4350: 61 74 75 73 29 20 3b 3b 20 74 72 69 67 67 65 72 atus) ;; trigger
4360: 73 20 61 72 65 20 63 61 6c 6c 65 64 20 69 6e 20 s are called in
4370: 74 65 73 74 2d 73 65 74 2d 73 74 61 74 65 2d 73 test-set-state-s
4380: 74 61 74 75 73 0a 09 20 20 29 29 0a 20 20 20 20 tatus.. )).
4390: 0a 20 20 20 20 3b 3b 20 69 66 20 73 74 61 74 75 . ;; if statu
43a0: 73 20 69 73 20 22 41 55 54 4f 22 20 74 68 65 6e s is "AUTO" then
43b0: 20 63 61 6c 6c 20 72 6f 6c 6c 75 70 20 28 6e 6f call rollup (no
43c0: 74 65 2c 20 74 68 69 73 20 6f 6e 65 20 6d 6f 64 te, this one mod
43d0: 69 66 69 65 73 20 64 61 74 61 20 69 6e 20 74 65 ifies data in te
43e0: 73 74 0a 20 20 20 20 3b 3b 20 72 75 6e 20 61 72 st. ;; run ar
43f0: 65 61 2c 20 69 74 20 64 6f 65 73 20 72 65 6d 6f ea, it does remo
4400: 74 65 20 63 61 6c 6c 73 20 75 6e 64 65 72 20 74 te calls under t
4410: 68 65 20 68 6f 6f 64 2e 0a 20 20 20 20 3b 3b 20 he hood.. ;;
4420: 28 69 66 20 28 61 6e 64 20 74 65 73 74 2d 69 64 (if (and test-id
4430: 20 73 74 61 74 65 20 73 74 61 74 75 73 20 28 65 state status (e
4440: 71 75 61 6c 3f 20 73 74 61 74 75 73 20 22 41 55 qual? status "AU
4450: 54 4f 22 29 29 20 0a 20 20 20 20 3b 3b 20 09 28 TO")) . ;; .(
4460: 72 6d 74 3a 74 65 73 74 2d 64 61 74 61 2d 72 6f rmt:test-data-ro
4470: 6c 6c 75 70 20 72 75 6e 2d 69 64 20 74 65 73 74 llup run-id test
4480: 2d 69 64 20 73 74 61 74 75 73 29 29 0a 0a 20 20 -id status))..
4490: 20 20 3b 3b 20 61 64 64 20 6d 65 74 61 64 61 74 ;; add metadat
44a0: 61 20 28 6e 65 65 64 20 74 6f 20 64 6f 20 74 68 a (need to do th
44b0: 69 73 20 77 61 79 20 74 6f 20 61 76 6f 69 64 20 is way to avoid
44c0: 53 51 4c 20 69 6e 6a 65 63 74 69 6f 6e 20 69 73 SQL injection is
44d0: 73 75 65 73 29 0a 0a 20 20 20 20 3b 3b 20 3a 66 sues).. ;; :f
44e0: 69 72 73 74 5f 65 72 72 0a 20 20 20 20 3b 3b 20 irst_err. ;;
44f0: 28 6c 65 74 20 28 28 76 61 6c 20 28 68 61 73 68 (let ((val (hash
4500: 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 -table-ref/defau
4510: 6c 74 20 6f 74 68 65 72 64 61 74 20 22 3a 66 69 lt otherdat ":fi
4520: 72 73 74 5f 65 72 72 22 20 23 66 29 29 29 0a 20 rst_err" #f))).
4530: 20 20 20 3b 3b 20 20 20 28 69 66 20 76 61 6c 0a ;; (if val.
4540: 20 20 20 20 3b 3b 20 20 20 20 20 20 20 28 73 71 ;; (sq
4550: 6c 69 74 65 33 3a 65 78 65 63 75 74 65 20 64 62 lite3:execute db
4560: 20 22 55 50 44 41 54 45 20 74 65 73 74 73 20 53 "UPDATE tests S
4570: 45 54 20 66 69 72 73 74 5f 65 72 72 3d 3f 20 57 ET first_err=? W
4580: 48 45 52 45 20 72 75 6e 5f 69 64 3d 3f 20 41 4e HERE run_id=? AN
4590: 44 20 74 65 73 74 6e 61 6d 65 3d 3f 20 41 4e 44 D testname=? AND
45a0: 20 69 74 65 6d 5f 70 61 74 68 3d 3f 3b 22 20 76 item_path=?;" v
45b0: 61 6c 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 6e al run-id test-n
45c0: 61 6d 65 20 69 74 65 6d 2d 70 61 74 68 29 29 29 ame item-path)))
45d0: 0a 20 20 20 20 3b 3b 20 0a 20 20 20 20 3b 3b 20 . ;; . ;;
45e0: 3b 3b 20 3a 66 69 72 73 74 5f 77 61 72 6e 0a 20 ;; :first_warn.
45f0: 20 20 20 3b 3b 20 28 6c 65 74 20 28 28 76 61 6c ;; (let ((val
4600: 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 (hash-table-ref
4610: 2f 64 65 66 61 75 6c 74 20 6f 74 68 65 72 64 61 /default otherda
4620: 74 20 22 3a 66 69 72 73 74 5f 77 61 72 6e 22 20 t ":first_warn"
4630: 23 66 29 29 29 0a 20 20 20 20 3b 3b 20 20 20 28 #f))). ;; (
4640: 69 66 20 76 61 6c 0a 20 20 20 20 3b 3b 20 20 20 if val. ;;
4650: 20 20 20 20 28 73 71 6c 69 74 65 33 3a 65 78 65 (sqlite3:exe
4660: 63 75 74 65 20 64 62 20 22 55 50 44 41 54 45 20 cute db "UPDATE
4670: 74 65 73 74 73 20 53 45 54 20 66 69 72 73 74 5f tests SET first_
4680: 77 61 72 6e 3d 3f 20 57 48 45 52 45 20 72 75 6e warn=? WHERE run
4690: 5f 69 64 3d 3f 20 41 4e 44 20 74 65 73 74 6e 61 _id=? AND testna
46a0: 6d 65 3d 3f 20 41 4e 44 20 69 74 65 6d 5f 70 61 me=? AND item_pa
46b0: 74 68 3d 3f 3b 22 20 76 61 6c 20 72 75 6e 2d 69 th=?;" val run-i
46c0: 64 20 74 65 73 74 2d 6e 61 6d 65 20 69 74 65 6d d test-name item
46d0: 2d 70 61 74 68 29 29 29 0a 0a 20 20 20 20 28 6c -path))).. (l
46e0: 65 74 20 28 28 63 61 74 65 67 6f 72 79 20 28 68 et ((category (h
46f0: 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 ash-table-ref/de
4700: 66 61 75 6c 74 20 6f 74 68 65 72 64 61 74 20 22 fault otherdat "
4710: 3a 63 61 74 65 67 6f 72 79 22 20 22 22 29 29 0a :category" "")).
4720: 09 20 20 28 76 61 72 69 61 62 6c 65 20 28 68 61 . (variable (ha
4730: 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 sh-table-ref/def
4740: 61 75 6c 74 20 6f 74 68 65 72 64 61 74 20 22 3a ault otherdat ":
4750: 76 61 72 69 61 62 6c 65 22 20 22 22 29 29 0a 09 variable" ""))..
4760: 20 20 28 76 61 6c 75 65 20 20 20 20 28 68 61 73 (value (has
4770: 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 h-table-ref/defa
4780: 75 6c 74 20 6f 74 68 65 72 64 61 74 20 22 3a 76 ult otherdat ":v
4790: 61 6c 75 65 22 20 20 20 20 23 66 29 29 0a 09 20 alue" #f))..
47a0: 20 28 65 78 70 65 63 74 65 64 20 28 68 61 73 68 (expected (hash
47b0: 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 -table-ref/defau
47c0: 6c 74 20 6f 74 68 65 72 64 61 74 20 22 3a 65 78 lt otherdat ":ex
47d0: 70 65 63 74 65 64 22 20 22 6e 2f 61 22 29 29 0a pected" "n/a")).
47e0: 09 20 20 28 74 6f 6c 20 20 20 20 20 20 28 68 61 . (tol (ha
47f0: 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 sh-table-ref/def
4800: 61 75 6c 74 20 6f 74 68 65 72 64 61 74 20 22 3a ault otherdat ":
4810: 74 6f 6c 22 20 20 20 20 20 20 22 6e 2f 61 22 29 tol" "n/a")
4820: 29 0a 09 20 20 28 75 6e 69 74 73 20 20 20 20 28 ).. (units (
4830: 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 hash-table-ref/d
4840: 65 66 61 75 6c 74 20 6f 74 68 65 72 64 61 74 20 efault otherdat
4850: 22 3a 75 6e 69 74 73 22 20 20 20 20 22 22 29 29 ":units" ""))
4860: 0a 09 20 20 28 74 79 70 65 20 20 20 20 20 28 68 .. (type (h
4870: 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 ash-table-ref/de
4880: 66 61 75 6c 74 20 6f 74 68 65 72 64 61 74 20 22 fault otherdat "
4890: 3a 74 79 70 65 22 20 20 20 20 20 22 22 29 29 0a :type" "")).
48a0: 09 20 20 28 64 63 6f 6d 6d 65 6e 74 20 28 68 61 . (dcomment (ha
48b0: 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 sh-table-ref/def
48c0: 61 75 6c 74 20 6f 74 68 65 72 64 61 74 20 22 3a ault otherdat ":
48d0: 63 6f 6d 6d 65 6e 74 22 20 20 22 22 29 29 29 0a comment" ""))).
48e0: 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 (debug:pri
48f0: 6e 74 20 34 20 2a 64 65 66 61 75 6c 74 2d 6c 6f nt 4 *default-lo
4900: 67 2d 70 6f 72 74 2a 20 0a 09 09 20 20 20 22 63 g-port* ... "c
4910: 61 74 65 67 6f 72 79 3a 20 22 20 63 61 74 65 67 ategory: " categ
4920: 6f 72 79 20 22 2c 20 76 61 72 69 61 62 6c 65 3a ory ", variable:
4930: 20 22 20 76 61 72 69 61 62 6c 65 20 22 2c 20 76 " variable ", v
4940: 61 6c 75 65 3a 20 22 20 76 61 6c 75 65 0a 09 09 alue: " value...
4950: 20 20 20 22 2c 20 65 78 70 65 63 74 65 64 3a 20 ", expected:
4960: 22 20 65 78 70 65 63 74 65 64 20 22 2c 20 74 6f " expected ", to
4970: 6c 3a 20 22 20 74 6f 6c 20 22 2c 20 75 6e 69 74 l: " tol ", unit
4980: 73 3a 20 22 20 75 6e 69 74 73 29 0a 20 20 20 20 s: " units).
4990: 20 20 28 69 66 20 28 61 6e 64 20 76 61 6c 75 65 (if (and value
49a0: 29 20 3b 3b 20 72 65 71 75 69 72 65 20 6f 6e 6c ) ;; require onl
49b0: 79 20 76 61 6c 75 65 3b 20 42 42 20 77 61 73 2d y value; BB was-
49c0: 20 61 6c 6c 20 74 68 72 65 65 20 72 65 71 75 69 all three requi
49d0: 72 65 64 0a 09 20 20 28 6c 65 74 20 28 28 64 61 red.. (let ((da
49e0: 74 20 28 63 6f 6e 63 20 63 61 74 65 67 6f 72 79 t (conc category
49f0: 20 22 2c 22 0a 09 09 09 20 20 20 76 61 72 69 61 ",".... varia
4a00: 62 6c 65 20 22 2c 22 0a 09 09 09 20 20 20 76 61 ble ",".... va
4a10: 6c 75 65 20 20 20 20 22 2c 22 0a 09 09 09 20 20 lue ","....
4a20: 20 65 78 70 65 63 74 65 64 20 22 2c 22 0a 09 09 expected ","...
4a30: 09 20 20 20 74 6f 6c 20 20 20 20 20 20 22 2c 22 . tol ","
4a40: 0a 09 09 09 20 20 20 75 6e 69 74 73 20 20 20 20 .... units
4a50: 22 2c 22 0a 09 09 09 20 20 20 64 63 6f 6d 6d 65 ",".... dcomme
4a60: 6e 74 20 22 2c 2c 22 20 3b 3b 20 65 78 74 72 61 nt ",," ;; extra
4a70: 20 63 6f 6d 6d 61 20 66 6f 72 20 73 74 61 74 75 comma for statu
4a80: 73 0a 09 09 09 20 20 20 74 79 70 65 20 20 20 20 s.... type
4a90: 20 29 29 29 0a 09 20 20 20 20 3b 3b 20 54 68 69 ))).. ;; Thi
4aa0: 73 20 77 61 73 20 72 75 6e 20 72 65 6d 6f 74 65 s was run remote
4ab0: 2c 20 64 6f 6e 27 74 20 74 68 69 6e 6b 20 74 68 , don't think th
4ac0: 61 74 20 6d 61 6b 65 73 20 73 65 6e 73 65 2e 20 at makes sense.
4ad0: 50 65 72 68 61 70 73 20 6e 6f 74 2c 20 62 75 74 Perhaps not, but
4ae0: 20 74 68 61 74 20 69 73 20 74 68 65 20 65 61 73 that is the eas
4af0: 69 65 73 74 20 70 61 74 68 20 66 6f 72 20 74 68 iest path for th
4b00: 65 20 6d 6f 6d 65 6e 74 2e 0a 09 20 20 20 20 28 e moment... (
4b10: 72 6d 74 3a 63 73 76 2d 3e 74 65 73 74 2d 64 61 rmt:csv->test-da
4b20: 74 61 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 69 ta run-id test-i
4b30: 64 0a 09 09 09 09 64 61 74 29 0a 20 20 20 20 20 d.....dat).
4b40: 20 20 20 20 20 20 20 28 74 68 72 65 61 64 2d 73 (thread-s
4b50: 6c 65 65 70 21 20 31 30 29 20 3b 3b 20 61 64 64 leep! 10) ;; add
4b60: 20 31 30 20 73 65 63 6f 6e 64 20 64 65 6c 61 79 10 second delay
4b70: 20 62 65 66 6f 72 65 20 71 75 69 74 20 69 6e 63 before quit inc
4b80: 61 73 65 20 72 6d 74 20 6e 65 65 64 73 20 74 69 ase rmt needs ti
4b90: 6d 65 20 74 6f 20 73 74 61 72 74 20 61 20 73 65 me to start a se
4ba0: 72 76 65 72 2e 0a 20 20 20 20 20 20 20 20 20 20 rver..
4bb0: 20 20 29 29 29 0a 20 20 20 20 20 20 0a 20 20 20 ))). .
4bc0: 20 3b 3b 20 6e 65 65 64 20 74 6f 20 75 70 64 61 ;; need to upda
4bd0: 74 65 20 74 68 65 20 74 6f 70 20 74 65 73 74 20 te the top test
4be0: 72 65 63 6f 72 64 20 69 66 20 50 41 53 53 20 6f record if PASS o
4bf0: 72 20 46 41 49 4c 20 61 6e 64 20 74 68 69 73 20 r FAIL and this
4c00: 69 73 20 61 20 73 75 62 74 65 73 74 0a 20 20 20 is a subtest.
4c10: 20 3b 3b 3b 3b 3b 3b 20 28 69 66 20 28 6e 6f 74 ;;;;;; (if (not
4c20: 20 28 65 71 75 61 6c 3f 20 69 74 65 6d 2d 70 61 (equal? item-pa
4c30: 74 68 20 22 22 29 29 0a 20 20 20 20 3b 3b 3b 3b th "")). ;;;;
4c40: 3b 3b 20 20 20 20 20 28 72 6d 74 3a 73 65 74 2d ;; (rmt:set-
4c50: 73 74 61 74 65 2d 73 74 61 74 75 73 2d 61 6e 64 state-status-and
4c60: 2d 72 6f 6c 6c 2d 75 70 2d 69 74 65 6d 73 20 72 -roll-up-items r
4c70: 75 6e 2d 69 64 20 74 65 73 74 2d 6e 61 6d 65 20 un-id test-name
4c80: 69 74 65 6d 2d 70 61 74 68 20 73 74 61 74 65 20 item-path state
4c90: 73 74 61 74 75 73 20 23 66 29 20 3b 3b 3b 3b 3b status #f) ;;;;;
4ca0: 29 0a 0a 20 20 20 20 28 69 66 20 28 6f 72 20 28 ).. (if (or (
4cb0: 61 6e 64 20 28 73 74 72 69 6e 67 3f 20 63 6f 6d and (string? com
4cc0: 6d 65 6e 74 29 0a 09 09 20 28 73 74 72 69 6e 67 ment)... (string
4cd0: 2d 6d 61 74 63 68 20 28 72 65 67 65 78 70 20 22 -match (regexp "
4ce0: 5c 5c 53 2b 22 29 20 63 6f 6d 6d 65 6e 74 29 29 \\S+") comment))
4cf0: 0a 09 20 20 20 20 77 61 69 76 65 64 29 0a 09 28 .. waived)..(
4d00: 6c 65 74 20 28 28 63 6d 74 20 20 28 69 66 20 77 let ((cmt (if w
4d10: 61 69 76 65 64 20 77 61 69 76 65 64 20 63 6f 6d aived waived com
4d20: 6d 65 6e 74 29 29 29 0a 09 20 20 28 72 6d 74 3a ment))).. (rmt:
4d30: 67 65 6e 65 72 61 6c 2d 63 61 6c 6c 20 27 73 65 general-call 'se
4d40: 74 2d 74 65 73 74 2d 63 6f 6d 6d 65 6e 74 20 72 t-test-comment r
4d50: 75 6e 2d 69 64 20 63 6d 74 20 74 65 73 74 2d 69 un-id cmt test-i
4d60: 64 29 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 d)))))..(define
4d70: 28 74 65 73 74 73 3a 74 65 73 74 2d 73 65 74 2d (tests:test-set-
4d80: 74 6f 70 6c 6f 67 21 20 72 75 6e 2d 69 64 20 74 toplog! run-id t
4d90: 65 73 74 2d 6e 61 6d 65 20 6c 6f 67 66 29 20 0a est-name logf) .
4da0: 20 20 28 72 6d 74 3a 67 65 6e 65 72 61 6c 2d 63 (rmt:general-c
4db0: 61 6c 6c 20 27 74 65 73 74 73 3a 74 65 73 74 2d all 'tests:test-
4dc0: 73 65 74 2d 74 6f 70 6c 6f 67 20 72 75 6e 2d 69 set-toplog run-i
4dd0: 64 20 6c 6f 67 66 20 72 75 6e 2d 69 64 20 74 65 d logf run-id te
4de0: 73 74 2d 6e 61 6d 65 29 29 0a 0a 28 64 65 66 69 st-name))..(defi
4df0: 6e 65 20 28 74 65 73 74 73 3a 73 75 6d 6d 61 72 ne (tests:summar
4e00: 69 7a 65 2d 69 74 65 6d 73 20 72 75 6e 2d 69 64 ize-items run-id
4e10: 20 74 65 73 74 2d 69 64 20 74 65 73 74 2d 6e 61 test-id test-na
4e20: 6d 65 20 66 6f 72 63 65 29 0a 20 20 3b 3b 20 69 me force). ;; i
4e30: 66 20 6e 6f 74 20 66 6f 72 63 65 20 74 68 65 6e f not force then
4e40: 20 6f 6e 6c 79 20 75 70 64 61 74 65 20 74 68 65 only update the
4e50: 20 72 65 63 6f 72 64 20 69 66 20 6f 6e 65 20 6f record if one o
4e60: 66 20 74 68 65 73 65 20 69 73 20 74 72 75 65 3a f these is true:
4e70: 0a 20 20 3b 3b 20 20 20 31 2e 20 6c 6f 67 66 20 . ;; 1. logf
4e80: 69 73 20 22 6c 6f 67 2f 66 69 6e 61 6c 2e 6c 6f is "log/final.lo
4e90: 67 0a 20 20 3b 3b 20 20 20 32 2e 20 6c 6f 67 66 g. ;; 2. logf
4ea0: 20 69 73 20 73 61 6d 65 20 61 73 20 6f 75 74 70 is same as outp
4eb0: 75 74 66 69 6c 65 6e 61 6d 65 0a 20 20 28 6c 65 utfilename. (le
4ec0: 74 2a 20 28 28 6f 75 74 70 75 74 66 69 6c 65 6e t* ((outputfilen
4ed0: 61 6d 65 20 28 63 6f 6e 63 20 22 6d 65 67 61 74 ame (conc "megat
4ee0: 65 73 74 2d 72 6f 6c 6c 75 70 2d 22 20 74 65 73 est-rollup-" tes
4ef0: 74 2d 6e 61 6d 65 20 22 2e 68 74 6d 6c 22 29 29 t-name ".html"))
4f00: 0a 09 20 28 6f 72 69 67 2d 64 69 72 20 20 20 20 .. (orig-dir
4f10: 20 20 20 28 63 75 72 72 65 6e 74 2d 64 69 72 65 (current-dire
4f20: 63 74 6f 72 79 29 29 0a 09 20 28 6c 6f 67 66 2d ctory)).. (logf-
4f30: 69 6e 66 6f 20 20 20 20 20 20 28 72 6d 74 3a 74 info (rmt:t
4f40: 65 73 74 2d 67 65 74 2d 6c 6f 67 66 69 6c 65 2d est-get-logfile-
4f50: 69 6e 66 6f 20 72 75 6e 2d 69 64 20 74 65 73 74 info run-id test
4f60: 2d 6e 61 6d 65 29 29 0a 09 20 28 6c 6f 67 66 20 -name)).. (logf
4f70: 20 20 20 20 20 20 20 20 20 20 28 69 66 20 6c 6f (if lo
4f80: 67 66 2d 69 6e 66 6f 20 28 63 61 64 72 20 6c 6f gf-info (cadr lo
4f90: 67 66 2d 69 6e 66 6f 29 20 23 66 29 29 0a 09 20 gf-info) #f))..
4fa0: 28 70 61 74 68 20 20 20 20 20 20 20 20 20 20 20 (path
4fb0: 28 69 66 20 6c 6f 67 66 2d 69 6e 66 6f 20 28 63 (if logf-info (c
4fc0: 61 72 20 20 6c 6f 67 66 2d 69 6e 66 6f 29 20 23 ar logf-info) #
4fd0: 66 29 29 29 0a 20 20 20 20 3b 3b 20 54 68 69 73 f))). ;; This
4fe0: 20 71 75 65 72 79 20 66 69 6e 64 73 20 74 68 65 query finds the
4ff0: 20 70 61 74 68 20 61 6e 64 20 63 68 61 6e 67 65 path and change
5000: 73 20 74 68 65 20 64 69 72 65 63 74 6f 72 79 20 s the directory
5010: 74 6f 20 69 74 20 66 6f 72 20 74 68 65 20 74 65 to it for the te
5020: 73 74 0a 20 20 20 20 28 69 66 20 28 61 6e 64 20 st. (if (and
5030: 28 73 74 72 69 6e 67 3f 20 70 61 74 68 29 0a 09 (string? path)..
5040: 20 20 20 20 20 28 64 69 72 65 63 74 6f 72 79 3f (directory?
5050: 20 70 61 74 68 29 29 20 3b 3b 20 63 61 6e 20 67 path)) ;; can g
5060: 65 74 20 23 66 20 68 65 72 65 20 75 6e 64 65 72 et #f here under
5070: 20 73 6f 6d 65 20 77 69 65 72 64 20 63 6f 6e 64 some wierd cond
5080: 69 74 69 6f 6e 73 2e 20 77 68 79 2c 20 75 6e 6b itions. why, unk
5090: 6e 6f 77 6e 20 2e 2e 2e 0a 09 28 62 65 67 69 6e nown .....(begin
50a0: 0a 09 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 .. (debug:print
50b0: 20 34 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 4 *default-log-
50c0: 70 6f 72 74 2a 20 22 46 6f 75 6e 64 20 70 61 74 port* "Found pat
50d0: 68 3a 20 22 20 70 61 74 68 29 0a 09 20 20 28 63 h: " path).. (c
50e0: 68 61 6e 67 65 2d 64 69 72 65 63 74 6f 72 79 20 hange-directory
50f0: 70 61 74 68 29 29 0a 09 3b 3b 20 28 73 65 74 21 path))..;; (set!
5100: 20 6f 75 74 70 75 74 66 69 6c 65 6e 61 6d 65 20 outputfilename
5110: 28 63 6f 6e 63 20 70 61 74 68 20 22 2f 22 20 6f (conc path "/" o
5120: 75 74 70 75 74 66 69 6c 65 6e 61 6d 65 29 29 29 utputfilename)))
5130: 0a 09 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 65 ..(debug:print-e
5140: 72 72 6f 72 20 30 20 2a 64 65 66 61 75 6c 74 2d rror 0 *default-
5150: 6c 6f 67 2d 70 6f 72 74 2a 20 22 73 75 6d 6d 61 log-port* "summa
5160: 72 69 7a 65 2d 69 74 65 6d 73 20 66 6f 72 20 72 rize-items for r
5170: 75 6e 2d 69 64 3d 22 20 72 75 6e 2d 69 64 20 22 un-id=" run-id "
5180: 2c 20 74 65 73 74 2d 6e 61 6d 65 3d 22 20 74 65 , test-name=" te
5190: 73 74 2d 6e 61 6d 65 20 22 2c 20 6e 6f 20 73 75 st-name ", no su
51a0: 63 68 20 70 61 74 68 3a 20 22 20 70 61 74 68 29 ch path: " path)
51b0: 29 0a 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 ). (debug:pri
51c0: 6e 74 20 34 20 2a 64 65 66 61 75 6c 74 2d 6c 6f nt 4 *default-lo
51d0: 67 2d 70 6f 72 74 2a 20 22 73 75 6d 6d 61 72 69 g-port* "summari
51e0: 7a 65 2d 69 74 65 6d 73 20 77 69 74 68 20 6c 6f ze-items with lo
51f0: 67 66 20 22 20 6c 6f 67 66 20 22 2c 20 6f 75 74 gf " logf ", out
5200: 70 75 74 66 69 6c 65 6e 61 6d 65 20 22 20 6f 75 putfilename " ou
5210: 74 70 75 74 66 69 6c 65 6e 61 6d 65 20 22 20 61 tputfilename " a
5220: 6e 64 20 66 6f 72 63 65 20 22 20 66 6f 72 63 65 nd force " force
5230: 29 0a 20 20 20 20 28 69 66 20 28 6f 72 20 28 65 ). (if (or (e
5240: 71 75 61 6c 3f 20 6c 6f 67 66 20 22 6c 6f 67 73 qual? logf "logs
5250: 2f 66 69 6e 61 6c 2e 6c 6f 67 22 29 0a 09 20 20 /final.log")..
5260: 20 20 28 65 71 75 61 6c 3f 20 6c 6f 67 66 20 6f (equal? logf o
5270: 75 74 70 75 74 66 69 6c 65 6e 61 6d 65 29 0a 09 utputfilename)..
5280: 20 20 20 20 66 6f 72 63 65 29 0a 09 28 6c 65 74 force)..(let
5290: 20 28 28 6d 79 2d 73 74 61 72 74 2d 74 69 6d 65 ((my-start-time
52a0: 20 28 63 75 72 72 65 6e 74 2d 73 65 63 6f 6e 64 (current-second
52b0: 73 29 29 0a 09 20 20 20 20 20 20 28 6c 6f 63 6b s)).. (lock
52c0: 66 20 20 20 20 20 20 20 20 20 28 63 6f 6e 63 20 f (conc
52d0: 6f 75 74 70 75 74 66 69 6c 65 6e 61 6d 65 20 22 outputfilename "
52e0: 2e 6c 6f 63 6b 22 29 29 29 0a 09 20 20 28 6c 65 .lock"))).. (le
52f0: 74 20 6c 6f 6f 70 20 28 28 68 61 76 65 2d 6c 6f t loop ((have-lo
5300: 63 6b 20 20 28 63 6f 6d 6d 6f 6e 3a 73 69 6d 70 ck (common:simp
5310: 6c 65 2d 66 69 6c 65 2d 6c 6f 63 6b 20 6c 6f 63 le-file-lock loc
5320: 6b 66 29 29 29 0a 09 20 20 20 20 28 69 66 20 68 kf))).. (if h
5330: 61 76 65 2d 6c 6f 63 6b 0a 09 09 28 6c 65 74 20 ave-lock...(let
5340: 28 28 73 63 72 69 70 74 20 28 63 6f 6e 66 69 67 ((script (config
5350: 66 3a 6c 6f 6f 6b 75 70 20 2a 63 6f 6e 66 69 67 f:lookup *config
5360: 64 61 74 2a 20 22 74 65 73 74 72 6f 6c 6c 75 70 dat* "testrollup
5370: 22 20 74 65 73 74 2d 6e 61 6d 65 29 29 29 0a 09 " test-name)))..
5380: 09 20 20 28 70 72 69 6e 74 20 22 4f 62 74 61 69 . (print "Obtai
5390: 6e 65 64 20 6c 6f 63 6b 20 66 6f 72 20 22 20 6f ned lock for " o
53a0: 75 74 70 75 74 66 69 6c 65 6e 61 6d 65 29 0a 09 utputfilename)..
53b0: 09 20 20 28 72 6d 74 3a 73 65 74 2d 73 74 61 74 . (rmt:set-stat
53c0: 65 2d 73 74 61 74 75 73 2d 61 6e 64 2d 72 6f 6c e-status-and-rol
53d0: 6c 2d 75 70 2d 69 74 65 6d 73 20 72 75 6e 2d 69 l-up-items run-i
53e0: 64 20 74 65 73 74 2d 6e 61 6d 65 20 22 22 20 23 d test-name "" #
53f0: 66 20 23 66 20 23 66 29 0a 09 09 20 20 28 69 66 f #f #f)... (if
5400: 20 73 63 72 69 70 74 0a 09 09 20 20 20 20 20 20 script...
5410: 28 73 79 73 74 65 6d 20 28 63 6f 6e 63 20 73 63 (system (conc sc
5420: 72 69 70 74 20 22 20 3e 20 22 20 6f 75 74 70 75 ript " > " outpu
5430: 74 66 69 6c 65 6e 61 6d 65 20 22 20 26 20 22 29 tfilename " & ")
5440: 29 0a 09 09 20 20 20 20 20 20 28 74 65 73 74 73 )... (tests
5450: 3a 67 65 6e 65 72 61 74 65 2d 68 74 6d 6c 2d 73 :generate-html-s
5460: 75 6d 6d 61 72 79 2d 66 6f 72 2d 69 74 65 72 61 ummary-for-itera
5470: 74 65 64 2d 74 65 73 74 20 72 75 6e 2d 69 64 20 ted-test run-id
5480: 74 65 73 74 2d 69 64 20 74 65 73 74 2d 6e 61 6d test-id test-nam
5490: 65 20 6f 75 74 70 75 74 66 69 6c 65 6e 61 6d 65 e outputfilename
54a0: 29 29 0a 09 09 20 20 28 63 6f 6d 6d 6f 6e 3a 73 ))... (common:s
54b0: 69 6d 70 6c 65 2d 66 69 6c 65 2d 72 65 6c 65 61 imple-file-relea
54c0: 73 65 2d 6c 6f 63 6b 20 6c 6f 63 6b 66 29 0a 09 se-lock lockf)..
54d0: 09 20 20 28 63 68 61 6e 67 65 2d 64 69 72 65 63 . (change-direc
54e0: 74 6f 72 79 20 6f 72 69 67 2d 64 69 72 29 0a 09 tory orig-dir)..
54f0: 09 20 20 3b 3b 20 4e 42 2f 2f 20 74 65 73 74 73 . ;; NB// tests
5500: 3a 74 65 73 74 2d 73 65 74 2d 74 6f 70 6c 6f 67 :test-set-toplog
5510: 21 20 69 73 20 72 65 6d 6f 74 65 20 69 6e 74 65 ! is remote inte
5520: 72 6e 61 6c 2e 2e 2e 0a 09 09 20 20 28 74 65 73 rnal...... (tes
5530: 74 73 3a 74 65 73 74 2d 73 65 74 2d 74 6f 70 6c ts:test-set-topl
5540: 6f 67 21 20 72 75 6e 2d 69 64 20 74 65 73 74 2d og! run-id test-
5550: 6e 61 6d 65 20 6f 75 74 70 75 74 66 69 6c 65 6e name outputfilen
5560: 61 6d 65 29 29 0a 09 09 3b 3b 20 64 69 64 6e 27 ame))...;; didn'
5570: 74 20 67 65 74 20 74 68 65 20 6c 6f 63 6b 2c 20 t get the lock,
5580: 63 68 65 63 6b 20 74 6f 20 73 65 65 20 69 66 20 check to see if
5590: 63 75 72 72 65 6e 74 20 75 70 64 61 74 65 20 73 current update s
55a0: 74 61 72 74 65 64 20 6c 61 74 65 72 20 74 68 61 tarted later tha
55b0: 6e 20 74 68 69 73 20 0a 09 09 3b 3b 20 75 70 64 n this ...;; upd
55c0: 61 74 65 2c 20 69 66 20 73 6f 20 77 65 20 63 61 ate, if so we ca
55d0: 6e 20 65 78 69 74 20 77 69 74 68 6f 75 74 20 64 n exit without d
55e0: 6f 69 6e 67 20 61 6e 79 20 77 6f 72 6b 0a 09 09 oing any work...
55f0: 28 69 66 20 28 3e 20 6d 79 2d 73 74 61 72 74 2d (if (> my-start-
5600: 74 69 6d 65 20 28 68 61 6e 64 6c 65 2d 65 78 63 time (handle-exc
5610: 65 70 74 69 6f 6e 73 0a 09 09 09 09 09 20 65 78 eptions...... ex
5620: 6e 0a 09 09 09 09 09 20 30 0a 09 09 09 09 20 20 n...... 0.....
5630: 20 20 20 20 20 28 66 69 6c 65 2d 6d 6f 64 69 66 (file-modif
5640: 69 63 61 74 69 6f 6e 2d 74 69 6d 65 20 6c 6f 63 ication-time loc
5650: 6b 66 29 29 29 0a 09 09 20 20 20 20 3b 3b 20 77 kf)))... ;; w
5660: 65 20 73 74 61 72 74 65 64 20 73 69 6e 63 65 20 e started since
5670: 63 75 72 72 65 6e 74 20 72 65 2d 67 65 6e 20 69 current re-gen i
5680: 6e 20 66 6c 69 67 68 74 2c 20 64 65 6c 61 79 20 n flight, delay
5690: 61 20 6c 69 74 74 6c 65 20 61 6e 64 20 74 72 79 a little and try
56a0: 20 61 67 61 69 6e 0a 09 09 20 20 20 20 28 62 65 again... (be
56b0: 67 69 6e 0a 09 09 20 20 20 20 20 20 28 64 65 62 gin... (deb
56c0: 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 31 20 ug:print-info 1
56d0: 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 *default-log-por
56e0: 74 2a 20 22 57 61 69 74 69 6e 67 20 74 6f 20 75 t* "Waiting to u
56f0: 70 64 61 74 65 20 22 20 6f 75 74 70 75 74 66 69 pdate " outputfi
5700: 6c 65 6e 61 6d 65 20 22 2c 20 61 6e 6f 74 68 65 lename ", anothe
5710: 72 20 74 65 73 74 20 63 75 72 72 65 6e 74 6c 79 r test currently
5720: 20 75 70 64 61 74 69 6e 67 20 69 74 22 29 0a 09 updating it")..
5730: 09 20 20 20 20 20 20 28 74 68 72 65 61 64 2d 73 . (thread-s
5740: 6c 65 65 70 21 20 28 2b 20 35 20 28 72 61 6e 64 leep! (+ 5 (rand
5750: 6f 6d 20 35 29 29 29 20 3b 3b 20 64 65 6c 61 79 om 5))) ;; delay
5760: 20 62 65 74 77 65 65 6e 20 35 20 61 6e 64 20 31 between 5 and 1
5770: 30 20 73 65 63 6f 6e 64 73 0a 09 09 20 20 20 20 0 seconds...
5780: 20 20 28 6c 6f 6f 70 20 28 63 6f 6d 6d 6f 6e 3a (loop (common:
5790: 73 69 6d 70 6c 65 2d 66 69 6c 65 2d 6c 6f 63 6b simple-file-lock
57a0: 20 6c 6f 63 6b 66 29 29 29 29 29 29 29 29 29 29 lockf))))))))))
57b0: 0a 0a 28 64 65 66 69 6e 65 20 28 74 65 73 74 73 ..(define (tests
57c0: 3a 67 65 6e 65 72 61 74 65 2d 68 74 6d 6c 2d 73 :generate-html-s
57d0: 75 6d 6d 61 72 79 2d 66 6f 72 2d 69 74 65 72 61 ummary-for-itera
57e0: 74 65 64 2d 74 65 73 74 20 72 75 6e 2d 69 64 20 ted-test run-id
57f0: 74 65 73 74 2d 69 64 20 74 65 73 74 2d 6e 61 6d test-id test-nam
5800: 65 20 6f 75 74 70 75 74 66 69 6c 65 6e 61 6d 65 e outputfilename
5810: 29 0a 20 20 28 6c 65 74 20 28 28 63 6f 75 6e 74 ). (let ((count
5820: 73 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 s (
5830: 6d 61 6b 65 2d 68 61 73 68 2d 74 61 62 6c 65 29 make-hash-table)
5840: 29 0a 09 28 73 74 61 74 65 63 6f 75 6e 74 73 20 )..(statecounts
5850: 20 20 20 20 20 20 20 20 28 6d 61 6b 65 2d 68 61 (make-ha
5860: 73 68 2d 74 61 62 6c 65 29 29 0a 09 28 6f 75 74 sh-table))..(out
5870: 74 78 74 20 20 20 20 20 20 20 20 20 20 20 20 20 txt
5880: 20 22 22 29 0a 09 28 74 6f 74 20 20 20 20 20 20 "")..(tot
5890: 20 20 20 20 20 20 20 20 20 20 20 30 29 0a 09 28 0)..(
58a0: 74 65 73 74 64 61 74 20 20 20 20 20 20 20 20 20 testdat
58b0: 20 20 20 20 28 72 6d 74 3a 74 65 73 74 2d 67 65 (rmt:test-ge
58c0: 74 2d 72 65 63 6f 72 64 73 2d 66 6f 72 2d 69 6e t-records-for-in
58d0: 64 65 78 2d 66 69 6c 65 20 72 75 6e 2d 69 64 20 dex-file run-id
58e0: 74 65 73 74 2d 6e 61 6d 65 29 29 29 0a 20 20 20 test-name))).
58f0: 20 28 77 69 74 68 2d 6f 75 74 70 75 74 2d 74 6f (with-output-to
5900: 2d 66 69 6c 65 20 6f 75 74 70 75 74 66 69 6c 65 -file outputfile
5910: 6e 61 6d 65 0a 20 20 20 20 20 20 28 6c 61 6d 62 name. (lamb
5920: 64 61 20 28 29 0a 09 28 73 65 74 21 20 6f 75 74 da ()..(set! out
5930: 74 78 74 20 28 63 6f 6e 63 20 6f 75 74 74 78 74 txt (conc outtxt
5940: 20 22 3c 68 74 6d 6c 3e 3c 74 69 74 6c 65 3e 53 "<html><title>S
5950: 75 6d 6d 61 72 79 3a 20 22 20 74 65 73 74 2d 6e ummary: " test-n
5960: 61 6d 65 20 0a 09 09 09 20 20 20 22 3c 2f 74 69 ame .... "</ti
5970: 74 6c 65 3e 3c 62 6f 64 79 3e 3c 68 32 3e 53 75 tle><body><h2>Su
5980: 6d 6d 61 72 79 20 66 6f 72 20 22 20 74 65 73 74 mmary for " test
5990: 2d 6e 61 6d 65 20 22 3c 2f 68 32 3e 22 29 29 0a -name "</h2>")).
59a0: 09 28 66 6f 72 2d 65 61 63 68 0a 09 20 28 6c 61 .(for-each.. (la
59b0: 6d 62 64 61 20 28 74 65 73 74 72 65 63 6f 72 64 mbda (testrecord
59c0: 29 0a 09 20 20 20 28 6c 65 74 20 28 28 69 64 20 ).. (let ((id
59d0: 20 20 20 20 20 20 20 20 20 20 20 20 28 76 65 63 (vec
59e0: 74 6f 72 2d 72 65 66 20 74 65 73 74 72 65 63 6f tor-ref testreco
59f0: 72 64 20 30 29 29 0a 09 09 20 28 69 74 65 6d 70 rd 0))... (itemp
5a00: 61 74 68 20 20 20 20 20 20 20 28 76 65 63 74 6f ath (vecto
5a10: 72 2d 72 65 66 20 74 65 73 74 72 65 63 6f 72 64 r-ref testrecord
5a20: 20 31 29 29 0a 09 09 20 28 73 74 61 74 65 20 20 1))... (state
5a30: 20 20 20 20 20 20 20 20 28 76 65 63 74 6f 72 2d (vector-
5a40: 72 65 66 20 74 65 73 74 72 65 63 6f 72 64 20 32 ref testrecord 2
5a50: 29 29 0a 09 09 20 28 73 74 61 74 75 73 20 20 20 ))... (status
5a60: 20 20 20 20 20 20 28 76 65 63 74 6f 72 2d 72 65 (vector-re
5a70: 66 20 74 65 73 74 72 65 63 6f 72 64 20 33 29 29 f testrecord 3))
5a80: 0a 09 09 20 28 72 75 6e 5f 64 75 72 61 74 69 6f ... (run_duratio
5a90: 6e 20 20 20 28 76 65 63 74 6f 72 2d 72 65 66 20 n (vector-ref
5aa0: 74 65 73 74 72 65 63 6f 72 64 20 34 29 29 0a 09 testrecord 4))..
5ab0: 09 20 28 6c 6f 67 66 20 20 20 20 20 20 20 20 20 . (logf
5ac0: 20 20 28 76 65 63 74 6f 72 2d 72 65 66 20 74 65 (vector-ref te
5ad0: 73 74 72 65 63 6f 72 64 20 35 29 29 0a 09 09 20 strecord 5))...
5ae0: 28 63 6f 6d 6d 65 6e 74 20 20 20 20 20 20 20 20 (comment
5af0: 28 76 65 63 74 6f 72 2d 72 65 66 20 74 65 73 74 (vector-ref test
5b00: 72 65 63 6f 72 64 20 36 29 29 29 0a 09 20 20 20 record 6)))..
5b10: 20 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 (hash-table-se
5b20: 74 21 20 63 6f 75 6e 74 73 20 73 74 61 74 75 73 t! counts status
5b30: 20 28 2b 20 31 20 28 68 61 73 68 2d 74 61 62 6c (+ 1 (hash-tabl
5b40: 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 63 6f e-ref/default co
5b50: 75 6e 74 73 20 73 74 61 74 75 73 20 30 29 29 29 unts status 0)))
5b60: 0a 09 20 20 20 20 20 28 68 61 73 68 2d 74 61 62 .. (hash-tab
5b70: 6c 65 2d 73 65 74 21 20 73 74 61 74 65 63 6f 75 le-set! statecou
5b80: 6e 74 73 20 73 74 61 74 65 20 28 2b 20 31 20 28 nts state (+ 1 (
5b90: 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 hash-table-ref/d
5ba0: 65 66 61 75 6c 74 20 73 74 61 74 65 63 6f 75 6e efault statecoun
5bb0: 74 73 20 73 74 61 74 65 20 30 29 29 29 0a 09 20 ts state 0)))..
5bc0: 20 20 20 20 28 73 65 74 21 20 6f 75 74 74 78 74 (set! outtxt
5bd0: 20 28 63 6f 6e 63 20 6f 75 74 74 78 74 20 22 3c (conc outtxt "<
5be0: 74 72 3e 22 0a 09 09 09 09 3b 3b 20 22 3c 74 64 tr>".....;; "<td
5bf0: 3e 3c 61 20 68 72 65 66 3d 5c 22 22 20 69 74 65 ><a href=\"" ite
5c00: 6d 70 61 74 68 20 22 2f 22 20 6c 6f 67 66 20 22 mpath "/" logf "
5c10: 5c 22 3e 20 22 20 69 74 65 6d 70 61 74 68 20 22 \"> " itempath "
5c20: 3c 2f 61 3e 3c 2f 74 64 3e 22 20 0a 09 09 09 09 </a></td>" .....
5c30: 22 3c 74 64 3e 3c 61 20 68 72 65 66 3d 5c 22 22 "<td><a href=\""
5c40: 20 69 74 65 6d 70 61 74 68 20 22 2f 74 65 73 74 itempath "/test
5c50: 2d 73 75 6d 6d 61 72 79 2e 68 74 6d 6c 5c 22 3e -summary.html\">
5c60: 20 22 20 69 74 65 6d 70 61 74 68 20 22 3c 2f 61 " itempath "</a
5c70: 3e 3c 2f 74 64 3e 22 20 0a 09 09 09 09 22 3c 74 ></td>" ....."<t
5c80: 64 3e 22 20 73 74 61 74 65 20 20 20 20 22 3c 2f d>" state "</
5c90: 74 64 3e 22 20 0a 09 09 09 09 22 3c 74 64 3e 3c td>" ....."<td><
5ca0: 66 6f 6e 74 20 63 6f 6c 6f 72 3d 22 20 28 63 6f font color=" (co
5cb0: 6d 6d 6f 6e 3a 67 65 74 2d 63 6f 6c 6f 72 2d 66 mmon:get-color-f
5cc0: 72 6f 6d 2d 73 74 61 74 75 73 20 73 74 61 74 75 rom-status statu
5cd0: 73 29 0a 09 09 09 09 22 3e 22 20 20 20 73 74 61 s).....">" sta
5ce0: 74 75 73 20 20 20 22 3c 2f 66 6f 6e 74 3e 3c 2f tus "</font></
5cf0: 74 64 3e 22 0a 09 09 09 09 22 3c 74 64 3e 22 20 td>"....."<td>"
5d00: 28 69 66 20 28 65 71 75 61 6c 3f 20 63 6f 6d 6d (if (equal? comm
5d10: 65 6e 74 20 22 22 29 0a 09 09 09 09 09 20 20 20 ent "")......
5d20: 22 26 6e 62 73 70 3b 22 0a 09 09 09 09 09 20 20 " "......
5d30: 20 63 6f 6d 6d 65 6e 74 29 20 22 3c 2f 74 64 3e comment) "</td>
5d40: 22 0a 09 09 09 09 09 20 20 20 22 3c 2f 74 72 3e "...... "</tr>
5d50: 22 29 29 29 29 0a 09 20 28 69 66 20 28 6c 69 73 ")))).. (if (lis
5d60: 74 3f 20 74 65 73 74 64 61 74 29 0a 09 20 20 20 t? testdat)..
5d70: 20 20 74 65 73 74 64 61 74 0a 09 20 20 20 20 20 testdat..
5d80: 28 62 65 67 69 6e 0a 09 20 20 20 20 20 20 20 28 (begin.. (
5d90: 70 72 69 6e 74 20 22 45 52 52 4f 52 3a 20 66 61 print "ERROR: fa
5da0: 69 6c 65 64 20 74 6f 20 67 65 74 20 72 65 63 6f iled to get reco
5db0: 72 64 73 20 77 69 74 68 20 72 6d 74 3a 74 65 73 rds with rmt:tes
5dc0: 74 2d 67 65 74 2d 72 65 63 6f 72 64 73 2d 66 6f t-get-records-fo
5dd0: 72 2d 69 6e 64 65 78 2d 66 69 6c 65 20 72 75 6e r-index-file run
5de0: 2d 69 64 3d 22 20 72 75 6e 2d 69 64 20 22 74 65 -id=" run-id "te
5df0: 73 74 2d 6e 61 6d 65 3d 22 20 74 65 73 74 2d 6e st-name=" test-n
5e00: 61 6d 65 29 0a 09 20 20 20 20 20 20 20 27 28 29 ame).. '()
5e10: 29 29 29 0a 09 0a 09 28 70 72 69 6e 74 20 22 3c )))....(print "<
5e20: 74 61 62 6c 65 3e 3c 74 72 3e 3c 74 64 20 76 61 table><tr><td va
5e30: 6c 69 67 6e 3d 5c 22 74 6f 70 5c 22 3e 22 29 0a lign=\"top\">").
5e40: 09 3b 3b 20 50 72 69 6e 74 20 6f 75 74 20 73 74 .;; Print out st
5e50: 61 74 73 20 66 6f 72 20 73 74 61 74 75 73 0a 09 ats for status..
5e60: 28 73 65 74 21 20 74 6f 74 20 30 29 0a 09 28 70 (set! tot 0)..(p
5e70: 72 69 6e 74 20 22 3c 74 61 62 6c 65 20 63 65 6c rint "<table cel
5e80: 6c 73 70 61 63 69 6e 67 3d 5c 22 30 5c 22 20 62 lspacing=\"0\" b
5e90: 6f 72 64 65 72 3d 5c 22 31 5c 22 3e 3c 74 72 3e order=\"1\"><tr>
5ea0: 3c 74 64 20 63 6f 6c 73 70 61 6e 3d 5c 22 32 5c <td colspan=\"2\
5eb0: 22 3e 3c 68 32 3e 53 74 61 74 65 20 73 74 61 74 "><h2>State stat
5ec0: 73 3c 2f 68 32 3e 3c 2f 74 64 3e 3c 2f 74 72 3e s</h2></td></tr>
5ed0: 22 29 0a 09 28 66 6f 72 2d 65 61 63 68 20 28 6c ")..(for-each (l
5ee0: 61 6d 62 64 61 20 28 73 74 61 74 65 29 0a 09 09 ambda (state)...
5ef0: 20 20 20 20 28 73 65 74 21 20 74 6f 74 20 28 2b (set! tot (+
5f00: 20 74 6f 74 20 28 68 61 73 68 2d 74 61 62 6c 65 tot (hash-table
5f10: 2d 72 65 66 20 73 74 61 74 65 63 6f 75 6e 74 73 -ref statecounts
5f20: 20 73 74 61 74 65 29 29 29 0a 09 09 20 20 20 20 state)))...
5f30: 28 70 72 69 6e 74 20 22 3c 74 72 3e 3c 74 64 3e (print "<tr><td>
5f40: 22 20 73 74 61 74 65 20 22 3c 2f 74 64 3e 3c 74 " state "</td><t
5f50: 64 3e 22 20 28 68 61 73 68 2d 74 61 62 6c 65 2d d>" (hash-table-
5f60: 72 65 66 20 73 74 61 74 65 63 6f 75 6e 74 73 20 ref statecounts
5f70: 73 74 61 74 65 29 20 22 3c 2f 74 64 3e 3c 2f 74 state) "</td></t
5f80: 72 3e 22 29 29 0a 09 09 20 20 28 68 61 73 68 2d r>"))... (hash-
5f90: 74 61 62 6c 65 2d 6b 65 79 73 20 73 74 61 74 65 table-keys state
5fa0: 63 6f 75 6e 74 73 29 29 0a 09 28 70 72 69 6e 74 counts))..(print
5fb0: 20 22 3c 74 72 3e 3c 74 64 3e 54 6f 74 61 6c 3c "<tr><td>Total<
5fc0: 2f 74 64 3e 3c 74 64 3e 22 20 74 6f 74 20 22 3c /td><td>" tot "<
5fd0: 2f 74 64 3e 3c 2f 74 72 3e 3c 2f 74 61 62 6c 65 /td></tr></table
5fe0: 3e 22 29 0a 09 28 70 72 69 6e 74 20 22 3c 2f 74 >")..(print "</t
5ff0: 64 3e 3c 74 64 20 76 61 6c 69 67 6e 3d 5c 22 74 d><td valign=\"t
6000: 6f 70 5c 22 3e 22 29 0a 09 3b 3b 20 50 72 69 6e op\">")..;; Prin
6010: 74 20 6f 75 74 20 73 74 61 74 73 20 66 6f 72 20 t out stats for
6020: 73 74 61 74 65 0a 09 28 73 65 74 21 20 74 6f 74 state..(set! tot
6030: 20 30 29 0a 09 28 70 72 69 6e 74 20 22 3c 74 61 0)..(print "<ta
6040: 62 6c 65 20 63 65 6c 6c 73 70 61 63 69 6e 67 3d ble cellspacing=
6050: 5c 22 30 5c 22 20 62 6f 72 64 65 72 3d 5c 22 31 \"0\" border=\"1
6060: 5c 22 3e 3c 74 72 3e 3c 74 64 20 63 6f 6c 73 70 \"><tr><td colsp
6070: 61 6e 3d 5c 22 32 5c 22 3e 3c 68 32 3e 53 74 61 an=\"2\"><h2>Sta
6080: 74 75 73 20 73 74 61 74 73 3c 2f 68 32 3e 3c 2f tus stats</h2></
6090: 74 64 3e 3c 2f 74 72 3e 22 29 0a 09 28 66 6f 72 td></tr>")..(for
60a0: 2d 65 61 63 68 20 28 6c 61 6d 62 64 61 20 28 73 -each (lambda (s
60b0: 74 61 74 75 73 29 0a 09 09 20 20 20 20 28 73 65 tatus)... (se
60c0: 74 21 20 74 6f 74 20 28 2b 20 74 6f 74 20 28 68 t! tot (+ tot (h
60d0: 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 20 63 6f ash-table-ref co
60e0: 75 6e 74 73 20 73 74 61 74 75 73 29 29 29 0a 09 unts status)))..
60f0: 09 20 20 20 20 28 70 72 69 6e 74 20 22 3c 74 72 . (print "<tr
6100: 3e 3c 74 64 3e 3c 66 6f 6e 74 20 63 6f 6c 6f 72 ><td><font color
6110: 3d 5c 22 22 20 28 63 6f 6d 6d 6f 6e 3a 67 65 74 =\"" (common:get
6120: 2d 63 6f 6c 6f 72 2d 66 72 6f 6d 2d 73 74 61 74 -color-from-stat
6130: 75 73 20 73 74 61 74 75 73 29 20 22 5c 22 3e 22 us status) "\">"
6140: 20 73 74 61 74 75 73 0a 09 09 09 20 20 20 22 3c status.... "<
6150: 2f 66 6f 6e 74 3e 3c 2f 74 64 3e 3c 74 64 3e 22 /font></td><td>"
6160: 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 (hash-table-ref
6170: 20 63 6f 75 6e 74 73 20 73 74 61 74 75 73 29 20 counts status)
6180: 22 3c 2f 74 64 3e 3c 2f 74 72 3e 22 29 29 0a 09 "</td></tr>"))..
6190: 09 20 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 6b . (hash-table-k
61a0: 65 79 73 20 63 6f 75 6e 74 73 29 29 0a 09 28 70 eys counts))..(p
61b0: 72 69 6e 74 20 22 3c 74 72 3e 3c 74 64 3e 54 6f rint "<tr><td>To
61c0: 74 61 6c 3c 2f 74 64 3e 3c 74 64 3e 22 20 74 6f tal</td><td>" to
61d0: 74 20 22 3c 2f 74 64 3e 3c 2f 74 72 3e 3c 2f 74 t "</td></tr></t
61e0: 61 62 6c 65 3e 22 29 0a 09 28 70 72 69 6e 74 20 able>")..(print
61f0: 22 3c 2f 74 64 3e 3c 2f 74 64 3e 3c 2f 74 72 3e "</td></td></tr>
6200: 3c 2f 74 61 62 6c 65 3e 22 29 0a 09 0a 09 28 70 </table>")....(p
6210: 72 69 6e 74 20 22 3c 74 61 62 6c 65 20 63 65 6c rint "<table cel
6220: 6c 73 70 61 63 69 6e 67 3d 5c 22 30 5c 22 20 62 lspacing=\"0\" b
6230: 6f 72 64 65 72 3d 5c 22 31 5c 22 3e 22 20 0a 09 order=\"1\">" ..
6240: 20 20 20 20 20 20 20 22 3c 74 72 3e 3c 74 64 3e "<tr><td>
6250: 49 74 65 6d 3c 2f 74 64 3e 3c 74 64 3e 53 74 61 Item</td><td>Sta
6260: 74 65 3c 2f 74 64 3e 3c 74 64 3e 53 74 61 74 75 te</td><td>Statu
6270: 73 3c 2f 74 64 3e 3c 74 64 3e 43 6f 6d 6d 65 6e s</td><td>Commen
6280: 74 3c 2f 74 64 3e 22 0a 09 20 20 20 20 20 20 20 t</td>"..
6290: 6f 75 74 74 78 74 20 22 3c 2f 74 61 62 6c 65 3e outtxt "</table>
62a0: 3c 2f 62 6f 64 79 3e 3c 2f 68 74 6d 6c 3e 22 29 </body></html>")
62b0: 0a 09 3b 3b 20 28 72 65 6c 65 61 73 65 2d 64 6f ..;; (release-do
62c0: 74 2d 6c 6f 63 6b 20 6f 75 74 70 75 74 66 69 6c t-lock outputfil
62d0: 65 6e 61 6d 65 29 0a 09 3b 3b 28 72 6d 74 3a 75 ename)..;;(rmt:u
62e0: 70 64 61 74 65 2d 72 75 6e 2d 73 74 61 74 73 20 pdate-run-stats
62f0: 0a 09 3b 3b 20 72 75 6e 2d 69 64 0a 09 3b 3b 20 ..;; run-id..;;
6300: 28 68 61 73 68 2d 74 61 62 6c 65 2d 6d 61 70 0a (hash-table-map.
6310: 09 3b 3b 20 20 73 74 61 74 65 2d 73 74 61 74 75 .;; state-statu
6320: 73 2d 63 6f 75 6e 74 73 0a 09 3b 3b 20 20 28 6c s-counts..;; (l
6330: 61 6d 62 64 61 20 28 6b 65 79 20 76 61 6c 29 0a ambda (key val).
6340: 09 3b 3b 09 28 61 70 70 65 6e 64 20 6b 65 79 20 .;;.(append key
6350: 28 6c 69 73 74 20 76 61 6c 29 29 29 29 29 0a 09 (list val)))))..
6360: 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 74 65 ))))..(define te
6370: 73 74 73 3a 63 73 73 2d 6a 73 63 72 69 70 74 2d sts:css-jscript-
6380: 62 6c 6f 63 6b 0a 23 3c 3c 45 4f 46 0a 3c 73 74 block.#<<EOF.<st
6390: 79 6c 65 20 74 79 70 65 3d 22 74 65 78 74 2f 63 yle type="text/c
63a0: 73 73 22 3e 0a 75 6c 2e 4c 69 6e 6b 65 64 4c 69 ss">.ul.LinkedLi
63b0: 73 74 20 7b 20 64 69 73 70 6c 61 79 3a 20 62 6c st { display: bl
63c0: 6f 63 6b 3b 20 7d 0a 2f 2a 20 75 6c 2e 4c 69 6e ock; }./* ul.Lin
63d0: 6b 65 64 4c 69 73 74 20 75 6c 20 7b 20 64 69 73 kedList ul { dis
63e0: 70 6c 61 79 3a 20 6e 6f 6e 65 3b 20 7d 20 2a 2f play: none; } */
63f0: 0a 2e 48 61 6e 64 43 75 72 73 6f 72 53 74 79 6c ..HandCursorStyl
6400: 65 20 7b 20 63 75 72 73 6f 72 3a 20 70 6f 69 6e e { cursor: poin
6410: 74 65 72 3b 20 63 75 72 73 6f 72 3a 20 68 61 6e ter; cursor: han
6420: 64 3b 20 7d 20 20 2f 2a 20 46 6f 72 20 49 45 20 d; } /* For IE
6430: 2a 2f 0a 74 68 20 7b 62 61 63 6b 67 72 6f 75 6e */.th {backgroun
6440: 64 2d 63 6f 6c 6f 72 3a 20 23 38 63 38 63 38 63 d-color: #8c8c8c
6450: 3b 7d 0a 74 64 2e 74 65 73 74 20 7b 62 61 63 6b ;}.td.test {back
6460: 67 72 6f 75 6e 64 2d 63 6f 6c 6f 72 3a 20 23 64 ground-color: #d
6470: 39 64 62 64 64 3b 7d 0a 74 64 2e 50 41 53 53 20 9dbdd;}.td.PASS
6480: 7b 62 61 63 6b 67 72 6f 75 6e 64 2d 63 6f 6c 6f {background-colo
6490: 72 3a 20 23 33 34 37 35 33 33 3b 7d 0a 74 64 2e r: #347533;}.td.
64a0: 46 41 49 4c 20 7b 62 61 63 6b 67 72 6f 75 6e 64 FAIL {background
64b0: 2d 63 6f 6c 6f 72 3a 20 23 63 63 32 38 31 32 3b -color: #cc2812;
64c0: 7d 0a 0a 20 20 3c 2f 73 74 79 6c 65 3e 0a 20 20 }.. </style>.
64d0: 3c 73 63 72 69 70 74 20 73 72 63 3d 2f 6e 66 73 <script src=/nfs
64e0: 2f 73 69 74 65 2f 64 69 73 6b 73 2f 63 68 5f 63 /site/disks/ch_c
64f0: 69 61 66 5f 64 69 73 6b 30 32 33 2f 66 64 6b 5f iaf_disk023/fdk_
6500: 67 77 61 5f 64 69 73 6b 30 30 33 2f 70 6a 68 61 gwa_disk003/pjha
6510: 74 77 61 6c 2f 66 64 6b 2f 64 6f 63 73 2f 71 61 twal/fdk/docs/qa
6520: 2d 65 6e 76 2d 74 65 61 6d 2f 6a 71 75 65 72 79 -env-team/jquery
6530: 2d 33 2e 31 2e 30 2e 73 6c 69 6d 2e 6d 69 6e 2e -3.1.0.slim.min.
6540: 6a 73 3e 3c 2f 73 63 72 69 70 74 3e 0a 0a 0a 20 js></script>...
6550: 20 3c 73 63 72 69 70 74 20 74 79 70 65 3d 22 74 <script type="t
6560: 65 78 74 2f 4a 61 76 61 53 63 72 69 70 74 22 3e ext/JavaScript">
6570: 0a 0a 20 20 20 20 66 75 6e 63 74 69 6f 6e 20 66 .. function f
6580: 69 6c 74 65 72 73 6f 6d 65 28 29 20 7b 0a 20 20 iltersome() {.
6590: 24 28 22 74 72 22 29 2e 73 68 6f 77 28 29 3b 0a $("tr").show();.
65a0: 20 20 24 28 22 2e 74 65 73 74 22 29 2e 66 69 6c $(".test").fil
65b0: 74 65 72 28 0a 20 20 20 20 66 75 6e 63 74 69 6f ter(. functio
65c0: 6e 28 29 20 7b 0a 20 20 20 20 20 20 76 61 72 20 n() {. var
65d0: 6e 61 6d 65 73 20 3d 20 24 28 27 23 74 65 73 74 names = $('#test
65e0: 6e 61 6d 65 27 29 2e 76 61 6c 28 29 2e 73 70 6c name').val().spl
65f0: 69 74 28 27 2c 27 29 3b 0a 20 20 20 20 20 20 76 it(',');. v
6600: 61 72 20 67 6f 6f 64 3d 31 3b 0a 20 20 20 20 20 ar good=1;.
6610: 20 66 6f 72 20 28 76 61 72 20 69 3d 30 2c 20 6c for (var i=0, l
6620: 65 6e 3d 6e 61 6d 65 73 2e 6c 65 6e 67 74 68 3b en=names.length;
6630: 20 69 3c 6c 65 6e 3b 20 69 2b 2b 29 20 7b 0a 20 i<len; i++) {.
6640: 20 20 20 20 20 20 20 76 61 72 20 75 6e 61 6d 65 var uname
6650: 3d 6e 61 6d 65 73 5b 69 5d 3b 0a 20 20 20 20 20 =names[i];.
6660: 20 20 20 63 6f 6e 73 6f 6c 65 2e 6c 6f 67 28 22 console.log("
6670: 54 72 79 69 6e 67 20 74 6f 20 63 68 65 63 6b 20 Trying to check
6680: 66 6f 72 20 22 20 2b 20 75 6e 61 6d 65 29 3b 20 for " + uname);
6690: 0a 20 20 20 20 20 20 20 20 69 66 28 24 28 74 68 . if($(th
66a0: 69 73 29 2e 74 65 78 74 28 29 2e 69 6e 64 65 78 is).text().index
66b0: 4f 66 28 75 6e 61 6d 65 29 20 21 3d 20 2d 31 29 Of(uname) != -1)
66c0: 20 7b 0a 20 20 20 20 20 20 20 20 20 20 67 6f 6f {. goo
66d0: 64 3d 20 30 3b 0a 20 20 20 20 20 20 20 20 20 20 d= 0;.
66e0: 63 6f 6e 73 6f 6c 65 2e 6c 6f 67 28 22 46 6f 75 console.log("Fou
66f0: 6e 64 20 22 2b 75 6e 61 6d 65 29 3b 0a 20 20 20 nd "+uname);.
6700: 20 20 20 20 20 7d 0a 20 20 20 20 20 20 7d 0a 20 }. }.
6710: 20 20 20 20 20 72 65 74 75 72 6e 20 67 6f 6f 64 return good
6720: 3b 20 0a 20 20 20 20 7d 0a 20 20 29 2e 70 61 72 ; . }. ).par
6730: 65 6e 74 28 29 2e 68 69 64 65 28 29 3b 0a 2f 2f ent().hide();.//
6740: 20 20 24 28 22 2e 73 75 6d 22 29 2e 73 68 6f 77 $(".sum").show
6750: 28 29 3b 0a 7d 0a 20 20 0a 20 20 20 20 2f 2f 20 ();.}. . //
6760: 41 64 64 20 74 68 69 73 20 74 6f 20 74 68 65 20 Add this to the
6770: 6f 6e 6c 6f 61 64 20 65 76 65 6e 74 20 6f 66 20 onload event of
6780: 74 68 65 20 42 4f 44 59 20 65 6c 65 6d 65 6e 74 the BODY element
6790: 0a 20 20 20 20 66 75 6e 63 74 69 6f 6e 20 61 64 . function ad
67a0: 64 45 76 65 6e 74 73 28 29 20 7b 0a 20 20 20 20 dEvents() {.
67b0: 20 20 61 63 74 69 76 61 74 65 54 72 65 65 28 64 activateTree(d
67c0: 6f 63 75 6d 65 6e 74 2e 67 65 74 45 6c 65 6d 65 ocument.getEleme
67d0: 6e 74 42 79 49 64 28 22 4c 69 6e 6b 65 64 4c 69 ntById("LinkedLi
67e0: 73 74 31 22 29 29 3b 0a 20 20 20 20 7d 0a 0a 20 st1"));. }..
67f0: 20 20 20 2f 2f 20 54 68 69 73 20 66 75 6e 63 74 // This funct
6800: 69 6f 6e 20 74 72 61 76 65 72 73 65 73 20 74 68 ion traverses th
6810: 65 20 6c 69 73 74 20 61 6e 64 20 61 64 64 20 6c e list and add l
6820: 69 6e 6b 73 20 0a 20 20 20 20 2f 2f 20 74 6f 20 inks . // to
6830: 6e 65 73 74 65 64 20 6c 69 73 74 20 69 74 65 6d nested list item
6840: 73 0a 20 20 20 20 66 75 6e 63 74 69 6f 6e 20 61 s. function a
6850: 63 74 69 76 61 74 65 54 72 65 65 28 6f 4c 69 73 ctivateTree(oLis
6860: 74 29 20 7b 0a 20 20 20 20 20 20 2f 2f 20 43 6f t) {. // Co
6870: 6c 6c 61 70 73 65 20 74 68 65 20 74 72 65 65 0a llapse the tree.
6880: 20 20 20 20 20 20 66 6f 72 20 28 76 61 72 20 69 for (var i
6890: 3d 30 3b 20 69 20 3c 20 6f 4c 69 73 74 2e 67 65 =0; i < oList.ge
68a0: 74 45 6c 65 6d 65 6e 74 73 42 79 54 61 67 4e 61 tElementsByTagNa
68b0: 6d 65 28 22 75 6c 22 29 2e 6c 65 6e 67 74 68 3b me("ul").length;
68c0: 20 69 2b 2b 29 20 7b 0a 20 20 20 20 20 20 20 20 i++) {.
68d0: 6f 4c 69 73 74 2e 67 65 74 45 6c 65 6d 65 6e 74 oList.getElement
68e0: 73 42 79 54 61 67 4e 61 6d 65 28 22 75 6c 22 29 sByTagName("ul")
68f0: 5b 69 5d 2e 73 74 79 6c 65 2e 64 69 73 70 6c 61 [i].style.displa
6900: 79 3d 22 6e 6f 6e 65 22 3b 20 20 20 20 20 20 20 y="none";
6910: 20 20 20 20 20 0a 20 20 20 20 20 20 7d 20 20 20 . }
6920: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
6930: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
6940: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
6950: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 0a .
6960: 20 20 20 20 20 20 2f 2f 20 41 64 64 20 74 68 65 // Add the
6970: 20 63 6c 69 63 6b 2d 65 76 65 6e 74 20 68 61 6e click-event han
6980: 64 6c 65 72 20 74 6f 20 74 68 65 20 6c 69 73 74 dler to the list
6990: 20 69 74 65 6d 73 0a 20 20 20 20 20 20 69 66 20 items. if
69a0: 28 6f 4c 69 73 74 2e 61 64 64 45 76 65 6e 74 4c (oList.addEventL
69b0: 69 73 74 65 6e 65 72 29 20 7b 0a 20 20 20 20 20 istener) {.
69c0: 20 20 20 6f 4c 69 73 74 2e 61 64 64 45 76 65 6e oList.addEven
69d0: 74 4c 69 73 74 65 6e 65 72 28 22 63 6c 69 63 6b tListener("click
69e0: 22 2c 20 74 6f 67 67 6c 65 42 72 61 6e 63 68 2c ", toggleBranch,
69f0: 20 66 61 6c 73 65 29 3b 0a 20 20 20 20 20 20 7d false);. }
6a00: 20 65 6c 73 65 20 69 66 20 28 6f 4c 69 73 74 2e else if (oList.
6a10: 61 74 74 61 63 68 45 76 65 6e 74 29 20 7b 20 2f attachEvent) { /
6a20: 2f 20 46 6f 72 20 49 45 0a 20 20 20 20 20 20 20 / For IE.
6a30: 20 6f 4c 69 73 74 2e 61 74 74 61 63 68 45 76 65 oList.attachEve
6a40: 6e 74 28 22 6f 6e 63 6c 69 63 6b 22 2c 20 74 6f nt("onclick", to
6a50: 67 67 6c 65 42 72 61 6e 63 68 29 3b 0a 20 20 20 ggleBranch);.
6a60: 20 20 20 7d 0a 20 20 20 20 20 20 2f 2f 20 4d 61 }. // Ma
6a70: 6b 65 20 74 68 65 20 6e 65 73 74 65 64 20 69 74 ke the nested it
6a80: 65 6d 73 20 6c 6f 6f 6b 20 6c 69 6b 65 20 6c 69 ems look like li
6a90: 6e 6b 73 0a 20 20 20 20 20 20 61 64 64 4c 69 6e nks. addLin
6aa0: 6b 73 54 6f 42 72 61 6e 63 68 65 73 28 6f 4c 69 ksToBranches(oLi
6ab0: 73 74 29 3b 0a 20 20 20 20 7d 0a 0a 20 20 20 20 st);. }..
6ac0: 2f 2f 20 54 68 69 73 20 69 73 20 74 68 65 20 63 // This is the c
6ad0: 6c 69 63 6b 2d 65 76 65 6e 74 20 68 61 6e 64 6c lick-event handl
6ae0: 65 72 0a 20 20 20 20 66 75 6e 63 74 69 6f 6e 20 er. function
6af0: 74 6f 67 67 6c 65 42 72 61 6e 63 68 28 65 76 65 toggleBranch(eve
6b00: 6e 74 29 20 7b 0a 20 20 20 20 20 20 76 61 72 20 nt) {. var
6b10: 6f 42 72 61 6e 63 68 2c 20 63 53 75 62 42 72 61 oBranch, cSubBra
6b20: 6e 63 68 65 73 3b 0a 20 20 20 20 20 20 69 66 20 nches;. if
6b30: 28 65 76 65 6e 74 2e 74 61 72 67 65 74 29 20 7b (event.target) {
6b40: 0a 20 20 20 20 20 20 20 20 6f 42 72 61 6e 63 68 . oBranch
6b50: 20 3d 20 65 76 65 6e 74 2e 74 61 72 67 65 74 3b = event.target;
6b60: 0a 20 20 20 20 20 20 7d 20 65 6c 73 65 20 69 66 . } else if
6b70: 20 28 65 76 65 6e 74 2e 73 72 63 45 6c 65 6d 65 (event.srcEleme
6b80: 6e 74 29 20 7b 20 2f 2f 20 46 6f 72 20 49 45 0a nt) { // For IE.
6b90: 20 20 20 20 20 20 20 20 6f 42 72 61 6e 63 68 20 oBranch
6ba0: 3d 20 65 76 65 6e 74 2e 73 72 63 45 6c 65 6d 65 = event.srcEleme
6bb0: 6e 74 3b 0a 20 20 20 20 20 20 7d 0a 20 20 20 20 nt;. }.
6bc0: 20 20 63 53 75 62 42 72 61 6e 63 68 65 73 20 3d cSubBranches =
6bd0: 20 6f 42 72 61 6e 63 68 2e 67 65 74 45 6c 65 6d oBranch.getElem
6be0: 65 6e 74 73 42 79 54 61 67 4e 61 6d 65 28 22 75 entsByTagName("u
6bf0: 6c 22 29 3b 0a 20 20 20 20 20 20 69 66 20 28 63 l");. if (c
6c00: 53 75 62 42 72 61 6e 63 68 65 73 2e 6c 65 6e 67 SubBranches.leng
6c10: 74 68 20 3e 20 30 29 20 7b 0a 20 20 20 20 20 20 th > 0) {.
6c20: 20 20 69 66 20 28 63 53 75 62 42 72 61 6e 63 68 if (cSubBranch
6c30: 65 73 5b 30 5d 2e 73 74 79 6c 65 2e 64 69 73 70 es[0].style.disp
6c40: 6c 61 79 20 3d 3d 20 22 62 6c 6f 63 6b 22 29 20 lay == "block")
6c50: 7b 0a 20 20 20 20 20 20 20 20 20 20 63 53 75 62 {. cSub
6c60: 42 72 61 6e 63 68 65 73 5b 30 5d 2e 73 74 79 6c Branches[0].styl
6c70: 65 2e 64 69 73 70 6c 61 79 20 3d 20 22 6e 6f 6e e.display = "non
6c80: 65 22 3b 0a 20 20 20 20 20 20 20 20 7d 20 65 6c e";. } el
6c90: 73 65 20 7b 0a 20 20 20 20 20 20 20 20 20 20 63 se {. c
6ca0: 53 75 62 42 72 61 6e 63 68 65 73 5b 30 5d 2e 73 SubBranches[0].s
6cb0: 74 79 6c 65 2e 64 69 73 70 6c 61 79 20 3d 20 22 tyle.display = "
6cc0: 62 6c 6f 63 6b 22 3b 0a 20 20 20 20 20 20 20 20 block";.
6cd0: 7d 0a 20 20 20 20 20 20 7d 0a 20 20 20 20 7d 0a }. }. }.
6ce0: 0a 20 20 20 20 2f 2f 20 54 68 69 73 20 66 75 6e . // This fun
6cf0: 63 74 69 6f 6e 20 6d 61 6b 65 73 20 6e 65 73 74 ction makes nest
6d00: 65 64 20 6c 69 73 74 20 69 74 65 6d 73 20 6c 6f ed list items lo
6d10: 6f 6b 20 6c 69 6b 65 20 6c 69 6e 6b 73 0a 20 20 ok like links.
6d20: 20 20 66 75 6e 63 74 69 6f 6e 20 61 64 64 4c 69 function addLi
6d30: 6e 6b 73 54 6f 42 72 61 6e 63 68 65 73 28 6f 4c nksToBranches(oL
6d40: 69 73 74 29 20 7b 0a 20 20 20 20 20 20 76 61 72 ist) {. var
6d50: 20 63 42 72 61 6e 63 68 65 73 20 3d 20 6f 4c 69 cBranches = oLi
6d60: 73 74 2e 67 65 74 45 6c 65 6d 65 6e 74 73 42 79 st.getElementsBy
6d70: 54 61 67 4e 61 6d 65 28 22 6c 69 22 29 3b 0a 20 TagName("li");.
6d80: 20 20 20 20 20 76 61 72 20 69 2c 20 6e 2c 20 63 var i, n, c
6d90: 53 75 62 42 72 61 6e 63 68 65 73 3b 0a 20 20 20 SubBranches;.
6da0: 20 20 20 69 66 20 28 63 42 72 61 6e 63 68 65 73 if (cBranches
6db0: 2e 6c 65 6e 67 74 68 20 3e 20 30 29 20 7b 0a 20 .length > 0) {.
6dc0: 20 20 20 20 20 20 20 66 6f 72 20 28 69 3d 30 2c for (i=0,
6dd0: 20 6e 20 3d 20 63 42 72 61 6e 63 68 65 73 2e 6c n = cBranches.l
6de0: 65 6e 67 74 68 3b 20 69 20 3c 20 6e 3b 20 69 2b ength; i < n; i+
6df0: 2b 29 20 7b 0a 20 20 20 20 20 20 20 20 20 20 63 +) {. c
6e00: 53 75 62 42 72 61 6e 63 68 65 73 20 3d 20 63 42 SubBranches = cB
6e10: 72 61 6e 63 68 65 73 5b 69 5d 2e 67 65 74 45 6c ranches[i].getEl
6e20: 65 6d 65 6e 74 73 42 79 54 61 67 4e 61 6d 65 28 ementsByTagName(
6e30: 22 75 6c 22 29 3b 0a 20 20 20 20 20 20 20 20 20 "ul");.
6e40: 20 69 66 20 28 63 53 75 62 42 72 61 6e 63 68 65 if (cSubBranche
6e50: 73 2e 6c 65 6e 67 74 68 20 3e 20 30 29 20 7b 0a s.length > 0) {.
6e60: 20 20 20 20 20 20 20 20 20 20 20 20 61 64 64 4c addL
6e70: 69 6e 6b 73 54 6f 42 72 61 6e 63 68 65 73 28 63 inksToBranches(c
6e80: 53 75 62 42 72 61 6e 63 68 65 73 5b 30 5d 29 3b SubBranches[0]);
6e90: 0a 20 20 20 20 20 20 20 20 20 20 20 20 63 42 72 . cBr
6ea0: 61 6e 63 68 65 73 5b 69 5d 2e 63 6c 61 73 73 4e anches[i].classN
6eb0: 61 6d 65 20 3d 20 22 48 61 6e 64 43 75 72 73 6f ame = "HandCurso
6ec0: 72 53 74 79 6c 65 22 3b 0a 20 20 20 20 20 20 20 rStyle";.
6ed0: 20 20 20 20 20 63 42 72 61 6e 63 68 65 73 5b 69 cBranches[i
6ee0: 5d 2e 73 74 79 6c 65 2e 63 6f 6c 6f 72 20 3d 20 ].style.color =
6ef0: 22 62 6c 75 65 22 3b 0a 20 20 20 20 20 20 20 20 "blue";.
6f00: 20 20 20 20 63 53 75 62 42 72 61 6e 63 68 65 73 cSubBranches
6f10: 5b 30 5d 2e 73 74 79 6c 65 2e 63 6f 6c 6f 72 20 [0].style.color
6f20: 3d 20 22 62 6c 61 63 6b 22 3b 0a 20 20 20 20 20 = "black";.
6f30: 20 20 20 20 20 20 20 63 53 75 62 42 72 61 6e 63 cSubBranc
6f40: 68 65 73 5b 30 5d 2e 73 74 79 6c 65 2e 63 75 72 hes[0].style.cur
6f50: 73 6f 72 20 3d 20 22 61 75 74 6f 22 3b 0a 20 20 sor = "auto";.
6f60: 20 20 20 20 20 20 20 20 7d 0a 20 20 20 20 20 20 }.
6f70: 20 20 7d 0a 20 20 20 20 20 20 7d 0a 20 20 20 20 }. }.
6f80: 7d 0a 20 20 3c 2f 73 63 72 69 70 74 3e 0a 45 4f }. </script>.EO
6f90: 46 0a 29 0a 0a 28 64 65 66 69 6e 65 20 28 74 65 F.)..(define (te
6fa0: 73 74 73 3a 72 75 6e 2d 72 65 63 6f 72 64 2d 3e sts:run-record->
6fb0: 74 65 73 74 2d 70 61 74 68 20 72 75 6e 20 6e 75 test-path run nu
6fc0: 6d 6b 65 79 73 29 0a 20 20 20 28 61 70 70 65 6e mkeys). (appen
6fd0: 64 20 28 74 61 6b 65 20 28 76 65 63 74 6f 72 2d d (take (vector-
6fe0: 3e 6c 69 73 74 20 72 75 6e 29 20 6e 75 6d 6b 65 >list run) numke
6ff0: 79 73 29 0a 09 20 20 20 28 6c 69 73 74 20 28 76 ys).. (list (v
7000: 65 63 74 6f 72 2d 72 65 66 20 72 75 6e 20 28 2b ector-ref run (+
7010: 20 31 20 6e 75 6d 6b 65 79 73 29 29 29 29 29 0a 1 numkeys))))).
7020: 0a 0a 28 64 65 66 69 6e 65 20 28 74 65 73 74 73 ..(define (tests
7030: 3a 67 65 74 2d 72 65 73 74 2d 64 61 74 61 20 72 :get-rest-data r
7040: 75 6e 73 20 68 65 61 64 65 72 20 6e 75 6d 6b 65 uns header numke
7050: 79 73 29 0a 20 20 20 28 6c 65 74 20 28 28 72 65 ys). (let ((re
7060: 73 68 20 28 6d 61 6b 65 2d 68 61 73 68 2d 74 61 sh (make-hash-ta
7070: 62 6c 65 29 29 29 0a 20 20 20 28 66 6f 72 2d 65 ble))). (for-e
7080: 61 63 68 0a 20 20 20 20 20 28 6c 61 6d 62 64 61 ach. (lambda
7090: 20 28 72 75 6e 29 0a 20 20 20 20 20 20 20 20 28 (run). (
70a0: 6c 65 74 2a 20 28 28 72 75 6e 2d 69 64 20 28 64 let* ((run-id (d
70b0: 62 3a 67 65 74 2d 76 61 6c 75 65 2d 62 79 2d 68 b:get-value-by-h
70c0: 65 61 64 65 72 20 72 75 6e 20 68 65 61 64 65 72 eader run header
70d0: 20 22 69 64 22 29 29 0a 20 20 20 20 20 20 20 20 "id")).
70e0: 20 20 20 20 20 20 20 28 72 75 6e 2d 64 69 72 20 (run-dir
70f0: 20 20 20 20 20 28 74 65 73 74 73 3a 72 75 6e 2d (tests:run-
7100: 72 65 63 6f 72 64 2d 3e 74 65 73 74 2d 70 61 74 record->test-pat
7110: 68 20 72 75 6e 20 6e 75 6d 6b 65 79 73 29 29 0a h run numkeys)).
7120: 09 20 20 20 20 20 20 20 28 74 65 73 74 2d 64 61 . (test-da
7130: 74 61 20 20 20 20 28 72 6d 74 3a 67 65 74 2d 74 ta (rmt:get-t
7140: 65 73 74 73 2d 66 6f 72 2d 72 75 6e 0a 09 09 09 ests-for-run....
7150: 09 20 20 20 72 75 6e 2d 69 64 0a 20 20 20 20 20 . run-id.
7160: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7170: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 22 25 "%
7180: 22 20 20 20 20 20 20 20 3b 3b 20 74 65 73 74 6e " ;; testn
7190: 61 6d 65 70 61 74 74 0a 09 09 09 09 20 20 20 27 amepatt..... '
71a0: 28 29 20 20 20 20 20 20 20 20 3b 3b 20 73 74 61 () ;; sta
71b0: 74 65 73 0a 09 09 09 09 20 20 20 27 28 29 20 20 tes..... '()
71c0: 20 20 20 20 20 20 3b 3b 20 73 74 61 74 75 73 65 ;; statuse
71d0: 73 0a 09 09 09 09 20 20 20 23 66 20 20 20 20 20 s..... #f
71e0: 20 20 20 20 3b 3b 20 6f 66 66 73 65 74 0a 09 09 ;; offset...
71f0: 09 09 20 20 20 23 66 20 20 20 20 20 20 20 20 20 .. #f
7200: 3b 3b 20 6e 75 6d 2d 74 6f 2d 67 65 74 0a 09 09 ;; num-to-get...
7210: 09 09 20 20 20 23 66 20 20 20 20 20 20 20 20 20 .. #f
7220: 3b 3b 20 68 69 64 65 2f 6e 6f 74 2d 68 69 64 65 ;; hide/not-hide
7230: 0a 09 09 09 09 20 20 20 23 66 20 20 20 20 20 20 ..... #f
7240: 20 20 20 3b 3b 20 73 6f 72 74 2d 62 79 0a 09 09 ;; sort-by...
7250: 09 09 20 20 20 23 66 20 20 20 20 20 20 20 20 20 .. #f
7260: 3b 3b 20 73 6f 72 74 2d 6f 72 64 65 72 0a 09 09 ;; sort-order...
7270: 09 09 20 20 20 23 66 20 20 20 20 20 20 20 20 20 .. #f
7280: 3b 3b 20 27 73 68 6f 72 74 6c 69 73 74 20 20 20 ;; 'shortlist
7290: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
72a0: 20 20 20 20 20 20 20 20 3b 3b 20 71 72 79 74 79 ;; qryty
72b0: 70 65 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 pe.
72c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
72d0: 20 20 20 20 20 20 30 20 20 20 20 20 20 20 20 20 0
72e0: 3b 3b 20 6c 61 73 74 20 75 70 64 61 74 65 0a 09 ;; last update..
72f0: 09 09 09 20 20 20 23 66 29 29 29 0a 20 20 20 20 ... #f))).
7300: 20 20 20 20 20 20 20 20 0a 20 20 20 20 20 20 20 .
7310: 20 20 20 20 20 28 6d 61 70 20 28 6c 61 6d 62 64 (map (lambd
7320: 61 20 28 74 65 73 74 29 0a 20 20 20 20 20 20 20 a (test).
7330: 20 20 20 20 20 20 20 20 20 20 28 6c 65 74 2a 20 (let*
7340: 28 28 74 65 73 74 2d 6e 61 6d 65 20 28 76 65 63 ((test-name (vec
7350: 74 6f 72 2d 72 65 66 20 74 65 73 74 20 32 29 29 tor-ref test 2))
7360: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
7370: 20 20 20 20 20 20 20 20 20 28 74 65 73 74 2d 68 (test-h
7380: 74 6d 6c 2d 70 61 74 68 20 28 63 6f 6e 63 20 28 tml-path (conc (
7390: 76 65 63 74 6f 72 2d 72 65 66 20 74 65 73 74 20 vector-ref test
73a0: 31 30 29 20 22 2f 22 20 28 76 65 63 74 6f 72 2d 10) "/" (vector-
73b0: 72 65 66 20 74 65 73 74 20 31 33 29 29 29 0a 20 ref test 13))).
73c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
73d0: 20 20 20 20 20 20 20 28 74 65 73 74 2d 69 74 65 (test-ite
73e0: 6d 20 28 63 6f 6e 63 20 74 65 73 74 2d 6e 61 6d m (conc test-nam
73f0: 65 20 22 3a 22 20 28 76 65 63 74 6f 72 2d 72 65 e ":" (vector-re
7400: 66 20 74 65 73 74 20 31 31 29 29 29 0a 20 20 20 f test 11))).
7410: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7420: 20 20 20 20 20 28 74 65 73 74 2d 73 74 61 74 75 (test-statu
7430: 73 20 28 76 65 63 74 6f 72 2d 72 65 66 20 74 65 s (vector-ref te
7440: 73 74 20 34 29 29 29 0a 20 20 20 20 20 20 20 20 st 4))).
7450: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7460: 20 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
7470: 20 20 28 69 66 20 28 6e 6f 74 20 28 68 61 73 68 (if (not (hash
7480: 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 -table-ref/defau
7490: 6c 74 20 72 65 73 68 20 74 65 73 74 2d 6e 61 6d lt resh test-nam
74a0: 65 20 20 23 66 29 29 0a 20 20 20 20 20 20 20 20 e #f)).
74b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 68 (h
74c0: 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 72 ash-table-set! r
74d0: 65 73 68 20 74 65 73 74 2d 6e 61 6d 65 20 20 20 esh test-name
74e0: 28 6d 61 6b 65 2d 68 61 73 68 2d 74 61 62 6c 65 (make-hash-table
74f0: 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 ))).
7500: 20 20 20 20 28 69 66 20 28 6e 6f 74 20 28 68 61 (if (not (ha
7510: 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 sh-table-ref/def
7520: 61 75 6c 74 20 28 68 61 73 68 2d 74 61 62 6c 65 ault (hash-table
7530: 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 72 65 73 -ref/default res
7540: 68 20 74 65 73 74 2d 6e 61 6d 65 20 20 23 66 29 h test-name #f)
7550: 20 20 74 65 73 74 2d 69 74 65 6d 20 20 23 66 29 test-item #f)
7560: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
7570: 20 20 20 20 20 20 20 20 20 28 68 61 73 68 2d 74 (hash-t
7580: 61 62 6c 65 2d 73 65 74 21 20 28 68 61 73 68 2d able-set! (hash-
7590: 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c table-ref/defaul
75a0: 74 20 72 65 73 68 20 74 65 73 74 2d 6e 61 6d 65 t resh test-name
75b0: 20 20 23 66 29 20 74 65 73 74 2d 69 74 65 6d 20 #f) test-item
75c0: 20 20 28 6d 61 6b 65 2d 68 61 73 68 2d 74 61 62 (make-hash-tab
75d0: 6c 65 29 29 29 20 0a 20 20 20 20 20 20 20 20 20 le))) .
75e0: 20 20 20 20 20 20 28 68 61 73 68 2d 74 61 62 6c (hash-tabl
75f0: 65 2d 73 65 74 21 20 20 28 68 61 73 68 2d 74 61 e-set! (hash-ta
7600: 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 ble-ref/default
7610: 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f (hash-table-ref/
7620: 64 65 66 61 75 6c 74 20 72 65 73 68 20 74 65 73 default resh tes
7630: 74 2d 6e 61 6d 65 20 20 23 66 29 20 74 65 73 74 t-name #f) test
7640: 2d 69 74 65 6d 20 23 66 29 20 72 75 6e 2d 69 64 -item #f) run-id
7650: 20 28 6c 69 73 74 20 74 65 73 74 2d 73 74 61 74 (list test-stat
7660: 75 73 20 74 65 73 74 2d 68 74 6d 6c 2d 70 61 74 us test-html-pat
7670: 68 29 29 29 29 20 0a 20 20 20 20 20 20 20 20 74 h)))) . t
7680: 65 73 74 2d 64 61 74 61 29 29 29 0a 20 20 20 20 est-data))).
7690: 20 20 72 75 6e 73 29 0a 20 20 20 72 65 73 68 29 runs). resh)
76a0: 29 0a 0a 3b 3b 20 28 74 65 73 74 73 3a 63 72 65 )..;; (tests:cre
76b0: 61 74 65 2d 68 74 6d 6c 2d 74 72 65 65 20 22 74 ate-html-tree "t
76c0: 65 73 74 2d 69 6e 64 65 78 2e 68 74 6d 6c 22 29 est-index.html")
76d0: 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 74 65 73 .;;.(define (tes
76e0: 74 73 3a 63 72 65 61 74 65 2d 68 74 6d 6c 2d 74 ts:create-html-t
76f0: 72 65 65 20 6f 75 74 66 29 0a 20 20 20 28 6c 65 ree outf). (le
7700: 74 2a 20 28 28 6c 6f 63 6b 66 69 6c 65 20 20 28 t* ((lockfile (
7710: 63 6f 6e 63 20 6f 75 74 66 20 22 2e 6c 6f 63 6b conc outf ".lock
7720: 22 29 29 0a 09 20 28 72 75 6e 73 2d 74 6f 2d 70 ")).. (runs-to-p
7730: 72 6f 63 65 73 73 20 27 28 29 29 0a 20 20 20 20 rocess '()).
7740: 20 20 20 20 20 28 6c 69 6e 6b 74 72 65 65 20 20 (linktree
7750: 28 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 6c 69 6e 6b (common:get-link
7760: 74 72 65 65 29 29 0a 20 20 20 20 20 20 20 20 20 tree)).
7770: 20 28 61 72 65 61 2d 6e 61 6d 65 20 28 63 6f 6d (area-name (com
7780: 6d 6f 6e 3a 67 65 74 2d 74 65 73 74 73 75 69 74 mon:get-testsuit
7790: 65 2d 6e 61 6d 65 29 29 0a 09 20 20 28 6b 65 79 e-name)).. (key
77a0: 73 20 20 20 20 20 20 28 72 6d 74 3a 67 65 74 2d s (rmt:get-
77b0: 6b 65 79 73 29 29 0a 09 20 20 28 6e 75 6d 6b 65 keys)).. (numke
77c0: 79 73 20 20 20 28 6c 65 6e 67 74 68 20 6b 65 79 ys (length key
77d0: 73 29 29 0a 20 20 20 20 20 20 20 20 20 28 74 6f s)). (to
77e0: 74 61 6c 2d 72 75 6e 73 20 20 28 72 6d 74 3a 67 tal-runs (rmt:g
77f0: 65 74 2d 6e 75 6d 2d 72 75 6e 73 20 22 25 22 29 et-num-runs "%")
7800: 29 0a 20 20 20 20 20 20 20 20 20 28 70 67 2d 73 ). (pg-s
7810: 69 7a 65 20 31 30 29 20 20 20 29 0a 20 20 20 20 ize 10) ).
7820: 28 69 66 20 28 63 6f 6d 6d 6f 6e 3a 73 69 6d 70 (if (common:simp
7830: 6c 65 2d 66 69 6c 65 2d 6c 6f 63 6b 20 6c 6f 63 le-file-lock loc
7840: 6b 66 69 6c 65 29 0a 20 20 20 20 20 20 20 20 28 kfile). (
7850: 62 65 67 69 6e 0a 20 20 20 20 20 20 20 20 20 28 begin. (
7860: 70 72 69 6e 74 20 74 6f 74 61 6c 2d 72 75 6e 73 print total-runs
7870: 29 20 20 20 20 0a 20 20 20 20 20 20 20 20 28 6c ) . (l
7880: 65 74 20 6c 6f 6f 70 20 28 28 70 61 67 65 20 30 et loop ((page 0
7890: 29 29 0a 09 28 6c 65 74 2a 20 28 28 6f 75 70 20 ))..(let* ((oup
78a0: 20 20 20 20 20 20 28 6f 70 65 6e 2d 6f 75 74 70 (open-outp
78b0: 75 74 2d 66 69 6c 65 20 28 6f 72 20 6f 75 74 66 ut-file (or outf
78c0: 20 28 63 6f 6e 63 20 6c 69 6e 6b 74 72 65 65 20 (conc linktree
78d0: 22 2f 70 61 67 65 22 20 70 61 67 65 20 22 2e 68 "/page" page ".h
78e0: 74 6d 6c 22 29 29 29 29 0a 20 20 20 20 20 20 20 tml")))).
78f0: 20 20 20 20 20 20 20 20 28 73 74 61 72 74 20 28 (start (
7900: 2a 20 70 61 67 65 20 70 67 2d 73 69 7a 65 29 29 * page pg-size))
7910: 20 0a 09 20 20 20 20 20 20 20 28 72 75 6e 73 64 .. (runsd
7920: 61 74 20 20 20 28 72 6d 74 3a 67 65 74 2d 72 75 at (rmt:get-ru
7930: 6e 73 20 22 25 22 20 70 67 2d 73 69 7a 65 20 73 ns "%" pg-size s
7940: 74 61 72 74 20 28 6d 61 70 20 28 6c 61 6d 62 64 tart (map (lambd
7950: 61 20 28 78 29 28 6c 69 73 74 20 78 20 22 25 22 a (x)(list x "%"
7960: 29 29 20 6b 65 79 73 29 29 29 0a 09 20 20 20 20 )) keys)))..
7970: 20 20 20 28 68 65 61 64 65 72 20 20 20 20 28 76 (header (v
7980: 65 63 74 6f 72 2d 72 65 66 20 72 75 6e 73 64 61 ector-ref runsda
7990: 74 20 30 29 29 0a 09 20 20 20 20 20 20 20 28 72 t 0)).. (r
79a0: 75 6e 73 20 20 20 20 20 20 28 76 65 63 74 6f 72 uns (vector
79b0: 2d 72 65 66 20 72 75 6e 73 64 61 74 20 31 29 29 -ref runsdat 1))
79c0: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
79d0: 28 63 74 72 20 30 29 0a 20 20 20 20 20 20 20 20 (ctr 0).
79e0: 20 20 20 20 20 20 20 28 74 65 73 74 2d 72 75 6e (test-run
79f0: 73 2d 68 61 73 68 20 28 74 65 73 74 73 3a 67 65 s-hash (tests:ge
7a00: 74 2d 72 65 73 74 2d 64 61 74 61 20 72 75 6e 73 t-rest-data runs
7a10: 20 68 65 61 64 65 72 20 6e 75 6d 6b 65 79 73 29 header numkeys)
7a20: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
7a30: 20 28 74 65 73 74 2d 6c 69 73 74 20 28 68 61 73 (test-list (has
7a40: 68 2d 74 61 62 6c 65 2d 6b 65 79 73 20 74 65 73 h-table-keys tes
7a50: 74 2d 72 75 6e 73 2d 68 61 73 68 29 29 0a 20 20 t-runs-hash)).
7a60: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 67 65 (ge
7a70: 74 2d 70 72 65 76 2d 6c 69 6e 6b 73 20 28 6c 61 t-prev-links (la
7a80: 6d 62 64 61 20 28 70 61 67 65 20 6c 69 6e 6b 74 mbda (page linkt
7a90: 72 65 65 20 29 20 20 20 0a 20 20 20 20 20 20 20 ree ) .
7aa0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7ab0: 20 20 20 20 20 28 6c 65 74 2a 20 28 28 6c 69 6e (let* ((lin
7ac0: 6b 20 20 28 69 66 20 28 6e 6f 74 20 28 65 71 3f k (if (not (eq?
7ad0: 20 70 61 67 65 20 30 29 29 0a 20 20 20 20 20 20 page 0)).
7ae0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7af0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7b00: 20 20 20 20 20 20 28 73 3a 61 20 22 26 6c 74 3b (s:a "<
7b10: 26 6c 74 3b 70 72 65 76 22 20 27 68 72 65 66 20 <prev" 'href
7b20: 28 63 6f 6e 63 20 20 6c 69 6e 6b 74 72 65 65 20 (conc linktree
7b30: 22 2f 70 61 67 65 22 20 28 2d 20 70 61 67 65 20 "/page" (- page
7b40: 31 29 20 22 2e 68 74 6d 6c 22 29 29 0a 20 20 20 1) ".html")).
7b50: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7b60: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7b70: 20 20 20 20 20 20 20 20 20 28 73 3a 61 20 22 22 (s:a ""
7b80: 20 27 68 72 65 66 20 28 63 6f 6e 63 20 20 6c 69 'href (conc li
7b90: 6e 6b 74 72 65 65 20 22 2f 70 61 67 65 22 20 20 nktree "/page"
7ba0: 70 61 67 65 20 22 2e 68 74 6d 6c 22 29 29 29 29 page ".html"))))
7bb0: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
7bc0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7bd0: 20 6c 69 6e 6b 29 29 29 0a 20 20 20 20 20 20 20 link))).
7be0: 20 20 20 20 20 20 20 20 20 28 67 65 74 2d 6e 65 (get-ne
7bf0: 78 74 2d 6c 69 6e 6b 73 20 28 6c 61 6d 62 64 61 xt-links (lambda
7c00: 20 28 70 61 67 65 20 6c 69 6e 6b 74 72 65 65 20 (page linktree
7c10: 74 6f 74 61 6c 2d 72 75 6e 73 29 20 20 20 0a 20 total-runs) .
7c20: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7c30: 20 20 20 20 20 20 20 20 20 20 20 28 6c 65 74 2a (let*
7c40: 20 28 28 6c 69 6e 6b 20 20 28 69 66 20 28 3e 20 ((link (if (>
7c50: 74 6f 74 61 6c 2d 72 75 6e 73 20 28 2b 20 31 20 total-runs (+ 1
7c60: 28 2a 20 70 61 67 65 20 70 67 2d 73 69 7a 65 29 (* page pg-size)
7c70: 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 )).
7c80: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7c90: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
7ca0: 73 3a 61 20 22 6e 65 78 74 26 67 74 3b 26 67 74 s:a "next>>
7cb0: 3b 22 20 27 68 72 65 66 20 28 63 6f 6e 63 20 20 ;" 'href (conc
7cc0: 6c 69 6e 6b 74 72 65 65 20 22 2f 70 61 67 65 22 linktree "/page"
7cd0: 20 20 28 2b 20 70 61 67 65 20 31 29 20 22 2e 68 (+ page 1) ".h
7ce0: 74 6d 6c 22 29 29 0a 20 20 20 20 20 20 20 20 20 tml")).
7cf0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7d00: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7d10: 20 20 20 20 28 73 3a 61 20 22 22 20 27 68 72 65 (s:a "" 'hre
7d20: 66 20 28 63 6f 6e 63 20 20 6c 69 6e 6b 74 72 65 f (conc linktre
7d30: 65 20 22 2f 70 61 67 65 22 20 70 61 67 65 20 20 e "/page" page
7d40: 22 2e 68 74 6d 6c 22 29 29 29 29 29 0a 20 20 20 ".html"))))).
7d50: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7d60: 20 20 20 20 20 20 20 20 20 20 20 20 6c 69 6e 6b link
7d70: 29 29 29 29 0a 09 20 20 28 73 3a 6f 75 74 70 75 )))).. (s:outpu
7d80: 74 2d 6e 65 77 0a 09 20 20 20 6f 75 70 0a 09 20 t-new.. oup..
7d90: 20 20 28 73 3a 68 74 6d 6c 20 74 65 73 74 73 3a (s:html tests:
7da0: 63 73 73 2d 6a 73 63 72 69 70 74 2d 62 6c 6f 63 css-jscript-bloc
7db0: 6b 0a 09 09 20 20 20 28 73 3a 74 69 74 6c 65 20 k... (s:title
7dc0: 22 53 75 6d 6d 61 72 79 20 66 6f 72 20 22 20 61 "Summary for " a
7dd0: 72 65 61 2d 6e 61 6d 65 29 0a 09 09 20 20 20 28 rea-name)... (
7de0: 73 3a 62 6f 64 79 20 27 6f 6e 6c 6f 61 64 20 22 s:body 'onload "
7df0: 61 64 64 45 76 65 6e 74 73 28 29 3b 22 0a 20 20 addEvents();".
7e00: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7e10: 20 20 20 20 20 20 20 20 28 67 65 74 2d 70 72 65 (get-pre
7e20: 76 2d 6c 69 6e 6b 73 20 70 61 67 65 20 6c 69 6e v-links page lin
7e30: 6b 74 72 65 65 29 0a 20 20 20 20 20 20 20 20 20 ktree).
7e40: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7e50: 20 28 67 65 74 2d 6e 65 78 74 2d 6c 69 6e 6b 73 (get-next-links
7e60: 20 70 61 67 65 20 6c 69 6e 6b 74 72 65 65 20 74 page linktree t
7e70: 6f 74 61 6c 2d 72 75 6e 73 29 0a 20 20 20 20 20 otal-runs).
7e80: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7e90: 20 20 20 20 20 20 0a 09 09 09 20 20 20 28 73 3a .... (s:
7ea0: 68 31 20 22 53 75 6d 6d 61 72 79 20 66 6f 72 20 h1 "Summary for
7eb0: 22 20 61 72 65 61 2d 6e 61 6d 65 29 0a 20 20 20 " area-name).
7ec0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7ed0: 20 20 20 20 20 20 20 20 28 73 3a 68 33 20 22 46 (s:h3 "F
7ee0: 69 6c 74 65 72 22 20 29 0a 20 20 20 20 20 20 20 ilter" ).
7ef0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7f00: 20 20 20 20 28 73 3a 69 6e 70 75 74 20 27 74 79 (s:input 'ty
7f10: 70 65 20 22 74 65 78 74 22 20 20 27 6e 61 6d 65 pe "text" 'name
7f20: 20 22 74 65 73 74 6e 61 6d 65 22 20 27 69 64 20 "testname" 'id
7f30: 22 74 65 73 74 6e 61 6d 65 22 20 27 6c 65 6e 67 "testname" 'leng
7f40: 74 68 20 22 33 30 22 20 27 6f 6e 6b 65 79 75 70 th "30" 'onkeyup
7f50: 20 22 66 69 6c 74 65 72 73 6f 6d 65 28 29 22 29 "filtersome()")
7f60: 0a 20 20 0a 09 09 09 20 20 20 3b 3b 20 74 6f 70 . .... ;; top
7f70: 20 6c 69 73 74 0a 09 09 09 20 20 20 28 73 3a 74 list.... (s:t
7f80: 61 62 6c 65 20 27 69 64 20 22 4c 69 6e 6b 65 64 able 'id "Linked
7f90: 4c 69 73 74 31 22 20 27 62 6f 72 64 65 72 20 22 List1" 'border "
7fa0: 31 22 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 1".
7fb0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
7fc0: 6d 61 70 20 28 6c 61 6d 62 64 61 20 28 6b 65 79 map (lambda (key
7fd0: 29 0a 09 09 09 09 20 28 6c 65 74 2a 20 28 28 72 )..... (let* ((r
7fe0: 65 73 20 28 73 3a 74 72 20 27 63 6c 61 73 73 20 es (s:tr 'class
7ff0: 22 73 6f 6d 65 74 68 69 6e 67 22 20 0a 09 09 09 "something" ....
8000: 09 20 20 28 73 3a 74 68 20 6b 65 79 20 29 0a 20 . (s:th key ).
8010: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8020: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8030: 20 20 28 6d 61 70 20 28 6c 61 6d 62 64 61 20 28 (map (lambda (
8040: 72 75 6e 29 0a 20 20 20 20 20 20 20 20 20 20 20 run).
8050: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8060: 20 20 20 20 20 20 20 20 28 73 3a 74 68 20 20 28 (s:th (
8070: 76 65 63 74 6f 72 2d 72 65 66 20 72 75 6e 20 63 vector-ref run c
8080: 74 72 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 tr))).
8090: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
80a0: 20 20 20 20 20 20 20 20 72 75 6e 73 29 29 29 29 runs))))
80b0: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
80c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 73 (s
80d0: 65 74 21 20 63 74 72 20 28 2b 20 63 74 72 20 31 et! ctr (+ ctr 1
80e0: 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 )).
80f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8100: 20 20 72 65 73 29 29 0a 20 20 20 20 20 20 20 20 res)).
8110: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8120: 20 20 20 20 20 20 20 6b 65 79 73 29 0a 20 20 20 keys).
8130: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8140: 20 20 20 20 20 20 20 20 20 20 20 20 28 73 3a 74 (s:t
8150: 72 0a 09 09 09 09 20 28 73 3a 74 68 20 22 52 75 r..... (s:th "Ru
8160: 6e 20 4e 61 6d 65 22 29 0a 20 20 20 20 20 20 20 n Name").
8170: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8180: 20 20 20 20 20 20 20 20 20 20 20 28 6d 61 70 20 (map
8190: 28 6c 61 6d 62 64 61 20 28 72 75 6e 29 0a 20 20 (lambda (run).
81a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
81b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
81c0: 20 28 73 3a 74 68 20 20 28 76 65 63 74 6f 72 2d (s:th (vector-
81d0: 72 65 66 20 72 75 6e 20 33 29 29 29 0a 20 20 20 ref run 3))).
81e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
81f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 72 r
8200: 75 6e 73 29 29 0a 20 20 20 20 20 20 20 20 20 20 uns)).
8210: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8220: 20 20 20 20 0a 20 20 20 20 20 20 20 20 20 20 20 .
8230: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8240: 20 20 20 20 28 6d 61 70 20 28 6c 61 6d 62 64 61 (map (lambda
8250: 20 28 74 65 73 74 2d 6e 61 6d 65 29 0a 20 20 20 (test-name).
8260: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8270: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 6c (l
8280: 65 74 2a 20 28 28 69 74 65 6d 2d 68 61 73 68 20 et* ((item-hash
8290: 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f (hash-table-ref/
82a0: 64 65 66 61 75 6c 74 20 74 65 73 74 2d 72 75 6e default test-run
82b0: 73 2d 68 61 73 68 20 74 65 73 74 2d 6e 61 6d 65 s-hash test-name
82c0: 20 20 23 66 29 29 0a 20 20 20 20 20 20 20 20 20 #f)).
82d0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
82e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
82f0: 28 69 74 65 6d 2d 6b 65 79 73 20 28 73 6f 72 74 (item-keys (sort
8300: 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 6b 65 79 (hash-table-key
8310: 73 20 69 74 65 6d 2d 68 61 73 68 29 20 73 74 72 s item-hash) str
8320: 69 6e 67 3c 3d 3f 29 29 29 20 0a 20 20 20 20 20 ing<=?))) .
8330: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8340: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8350: 20 20 20 20 20 28 6d 61 70 20 28 6c 61 6d 62 64 (map (lambd
8360: 61 20 28 69 74 65 6d 2d 6e 61 6d 65 29 20 20 0a a (item-name) .
8370: 20 20 09 09 20 20 20 20 20 20 20 20 20 20 20 20 ..
8380: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8390: 20 28 6c 65 74 2a 20 28 28 72 65 73 20 28 73 3a (let* ((res (s:
83a0: 74 72 20 20 27 63 6c 61 73 73 20 69 74 65 6d 2d tr 'class item-
83b0: 6e 61 6d 65 0a 09 09 09 09 20 20 20 20 20 20 20 name.....
83c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
83d0: 20 20 28 73 3a 74 64 20 20 69 74 65 6d 2d 6e 61 (s:td item-na
83e0: 6d 65 20 27 63 6c 61 73 73 20 22 74 65 73 74 22 me 'class "test"
83f0: 20 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
8400: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8410: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8420: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 6d (m
8430: 61 70 20 28 6c 61 6d 62 64 61 20 28 72 75 6e 29 ap (lambda (run)
8440: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
8450: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8460: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8470: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8480: 28 6c 65 74 2a 20 28 28 72 75 6e 2d 74 65 73 74 (let* ((run-test
8490: 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 (hash-table-ref
84a0: 2f 64 65 66 61 75 6c 74 20 69 74 65 6d 2d 68 61 /default item-ha
84b0: 73 68 20 69 74 65 6d 2d 6e 61 6d 65 20 20 23 66 sh item-name #f
84c0: 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 )).
84d0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
84e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
84f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8500: 20 20 20 20 20 20 20 20 20 28 72 75 6e 2d 69 64 (run-id
8510: 20 28 64 62 3a 67 65 74 2d 76 61 6c 75 65 2d 62 (db:get-value-b
8520: 79 2d 68 65 61 64 65 72 20 72 75 6e 20 68 65 61 y-header run hea
8530: 64 65 72 20 22 69 64 22 29 29 0a 20 20 20 20 20 der "id")).
8540: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8550: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8560: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8570: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8580: 20 28 72 65 73 75 6c 74 20 28 68 61 73 68 2d 74 (result (hash-t
8590: 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 able-ref/default
85a0: 20 72 75 6e 2d 74 65 73 74 20 72 75 6e 2d 69 64 run-test run-id
85b0: 20 22 6e 2f 61 22 29 29 0a 20 20 20 20 20 20 20 "n/a")).
85c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
85d0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
85e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
85f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
8600: 73 74 61 74 75 73 20 28 69 66 20 28 73 74 72 69 status (if (stri
8610: 6e 67 3f 20 72 65 73 75 6c 74 29 0a 20 20 20 20 ng? result).
8620: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8630: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8640: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8650: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8660: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 62 65 (be
8670: 67 69 6e 20 0a 20 20 20 20 20 20 20 20 20 20 20 gin .
8680: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8690: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
86a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
86b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
86c0: 20 20 20 20 20 20 20 3b 20 28 70 72 69 6e 74 20 ; (print
86d0: 22 73 74 72 69 6e 67 22 20 72 65 73 75 6c 74 29 "string" result)
86e0: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
86f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8700: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8710: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8720: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8730: 20 20 20 20 20 20 72 65 73 75 6c 74 29 0a 20 20 result).
8740: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8750: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8760: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8770: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8780: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
8790: 62 65 67 69 6e 20 0a 20 20 20 20 20 20 20 20 20 begin .
87a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
87b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
87c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
87d0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
87e0: 20 20 20 20 20 20 20 20 20 20 3b 20 20 28 70 72 ; (pr
87f0: 69 6e 74 20 22 6e 6f 74 20 73 74 72 69 6e 67 22 int "not string"
8800: 20 72 65 73 75 6c 74 20 29 0a 20 20 20 20 20 20 result ).
8810: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8820: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8830: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8840: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8850: 20 20 20 20 20 20 20 20 20 20 20 28 63 61 72 20 (car
8860: 72 65 73 75 6c 74 29 29 29 29 29 0a 20 20 20 20 result))))).
8870: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8880: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8890: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
88a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
88b0: 20 20 20 28 73 3a 74 64 20 20 73 74 61 74 75 73 (s:td status
88c0: 20 27 63 6c 61 73 73 20 73 74 61 74 75 73 29 29 'class status))
88d0: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
88e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
88f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8900: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8910: 20 20 72 75 6e 73 29 29 29 29 0a 20 20 20 20 20 runs)))).
8920: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8930: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8940: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8950: 20 20 20 72 65 73 29 29 0a 20 20 20 20 20 20 20 res)).
8960: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8970: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8980: 20 20 20 20 20 20 20 20 20 20 20 20 69 74 65 6d item
8990: 2d 6b 65 79 73 29 29 29 0a 20 20 20 20 20 20 20 -keys))).
89a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
89b0: 20 20 20 20 20 20 20 20 74 65 73 74 2d 6c 69 73 test-lis
89c0: 74 29 29 29 29 29 0a 20 20 20 20 20 20 20 20 20 t))))).
89d0: 20 28 63 6c 6f 73 65 2d 6f 75 74 70 75 74 2d 70 (close-output-p
89e0: 6f 72 74 20 6f 75 70 29 0a 20 20 20 20 20 20 20 ort oup).
89f0: 20 20 3b 20 28 73 65 74 21 20 70 61 67 65 20 28 ; (set! page (
8a00: 2b 20 31 20 70 61 67 65 29 29 0a 20 20 20 20 20 + 1 page)).
8a10: 20 20 20 20 20 28 69 66 20 28 3e 20 74 6f 74 61 (if (> tota
8a20: 6c 2d 72 75 6e 73 20 28 2a 20 28 2b 20 31 20 70 l-runs (* (+ 1 p
8a30: 61 67 65 29 20 70 67 2d 73 69 7a 65 29 29 0a 20 age) pg-size)).
8a40: 20 20 20 20 20 20 20 20 20 20 28 6c 6f 6f 70 20 (loop
8a50: 28 2b 20 31 20 20 70 61 67 65 29 29 29 29 29 0a (+ 1 page))))).
8a60: 09 20 20 28 63 6f 6d 6d 6f 6e 3a 73 69 6d 70 6c . (common:simpl
8a70: 65 2d 66 69 6c 65 2d 72 65 6c 65 61 73 65 2d 6c e-file-release-l
8a80: 6f 63 6b 20 6c 6f 63 6b 66 69 6c 65 29 29 0a 09 ock lockfile))..
8a90: 20 20 20 20 20 20 20 20 20 20 20 20 0a 09 23 66 ..#f
8aa0: 29 29 29 0a 0a 0a 0a 0a 0a 0a 28 64 65 66 69 6e ))).......(defin
8ab0: 65 20 28 74 65 73 74 73 3a 63 72 65 61 74 65 2d e (tests:create-
8ac0: 68 74 6d 6c 2d 74 72 65 65 2d 6f 6c 64 20 6f 75 html-tree-old ou
8ad0: 74 66 29 0a 20 20 20 28 6c 65 74 2a 20 28 28 6c tf). (let* ((l
8ae0: 6f 63 6b 66 69 6c 65 20 20 28 63 6f 6e 63 20 6f ockfile (conc o
8af0: 75 74 66 20 22 2e 6c 6f 63 6b 22 29 29 0a 09 20 utf ".lock"))..
8b00: 28 72 75 6e 73 2d 74 6f 2d 70 72 6f 63 65 73 73 (runs-to-process
8b10: 20 27 28 29 29 29 0a 20 20 20 20 28 69 66 20 28 '())). (if (
8b20: 63 6f 6d 6d 6f 6e 3a 73 69 6d 70 6c 65 2d 66 69 common:simple-fi
8b30: 6c 65 2d 6c 6f 63 6b 20 6c 6f 63 6b 66 69 6c 65 le-lock lockfile
8b40: 29 0a 09 28 6c 65 74 2a 20 28 28 6c 69 6e 6b 74 )..(let* ((linkt
8b50: 72 65 65 20 20 28 63 6f 6d 6d 6f 6e 3a 67 65 74 ree (common:get
8b60: 2d 6c 69 6e 6b 74 72 65 65 29 29 0a 09 20 20 20 -linktree))..
8b70: 20 20 20 20 28 6f 75 70 20 20 20 20 20 20 20 28 (oup (
8b80: 6f 70 65 6e 2d 6f 75 74 70 75 74 2d 66 69 6c 65 open-output-file
8b90: 20 28 6f 72 20 6f 75 74 66 20 28 63 6f 6e 63 20 (or outf (conc
8ba0: 6c 69 6e 6b 74 72 65 65 20 22 2f 72 75 6e 73 2d linktree "/runs-
8bb0: 69 6e 64 65 78 2e 68 74 6d 6c 22 29 29 29 29 0a index.html")))).
8bc0: 09 20 20 20 20 20 20 20 28 61 72 65 61 2d 6e 61 . (area-na
8bd0: 6d 65 20 28 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 74 me (common:get-t
8be0: 65 73 74 73 75 69 74 65 2d 6e 61 6d 65 29 29 0a estsuite-name)).
8bf0: 09 20 20 20 20 20 20 20 28 6b 65 79 73 20 20 20 . (keys
8c00: 20 20 20 28 72 6d 74 3a 67 65 74 2d 6b 65 79 73 (rmt:get-keys
8c10: 29 29 0a 09 20 20 20 20 20 20 20 28 6e 75 6d 6b )).. (numk
8c20: 65 79 73 20 20 20 28 6c 65 6e 67 74 68 20 6b 65 eys (length ke
8c30: 79 73 29 29 0a 09 20 20 20 20 20 20 20 28 72 75 ys)).. (ru
8c40: 6e 73 64 61 74 20 20 20 28 72 6d 74 3a 67 65 74 nsdat (rmt:get
8c50: 2d 72 75 6e 73 20 22 25 22 20 23 66 20 23 66 20 -runs "%" #f #f
8c60: 28 6d 61 70 20 28 6c 61 6d 62 64 61 20 28 78 29 (map (lambda (x)
8c70: 28 6c 69 73 74 20 78 20 22 25 22 29 29 20 6b 65 (list x "%")) ke
8c80: 79 73 29 29 29 0a 09 20 20 20 20 20 20 20 28 68 ys))).. (h
8c90: 65 61 64 65 72 20 20 20 20 28 76 65 63 74 6f 72 eader (vector
8ca0: 2d 72 65 66 20 72 75 6e 73 64 61 74 20 30 29 29 -ref runsdat 0))
8cb0: 0a 09 20 20 20 20 20 20 20 28 72 75 6e 73 20 20 .. (runs
8cc0: 20 20 20 20 28 76 65 63 74 6f 72 2d 72 65 66 20 (vector-ref
8cd0: 72 75 6e 73 64 61 74 20 31 29 29 0a 09 20 20 20 runsdat 1))..
8ce0: 20 20 20 20 28 72 75 6e 74 72 65 65 64 61 74 20 (runtreedat
8cf0: 28 6d 61 70 20 28 6c 61 6d 62 64 61 20 28 78 29 (map (lambda (x)
8d00: 0a 09 09 09 09 20 20 28 74 65 73 74 73 3a 72 75 ..... (tests:ru
8d10: 6e 2d 72 65 63 6f 72 64 2d 3e 74 65 73 74 2d 70 n-record->test-p
8d20: 61 74 68 20 78 20 6e 75 6d 6b 65 79 73 29 29 0a ath x numkeys)).
8d30: 09 09 09 09 72 75 6e 73 29 29 0a 09 20 20 20 20 ....runs))..
8d40: 20 20 20 28 72 75 6e 73 2d 68 74 72 65 65 20 28 (runs-htree (
8d50: 63 6f 6d 6d 6f 6e 3a 6c 69 73 74 2d 3e 68 74 72 common:list->htr
8d60: 65 65 20 72 75 6e 74 72 65 65 64 61 74 29 29 29 ee runtreedat)))
8d70: 0a 09 20 20 28 73 65 74 21 20 72 75 6e 73 2d 74 .. (set! runs-t
8d80: 6f 2d 70 72 6f 63 65 73 73 20 72 75 6e 73 29 0a o-process runs).
8d90: 09 20 20 28 73 3a 6f 75 74 70 75 74 2d 6e 65 77 . (s:output-new
8da0: 0a 09 20 20 20 6f 75 70 0a 09 20 20 20 28 73 3a .. oup.. (s:
8db0: 68 74 6d 6c 20 74 65 73 74 73 3a 63 73 73 2d 6a html tests:css-j
8dc0: 73 63 72 69 70 74 2d 62 6c 6f 63 6b 0a 09 09 20 script-block...
8dd0: 20 20 28 73 3a 74 69 74 6c 65 20 22 53 75 6d 6d (s:title "Summ
8de0: 61 72 79 20 66 6f 72 20 22 20 61 72 65 61 2d 6e ary for " area-n
8df0: 61 6d 65 29 0a 09 09 20 20 20 28 73 3a 62 6f 64 ame)... (s:bod
8e00: 79 20 27 6f 6e 6c 6f 61 64 20 22 61 64 64 45 76 y 'onload "addEv
8e10: 65 6e 74 73 28 29 3b 22 0a 09 09 09 20 20 20 28 ents();".... (
8e20: 73 3a 68 31 20 22 53 75 6d 6d 61 72 79 20 66 6f s:h1 "Summary fo
8e30: 72 20 22 20 61 72 65 61 2d 6e 61 6d 65 29 0a 09 r " area-name)..
8e40: 09 09 20 20 20 3b 3b 20 74 6f 70 20 6c 69 73 74 .. ;; top list
8e50: 0a 09 09 09 20 20 20 28 73 3a 75 6c 20 27 69 64 .... (s:ul 'id
8e60: 20 22 4c 69 6e 6b 65 64 4c 69 73 74 31 22 20 27 "LinkedList1" '
8e70: 63 6c 61 73 73 20 22 4c 69 6e 6b 65 64 4c 69 73 class "LinkedLis
8e80: 74 22 0a 09 09 09 09 20 28 73 3a 6c 69 0a 09 09 t"..... (s:li...
8e90: 09 09 20 20 22 52 75 6e 73 22 0a 09 09 09 09 20 .. "Runs".....
8ea0: 20 28 63 6f 6d 6d 6f 6e 3a 68 74 72 65 65 2d 3e (common:htree->
8eb0: 68 74 6d 6c 20 72 75 6e 73 2d 68 74 72 65 65 0a html runs-htree.
8ec0: 09 09 09 09 09 09 20 20 20 20 20 20 27 28 29 0a ...... '().
8ed0: 09 09 09 09 09 09 20 20 20 20 20 20 28 6c 61 6d ...... (lam
8ee0: 62 64 61 20 28 78 20 70 29 0a 09 09 09 09 09 09 bda (x p).......
8ef0: 09 28 6c 65 74 2a 20 28 28 74 61 72 67 2d 70 61 .(let* ((targ-pa
8f00: 74 68 20 28 73 74 72 69 6e 67 2d 69 6e 74 65 72 th (string-inter
8f10: 73 70 65 72 73 65 20 70 20 22 2f 22 29 29 0a 20 sperse p "/")).
8f20: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8f30: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8f40: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8f50: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 66 (f
8f60: 75 6c 6c 2d 70 61 74 68 20 28 63 6f 6e 63 20 6c ull-path (conc l
8f70: 69 6e 6b 74 72 65 65 20 22 2f 22 20 74 61 72 67 inktree "/" targ
8f80: 2d 70 61 74 68 29 29 0a 20 20 20 20 20 20 20 20 -path)).
8f90: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8fa0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8fb0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8fc0: 20 20 20 20 20 20 20 28 72 75 6e 2d 6e 61 6d 65 (run-name
8fd0: 20 20 28 63 61 72 20 28 72 65 76 65 72 73 65 20 (car (reverse
8fe0: 70 29 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 p)))).
8ff0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9000: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9010: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9020: 28 69 66 20 28 61 6e 64 20 28 63 6f 6d 6d 6f 6e (if (and (common
9030: 3a 66 69 6c 65 2d 65 78 69 73 74 73 3f 20 66 75 :file-exists? fu
9040: 6c 6c 2d 70 61 74 68 29 0a 20 20 20 20 20 20 20 ll-path).
9050: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9060: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9070: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9080: 20 20 20 20 20 20 20 20 20 20 20 20 28 64 69 72 (dir
9090: 65 63 74 6f 72 79 3f 20 20 20 66 75 6c 6c 2d 70 ectory? full-p
90a0: 61 74 68 29 0a 20 20 20 20 20 20 20 20 20 20 20 ath).
90b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
90c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
90d0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
90e0: 20 20 20 20 20 20 20 20 28 66 69 6c 65 2d 77 72 (file-wr
90f0: 69 74 65 2d 61 63 63 65 73 73 3f 20 66 75 6c 6c ite-access? full
9100: 2d 70 61 74 68 29 29 0a 20 20 20 20 20 20 20 20 -path)).
9110: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9120: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9130: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9140: 20 20 20 20 20 20 28 73 3a 61 20 72 75 6e 2d 6e (s:a run-n
9150: 61 6d 65 20 27 68 72 65 66 20 28 63 6f 6e 63 20 ame 'href (conc
9160: 74 61 72 67 2d 70 61 74 68 20 22 2f 72 75 6e 2d targ-path "/run-
9170: 73 75 6d 6d 61 72 79 2e 68 74 6d 6c 22 29 29 0a summary.html")).
9180: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9190: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
91a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
91b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 62 (b
91c0: 65 67 69 6e 0a 20 20 20 20 20 20 20 20 20 20 20 egin.
91d0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
91e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
91f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9200: 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e (debug:prin
9210: 74 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 t 0 *default-log
9220: 2d 70 6f 72 74 2a 20 22 49 4e 46 4f 3a 20 43 61 -port* "INFO: Ca
9230: 6e 27 74 20 63 72 65 61 74 65 20 22 20 74 61 72 n't create " tar
9240: 67 2d 70 61 74 68 20 22 2f 72 75 6e 2d 73 75 6d g-path "/run-sum
9250: 6d 61 72 79 2e 68 74 6d 6c 22 29 0a 20 20 20 20 mary.html").
9260: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9270: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9280: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9290: 20 20 20 20 20 20 20 20 20 20 20 20 28 63 6f 6e (con
92a0: 63 20 72 75 6e 2d 6e 61 6d 65 20 22 20 28 4e 6f c run-name " (No
92b0: 74 20 61 62 6c 65 20 74 6f 20 63 72 65 61 74 65 t able to create
92c0: 20 73 75 6d 6d 61 72 79 20 61 74 20 22 20 74 61 summary at " ta
92d0: 72 67 2d 70 61 74 68 20 22 29 22 29 29 29 29 29 rg-path ")")))))
92e0: 29 29 29 29 29 29 0a 20 20 20 20 20 20 20 20 20 )))))).
92f0: 20 28 63 6c 6f 73 65 2d 6f 75 74 70 75 74 2d 70 (close-output-p
9300: 6f 72 74 20 6f 75 70 29 0a 09 20 20 28 63 6f 6d ort oup).. (com
9310: 6d 6f 6e 3a 73 69 6d 70 6c 65 2d 66 69 6c 65 2d mon:simple-file-
9320: 72 65 6c 65 61 73 65 2d 6c 6f 63 6b 20 6c 6f 63 release-lock loc
9330: 6b 66 69 6c 65 29 0a 20 20 20 20 20 20 20 20 20 kfile).
9340: 20 20 20 20 20 20 0a 09 20 20 28 66 6f 72 2d 65 .. (for-e
9350: 61 63 68 0a 09 20 20 20 28 6c 61 6d 62 64 61 20 ach.. (lambda
9360: 28 72 75 6e 29 0a 09 20 20 20 20 20 28 6c 65 74 (run).. (let
9370: 2a 20 28 28 74 65 73 74 2d 73 75 62 70 61 74 68 * ((test-subpath
9380: 20 28 74 65 73 74 73 3a 72 75 6e 2d 72 65 63 6f (tests:run-reco
9390: 72 64 2d 3e 74 65 73 74 2d 70 61 74 68 20 72 75 rd->test-path ru
93a0: 6e 20 6e 75 6d 6b 65 79 73 29 29 0a 09 09 20 20 n numkeys))...
93b0: 20 20 28 72 75 6e 2d 69 64 20 20 20 20 20 20 20 (run-id
93c0: 28 64 62 3a 67 65 74 2d 76 61 6c 75 65 2d 62 79 (db:get-value-by
93d0: 2d 68 65 61 64 65 72 20 72 75 6e 20 68 65 61 64 -header run head
93e0: 65 72 20 22 69 64 22 29 29 0a 20 20 20 20 20 20 er "id")).
93f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 72 (r
9400: 75 6e 2d 64 69 72 20 20 20 20 20 20 28 74 65 73 un-dir (tes
9410: 74 73 3a 72 75 6e 2d 72 65 63 6f 72 64 2d 3e 74 ts:run-record->t
9420: 65 73 74 2d 70 61 74 68 20 72 75 6e 20 6e 75 6d est-path run num
9430: 6b 65 79 73 29 29 0a 09 09 20 20 20 20 28 74 65 keys))... (te
9440: 73 74 2d 64 61 74 73 20 20 20 20 28 72 6d 74 3a st-dats (rmt:
9450: 67 65 74 2d 74 65 73 74 73 2d 66 6f 72 2d 72 75 get-tests-for-ru
9460: 6e 0a 09 09 09 09 20 20 20 72 75 6e 2d 69 64 0a n..... run-id.
9470: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9480: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9490: 20 20 20 22 25 2f 22 20 20 20 20 20 20 20 3b 3b "%/" ;;
94a0: 20 74 65 73 74 6e 61 6d 65 70 61 74 74 0a 09 09 testnamepatt...
94b0: 09 09 20 20 20 27 28 29 20 20 20 20 20 20 20 20 .. '()
94c0: 3b 3b 20 73 74 61 74 65 73 0a 09 09 09 09 20 20 ;; states.....
94d0: 20 27 28 29 20 20 20 20 20 20 20 20 3b 3b 20 73 '() ;; s
94e0: 74 61 74 75 73 65 73 0a 09 09 09 09 20 20 20 23 tatuses..... #
94f0: 66 20 20 20 20 20 20 20 20 20 3b 3b 20 6f 66 66 f ;; off
9500: 73 65 74 0a 09 09 09 09 20 20 20 23 66 20 20 20 set..... #f
9510: 20 20 20 20 20 20 3b 3b 20 6e 75 6d 2d 74 6f 2d ;; num-to-
9520: 67 65 74 0a 09 09 09 09 20 20 20 23 66 20 20 20 get..... #f
9530: 20 20 20 20 20 20 3b 3b 20 68 69 64 65 2f 6e 6f ;; hide/no
9540: 74 2d 68 69 64 65 0a 09 09 09 09 20 20 20 23 66 t-hide..... #f
9550: 20 20 20 20 20 20 20 20 20 3b 3b 20 73 6f 72 74 ;; sort
9560: 2d 62 79 0a 09 09 09 09 20 20 20 23 66 20 20 20 -by..... #f
9570: 20 20 20 20 20 20 3b 3b 20 73 6f 72 74 2d 6f 72 ;; sort-or
9580: 64 65 72 0a 09 09 09 09 20 20 20 23 66 20 20 20 der..... #f
9590: 20 20 20 20 20 20 3b 3b 20 27 73 68 6f 72 74 6c ;; 'shortl
95a0: 69 73 74 20 20 20 20 20 20 20 20 20 20 20 20 20 ist
95b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 3b 3b ;;
95c0: 20 71 72 79 74 79 70 65 0a 20 20 20 20 20 20 20 qrytype.
95d0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
95e0: 20 20 20 20 20 20 20 20 20 20 20 20 30 20 20 20 0
95f0: 20 20 20 20 20 20 3b 3b 20 6c 61 73 74 20 75 70 ;; last up
9600: 64 61 74 65 0a 09 09 09 09 20 20 20 23 66 29 29 date..... #f))
9610: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
9620: 20 20 20 20 20 28 74 65 73 74 73 2d 74 72 65 65 (tests-tree
9630: 2d 64 61 74 20 28 6d 61 70 20 28 6c 61 6d 62 64 -dat (map (lambd
9640: 61 20 28 74 65 73 74 2d 64 61 74 29 0a 20 20 20 a (test-dat).
9650: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9660: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9670: 20 20 20 20 20 20 3b 3b 20 28 74 65 73 74 73 3a ;; (tests:
9680: 72 75 6e 2d 72 65 63 6f 72 64 2d 3e 74 65 73 74 run-record->test
9690: 2d 70 61 74 68 20 78 20 6e 75 6d 6b 65 79 73 29 -path x numkeys)
96a0: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
96b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
96c0: 20 20 20 20 20 20 20 20 20 20 20 28 6c 65 74 2a (let*
96d0: 20 28 28 74 65 73 74 2d 6e 61 6d 65 20 20 28 64 ((test-name (d
96e0: 62 3a 74 65 73 74 2d 67 65 74 2d 74 65 73 74 6e b:test-get-testn
96f0: 61 6d 65 20 74 65 73 74 2d 64 61 74 29 29 0a 20 ame test-dat)).
9700: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9710: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9720: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
9730: 69 74 65 6d 2d 70 61 74 68 20 20 28 64 62 3a 74 item-path (db:t
9740: 65 73 74 2d 67 65 74 2d 69 74 65 6d 2d 70 61 74 est-get-item-pat
9750: 68 20 74 65 73 74 2d 64 61 74 29 29 0a 20 20 20 h test-dat)).
9760: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9770: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9780: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 66 75 (fu
9790: 6c 6c 2d 6e 61 6d 65 20 20 28 64 62 3a 74 65 73 ll-name (db:tes
97a0: 74 2d 6d 61 6b 65 2d 66 75 6c 6c 2d 6e 61 6d 65 t-make-full-name
97b0: 20 74 65 73 74 2d 6e 61 6d 65 20 69 74 65 6d 2d test-name item-
97c0: 70 61 74 68 29 29 0a 20 20 20 20 20 20 20 20 20 path)).
97d0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
97e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
97f0: 20 20 20 20 20 20 20 28 70 61 74 68 2d 70 61 72 (path-par
9800: 74 73 20 28 73 74 72 69 6e 67 2d 73 70 6c 69 74 ts (string-split
9810: 20 66 75 6c 6c 2d 6e 61 6d 65 29 29 29 0a 20 20 full-name))).
9820: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9830: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9840: 20 20 20 20 20 20 20 20 20 70 61 74 68 2d 70 61 path-pa
9850: 72 74 73 29 29 0a 20 20 20 20 20 20 20 20 20 20 rts)).
9860: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9870: 20 20 20 20 20 20 20 20 20 20 20 20 20 74 65 73 tes
9880: 74 2d 64 61 74 73 29 29 0a 20 20 20 20 20 20 20 t-dats)).
9890: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 74 65 (te
98a0: 73 74 73 2d 68 74 72 65 65 20 28 63 6f 6d 6d 6f sts-htree (commo
98b0: 6e 3a 6c 69 73 74 2d 3e 68 74 72 65 65 20 74 65 n:list->htree te
98c0: 73 74 73 2d 74 72 65 65 2d 64 61 74 29 29 0a 20 sts-tree-dat)).
98d0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
98e0: 20 20 20 28 68 74 6d 6c 2d 64 69 72 20 20 20 20 (html-dir
98f0: 28 63 6f 6e 63 20 6c 69 6e 6b 74 72 65 65 20 22 (conc linktree "
9900: 2f 22 20 28 73 74 72 69 6e 67 2d 69 6e 74 65 72 /" (string-inter
9910: 73 70 65 72 73 65 20 72 75 6e 2d 64 69 72 20 22 sperse run-dir "
9920: 2f 22 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 /"))).
9930: 20 20 20 20 20 20 20 20 20 20 28 68 74 6d 6c 2d (html-
9940: 70 61 74 68 20 20 20 28 63 6f 6e 63 20 68 74 6d path (conc htm
9950: 6c 2d 64 69 72 20 22 2f 72 75 6e 2d 73 75 6d 6d l-dir "/run-summ
9960: 61 72 79 2e 68 74 6d 6c 22 29 29 0a 20 20 20 20 ary.html")).
9970: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9980: 28 6f 75 70 20 20 20 20 20 20 20 20 20 28 69 66 (oup (if
9990: 20 28 61 6e 64 20 28 63 6f 6d 6d 6f 6e 3a 66 69 (and (common:fi
99a0: 6c 65 2d 65 78 69 73 74 73 3f 20 68 74 6d 6c 2d le-exists? html-
99b0: 64 69 72 29 0a 20 20 20 20 20 20 20 20 20 20 20 dir).
99c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
99d0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
99e0: 64 69 72 65 63 74 6f 72 79 3f 20 20 20 68 74 6d directory? htm
99f0: 6c 2d 64 69 72 29 0a 20 20 20 20 20 20 20 20 20 l-dir).
9a00: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9a10: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9a20: 20 28 66 69 6c 65 2d 77 72 69 74 65 2d 61 63 63 (file-write-acc
9a30: 65 73 73 3f 20 68 74 6d 6c 2d 64 69 72 29 29 0a ess? html-dir)).
9a40: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9a50: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9a60: 20 20 20 20 20 28 6f 70 65 6e 2d 6f 75 74 70 75 (open-outpu
9a70: 74 2d 66 69 6c 65 20 20 68 74 6d 6c 2d 70 61 74 t-file html-pat
9a80: 68 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 h).
9a90: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9aa0: 20 20 20 20 20 20 20 20 23 66 29 29 29 0a 20 20 #f))).
9ab0: 20 20 20 20 20 20 20 20 20 20 20 20 20 3b 3b 20 ;;
9ac0: 28 70 72 69 6e 74 20 22 72 75 6e 2d 64 69 72 3a (print "run-dir:
9ad0: 20 22 20 72 75 6e 2d 64 69 72 20 22 2c 20 74 65 " run-dir ", te
9ae0: 73 74 73 2d 74 72 65 65 2d 64 61 74 3a 20 22 20 sts-tree-dat: "
9af0: 74 65 73 74 73 2d 74 72 65 65 2d 64 61 74 29 0a tests-tree-dat).
9b00: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
9b10: 69 66 20 6f 75 70 0a 20 20 20 20 20 20 20 20 20 if oup.
9b20: 20 20 20 20 20 20 20 20 20 20 28 62 65 67 69 6e (begin
9b30: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
9b40: 20 20 20 20 20 20 28 73 3a 6f 75 74 70 75 74 2d (s:output-
9b50: 6e 65 77 0a 20 20 20 20 20 20 20 20 20 20 20 20 new.
9b60: 20 20 20 20 20 20 20 20 20 20 6f 75 70 0a 20 20 oup.
9b70: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9b80: 20 20 20 20 28 73 3a 68 74 6d 6c 20 74 65 73 74 (s:html test
9b90: 73 3a 63 73 73 2d 6a 73 63 72 69 70 74 2d 62 6c s:css-jscript-bl
9ba0: 6f 63 6b 0a 20 20 20 20 20 20 20 20 20 20 20 20 ock.
9bb0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9bc0: 20 20 28 73 3a 74 69 74 6c 65 20 22 53 75 6d 6d (s:title "Summ
9bd0: 61 72 79 20 66 6f 72 20 22 20 61 72 65 61 2d 6e ary for " area-n
9be0: 61 6d 65 29 0a 20 20 20 20 20 20 20 20 20 20 20 ame).
9bf0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9c00: 20 20 20 28 73 3a 62 6f 64 79 20 27 6f 6e 6c 6f (s:body 'onlo
9c10: 61 64 20 22 61 64 64 45 76 65 6e 74 73 28 29 3b ad "addEvents();
9c20: 22 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ".
9c30: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9c40: 20 20 20 20 20 20 20 20 28 73 3a 68 31 20 22 53 (s:h1 "S
9c50: 75 6d 6d 61 72 79 20 66 6f 72 20 22 20 28 73 74 ummary for " (st
9c60: 72 69 6e 67 2d 69 6e 74 65 72 73 70 65 72 73 65 ring-intersperse
9c70: 20 72 75 6e 2d 64 69 72 20 22 2f 22 29 29 0a 20 run-dir "/")).
9c80: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9c90: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9ca0: 20 20 20 20 20 3b 3b 20 74 6f 70 20 6c 69 73 74 ;; top list
9cb0: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
9cc0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9cd0: 20 20 20 20 20 20 20 28 73 3a 75 6c 20 27 69 64 (s:ul 'id
9ce0: 20 22 4c 69 6e 6b 65 64 4c 69 73 74 31 22 20 27 "LinkedList1" '
9cf0: 63 6c 61 73 73 20 22 4c 69 6e 6b 65 64 4c 69 73 class "LinkedLis
9d00: 74 22 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 t".
9d10: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9d20: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
9d30: 73 3a 6c 69 0a 20 20 20 20 20 20 20 20 20 20 20 s:li.
9d40: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9d50: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9d60: 20 20 22 54 65 73 74 73 22 0a 20 20 20 20 20 20 "Tests".
9d70: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9d80: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9d90: 20 20 20 20 20 20 20 28 63 6f 6d 6d 6f 6e 3a 68 (common:h
9da0: 74 72 65 65 2d 3e 68 74 6d 6c 20 74 65 73 74 73 tree->html tests
9db0: 2d 68 74 72 65 65 0a 20 20 20 20 20 20 20 20 20 -htree.
9dc0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9dd0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9de0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9df0: 20 20 20 20 20 20 20 20 27 28 29 0a 20 20 20 20 '().
9e00: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9e10: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9e20: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9e30: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 6c 61 (la
9e40: 6d 62 64 61 20 28 78 20 70 29 0a 20 20 20 20 20 mbda (x p).
9e50: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9e60: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9e70: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9e80: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 6c (l
9e90: 65 74 2a 20 28 28 74 61 72 67 2d 70 61 74 68 20 et* ((targ-path
9ea0: 28 73 74 72 69 6e 67 2d 69 6e 74 65 72 73 70 65 (string-interspe
9eb0: 72 73 65 20 70 20 22 2f 22 29 29 0a 20 20 20 20 rse p "/")).
9ec0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9ed0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9ee0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9ef0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9f00: 20 20 20 20 20 20 28 74 65 73 74 2d 6e 61 6d 65 (test-name
9f10: 20 28 63 61 72 20 70 29 29 0a 20 20 20 20 20 20 (car p)).
9f20: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9f30: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9f40: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9f50: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9f60: 20 20 20 20 28 69 74 65 6d 2d 70 61 74 68 20 3b (item-path ;
9f70: 3b 20 28 69 66 20 28 3e 20 28 6c 65 6e 67 74 68 ; (if (> (length
9f80: 20 70 29 20 32 29 20 3b 3b 20 74 65 73 74 2d 6e p) 2) ;; test-n
9f90: 61 6d 65 20 2b 20 72 75 6e 2d 6e 61 6d 65 0a 20 ame + run-name.
9fa0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9fb0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9fc0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9fd0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9fe0: 20 20 20 20 20 20 20 20 20 20 28 73 74 72 69 6e (strin
9ff0: 67 2d 69 6e 74 65 72 73 70 65 72 73 65 20 70 20 g-intersperse p
a000: 22 2f 22 29 29 0a 20 20 20 20 20 20 20 20 20 20 "/")).
a010: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
a020: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
a030: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
a040: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
a050: 28 66 75 6c 6c 2d 74 61 72 67 20 28 63 6f 6e 63 (full-targ (conc
a060: 20 68 74 6d 6c 2d 64 69 72 20 22 2f 22 20 74 61 html-dir "/" ta
a070: 72 67 2d 70 61 74 68 29 29 0a 20 20 20 20 20 20 rg-path)).
a080: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
a090: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
a0a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
a0b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
a0c0: 20 20 20 20 28 73 74 64 2d 66 69 6c 65 20 20 28 (std-file (
a0d0: 63 6f 6e 63 20 66 75 6c 6c 2d 74 61 72 67 20 22 conc full-targ "
a0e0: 2f 74 65 73 74 2d 73 75 6d 6d 61 72 79 2e 68 74 /test-summary.ht
a0f0: 6d 6c 22 29 29 0a 20 20 20 20 20 20 20 20 20 20 ml")).
a100: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
a110: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
a120: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
a130: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
a140: 28 61 6c 74 2d 66 69 6c 65 20 20 28 63 6f 6e 63 (alt-file (conc
a150: 20 66 75 6c 6c 2d 74 61 72 67 20 22 2f 6d 65 67 full-targ "/meg
a160: 61 74 65 73 74 2d 72 6f 6c 6c 75 70 2d 22 20 74 atest-rollup-" t
a170: 65 73 74 2d 6e 61 6d 65 20 22 2e 68 74 6d 6c 22 est-name ".html"
a180: 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 )).
a190: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
a1a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
a1b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
a1c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 68 74 (ht
a1d0: 6d 6c 2d 66 69 6c 65 20 28 69 66 20 28 63 6f 6d ml-file (if (com
a1e0: 6d 6f 6e 3a 66 69 6c 65 2d 65 78 69 73 74 73 3f mon:file-exists?
a1f0: 20 61 6c 74 2d 66 69 6c 65 29 0a 20 20 20 20 20 alt-file).
a200: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
a210: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
a220: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
a230: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
a240: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
a250: 20 20 20 20 61 6c 74 2d 66 69 6c 65 0a 20 20 20 alt-file.
a260: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
a270: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
a280: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
a290: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
a2a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
a2b0: 20 20 20 20 20 20 73 74 64 2d 66 69 6c 65 29 29 std-file))
a2c0: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
a2d0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
a2e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
a2f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
a300: 20 20 20 20 20 20 20 20 20 20 20 28 72 75 6e 2d (run-
a310: 6e 61 6d 65 20 20 28 63 61 72 20 28 72 65 76 65 name (car (reve
a320: 72 73 65 20 70 29 29 29 29 0a 20 20 20 20 20 20 rse p)))).
a330: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
a340: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
a350: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
a360: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
a370: 69 66 20 28 61 6e 64 20 28 6e 6f 74 20 28 63 6f if (and (not (co
a380: 6d 6d 6f 6e 3a 66 69 6c 65 2d 65 78 69 73 74 73 mmon:file-exists
a390: 3f 20 66 75 6c 6c 2d 74 61 72 67 29 29 0a 20 20 ? full-targ)).
a3a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
a3b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
a3c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
a3d0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
a3e0: 20 20 20 20 20 20 20 20 20 20 20 20 28 64 69 72 (dir
a3f0: 65 63 74 6f 72 79 3f 20 66 75 6c 6c 2d 74 61 72 ectory? full-tar
a400: 67 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 g).
a410: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
a420: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
a430: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
a440: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
a450: 20 28 66 69 6c 65 2d 77 72 69 74 65 2d 61 63 63 (file-write-acc
a460: 65 73 73 3f 20 66 75 6c 6c 2d 74 61 72 67 29 29 ess? full-targ))
a470: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
a480: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
a490: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
a4a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
a4b0: 20 20 20 20 20 20 20 20 20 20 28 74 65 73 74 73 (tests
a4c0: 3a 73 75 6d 6d 61 72 69 7a 65 2d 74 65 73 74 20 :summarize-test
a4d0: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
a4e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
a4f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
a500: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
a510: 20 20 20 20 20 20 20 20 20 20 20 72 75 6e 2d 69 run-i
a520: 64 20 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 d .
a530: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
a540: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
a550: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
a560: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 72 6d (rm
a570: 74 3a 67 65 74 2d 74 65 73 74 2d 69 64 20 72 75 t:get-test-id ru
a580: 6e 2d 69 64 20 74 65 73 74 2d 6e 61 6d 65 20 69 n-id test-name i
a590: 74 65 6d 2d 70 61 74 68 29 29 29 0a 20 20 20 20 tem-path))).
a5a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
a5b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
a5c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
a5d0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
a5e0: 20 28 69 66 20 28 63 6f 6d 6d 6f 6e 3a 66 69 6c (if (common:fil
a5f0: 65 2d 65 78 69 73 74 73 3f 20 66 75 6c 6c 2d 74 e-exists? full-t
a600: 61 72 67 29 0a 20 20 20 20 20 20 20 20 20 20 20 arg).
a610: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
a620: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
a630: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
a640: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 73 (s
a650: 3a 61 20 72 75 6e 2d 6e 61 6d 65 20 27 68 72 65 :a run-name 'hre
a660: 66 20 68 74 6d 6c 2d 66 69 6c 65 29 0a 20 20 20 f html-file).
a670: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
a680: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
a690: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
a6a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
a6b0: 20 20 20 20 20 20 28 62 65 67 69 6e 0a 20 20 20 (begin.
a6c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
a6d0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
a6e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
a6f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
a700: 20 20 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 (debug:p
a710: 72 69 6e 74 20 30 20 2a 64 65 66 61 75 6c 74 2d rint 0 *default-
a720: 6c 6f 67 2d 70 6f 72 74 2a 20 22 45 52 52 4f 52 log-port* "ERROR
a730: 3a 20 63 61 6e 27 74 20 61 63 63 65 73 73 20 22 : can't access "
a740: 20 66 75 6c 6c 2d 74 61 72 67 29 0a 20 20 20 20 full-targ).
a750: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
a760: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
a770: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
a780: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
a790: 20 20 20 20 20 20 20 28 63 6f 6e 63 20 22 4e 6f (conc "No
a7a0: 20 73 75 6d 6d 61 72 79 20 66 6f 72 20 22 20 72 summary for " r
a7b0: 75 6e 2d 6e 61 6d 65 29 29 29 29 29 0a 20 20 20 un-name))))).
a7c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
a7d0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
a7e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
a7f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 29 29 ))
a800: 29 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 )))).
a810: 20 20 20 20 20 20 20 20 20 20 28 63 6c 6f 73 65 (close
a820: 2d 6f 75 74 70 75 74 2d 70 6f 72 74 20 6f 75 70 -output-port oup
a830: 29 29 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 ))))).
a840: 20 72 75 6e 73 29 0a 20 20 20 20 20 20 20 20 20 runs).
a850: 20 23 74 29 0a 09 23 66 29 29 29 0a 0a 0a 0a 0a #t)..#f))).....
a860: 0a 0a 0a 3b 3b 20 43 48 45 43 4b 20 2d 20 57 41 ...;; CHECK - WA
a870: 53 20 54 48 49 53 20 41 44 44 45 44 20 4f 52 20 S THIS ADDED OR
a880: 52 45 4d 4f 56 45 44 3f 20 4d 41 4e 55 41 4c 20 REMOVED? MANUAL
a890: 4d 45 52 47 45 20 57 49 54 48 20 41 50 49 20 53 MERGE WITH API S
a8a0: 54 55 46 46 21 21 21 0a 3b 3b 0a 3b 3b 20 67 65 TUFF!!!.;;.;; ge
a8b0: 74 20 61 20 70 72 65 74 74 79 20 74 61 62 6c 65 t a pretty table
a8c0: 20 74 6f 20 73 75 6d 6d 61 72 69 7a 65 20 73 74 to summarize st
a8d0: 65 70 73 0a 3b 3b 0a 3b 3b 20 28 64 65 66 69 6e eps.;;.;; (defin
a8e0: 65 20 28 64 63 6f 6d 6d 6f 6e 3a 70 72 6f 63 65 e (dcommon:proce
a8f0: 73 73 2d 73 74 65 70 73 2d 74 61 62 6c 65 20 73 ss-steps-table s
a900: 74 65 70 73 29 3b 3b 20 64 62 20 74 65 73 74 2d teps);; db test-
a910: 69 64 20 23 21 6b 65 79 20 28 77 6f 72 6b 2d 61 id #!key (work-a
a920: 72 65 61 20 23 66 29 29 0a 28 64 65 66 69 6e 65 rea #f)).(define
a930: 20 28 74 65 73 74 73 3a 70 72 6f 63 65 73 73 2d (tests:process-
a940: 73 74 65 70 73 2d 74 61 62 6c 65 20 73 74 65 70 steps-table step
a950: 73 29 3b 3b 20 64 62 20 74 65 73 74 2d 69 64 20 s);; db test-id
a960: 23 21 6b 65 79 20 28 77 6f 72 6b 2d 61 72 65 61 #!key (work-area
a970: 20 23 66 29 29 0a 3b 3b 20 20 28 6c 65 74 20 28 #f)).;; (let (
a980: 28 73 74 65 70 73 20 20 20 28 64 62 3a 67 65 74 (steps (db:get
a990: 2d 73 74 65 70 73 2d 66 6f 72 2d 74 65 73 74 20 -steps-for-test
a9a0: 64 62 20 74 65 73 74 2d 69 64 20 77 6f 72 6b 2d db test-id work-
a9b0: 61 72 65 61 3a 20 77 6f 72 6b 2d 61 72 65 61 29 area: work-area)
a9c0: 29 29 0a 20 20 20 20 3b 3b 20 6f 72 67 61 6e 69 )). ;; organi
a9d0: 73 65 20 74 68 65 20 73 74 65 70 73 20 66 6f 72 se the steps for
a9e0: 20 62 65 74 74 65 72 20 72 65 61 64 61 62 69 6c better readabil
a9f0: 69 74 79 0a 20 20 20 20 28 6c 65 74 20 28 28 72 ity. (let ((r
aa00: 65 73 20 28 6d 61 6b 65 2d 68 61 73 68 2d 74 61 es (make-hash-ta
aa10: 62 6c 65 29 29 29 0a 20 20 20 20 20 20 28 66 6f ble))). (fo
aa20: 72 2d 65 61 63 68 20 0a 20 20 20 20 20 20 20 28 r-each . (
aa30: 6c 61 6d 62 64 61 20 28 73 74 65 70 29 0a 09 20 lambda (step)..
aa40: 28 64 65 62 75 67 3a 70 72 69 6e 74 20 36 20 2a (debug:print 6 *
aa50: 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 default-log-port
aa60: 2a 20 22 73 74 65 70 3d 22 20 73 74 65 70 29 0a * "step=" step).
aa70: 09 20 28 6c 65 74 20 28 28 72 65 63 6f 72 64 20 . (let ((record
aa80: 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f (hash-table-ref/
aa90: 64 65 66 61 75 6c 74 20 0a 09 09 09 72 65 73 20 default ....res
aaa0: 0a 09 09 09 28 74 64 62 3a 73 74 65 70 2d 67 65 ....(tdb:step-ge
aab0: 74 2d 73 74 65 70 6e 61 6d 65 20 73 74 65 70 29 t-stepname step)
aac0: 0a 09 09 09 3b 3b 20 20 20 20 20 20 20 20 20 20 ....;;
aad0: 20 30 20 20 20 20 20 20 20 20 20 20 20 20 20 20 0
aae0: 20 20 20 20 20 20 20 20 31 20 20 20 20 32 20 20 1 2
aaf0: 20 20 33 20 20 20 20 20 20 20 34 20 20 20 20 20 3 4
ab00: 20 20 20 20 35 20 20 20 20 20 20 20 36 20 20 20 5 6
ab10: 20 20 20 20 37 0a 09 09 09 3b 3b 20 20 20 20 20 7....;;
ab20: 20 20 20 73 74 65 70 6e 61 6d 65 20 20 20 20 20 stepname
ab30: 20 20 20 20 20 20 20 20 20 20 20 73 74 61 72 74 start
ab40: 20 65 6e 64 20 73 74 61 74 75 73 20 44 75 72 61 end status Dura
ab50: 74 69 6f 6e 20 20 4c 6f 67 66 69 6c 65 20 43 6f tion Logfile Co
ab60: 6d 6d 65 6e 74 20 20 66 69 72 73 74 2d 69 64 0a mment first-id.
ab70: 09 09 09 28 76 65 63 74 6f 72 20 28 74 64 62 3a ...(vector (tdb:
ab80: 73 74 65 70 2d 67 65 74 2d 73 74 65 70 6e 61 6d step-get-stepnam
ab90: 65 20 73 74 65 70 29 20 22 22 20 20 20 22 22 20 e step) "" ""
aba0: 22 22 20 20 20 20 20 22 22 20 20 20 20 20 20 20 "" ""
abb0: 20 22 22 20 20 20 20 20 22 22 20 20 20 20 20 20 "" ""
abc0: 20 23 66 29 29 29 29 0a 09 20 20 20 28 64 65 62 #f)))).. (deb
abd0: 75 67 3a 70 72 69 6e 74 20 36 20 2a 64 65 66 61 ug:print 6 *defa
abe0: 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 72 ult-log-port* "r
abf0: 65 63 6f 72 64 28 62 65 66 6f 72 65 29 20 3d 20 ecord(before) =
ac00: 22 20 72 65 63 6f 72 64 20 0a 09 09 09 22 5c 6e " record ...."\n
ac10: 69 64 3a 20 20 20 20 20 20 20 22 20 28 74 64 62 id: " (tdb
ac20: 3a 73 74 65 70 2d 67 65 74 2d 69 64 20 73 74 65 :step-get-id ste
ac30: 70 29 0a 09 09 09 22 5c 6e 73 74 65 70 6e 61 6d p)...."\nstepnam
ac40: 65 3a 20 22 20 28 74 64 62 3a 73 74 65 70 2d 67 e: " (tdb:step-g
ac50: 65 74 2d 73 74 65 70 6e 61 6d 65 20 73 74 65 70 et-stepname step
ac60: 29 0a 09 09 09 22 5c 6e 73 74 61 74 65 3a 20 20 )...."\nstate:
ac70: 20 20 22 20 28 74 64 62 3a 73 74 65 70 2d 67 65 " (tdb:step-ge
ac80: 74 2d 73 74 61 74 65 20 73 74 65 70 29 0a 09 09 t-state step)...
ac90: 09 22 5c 6e 73 74 61 74 75 73 3a 20 20 20 22 20 ."\nstatus: "
aca0: 28 74 64 62 3a 73 74 65 70 2d 67 65 74 2d 73 74 (tdb:step-get-st
acb0: 61 74 75 73 20 73 74 65 70 29 0a 09 09 09 22 5c atus step)...."\
acc0: 6e 74 69 6d 65 3a 20 20 20 20 20 22 20 28 74 64 ntime: " (td
acd0: 62 3a 73 74 65 70 2d 67 65 74 2d 65 76 65 6e 74 b:step-get-event
ace0: 5f 74 69 6d 65 20 73 74 65 70 29 29 0a 09 20 20 _time step))..
acf0: 20 28 69 66 20 28 6e 6f 74 20 28 76 65 63 74 6f (if (not (vecto
ad00: 72 2d 72 65 66 20 72 65 63 6f 72 64 20 37 29 29 r-ref record 7))
ad10: 28 76 65 63 74 6f 72 2d 73 65 74 21 20 72 65 63 (vector-set! rec
ad20: 6f 72 64 20 37 20 28 74 64 62 3a 73 74 65 70 2d ord 7 (tdb:step-
ad30: 67 65 74 2d 69 64 20 73 74 65 70 29 29 29 20 3b get-id step))) ;
ad40: 3b 20 64 6f 20 6e 6f 74 20 63 6c 6f 62 62 65 72 ; do not clobber
ad50: 20 74 68 65 20 69 64 20 69 66 20 70 72 65 76 69 the id if previ
ad60: 6f 75 73 6c 79 20 73 65 74 0a 09 20 20 20 28 63 ously set.. (c
ad70: 61 73 65 20 28 73 74 72 69 6e 67 2d 3e 73 79 6d ase (string->sym
ad80: 62 6f 6c 20 28 74 64 62 3a 73 74 65 70 2d 67 65 bol (tdb:step-ge
ad90: 74 2d 73 74 61 74 65 20 73 74 65 70 29 29 0a 09 t-state step))..
ada0: 20 20 20 20 20 28 28 73 74 61 72 74 29 28 76 65 ((start)(ve
adb0: 63 74 6f 72 2d 73 65 74 21 20 72 65 63 6f 72 64 ctor-set! record
adc0: 20 31 20 28 74 64 62 3a 73 74 65 70 2d 67 65 74 1 (tdb:step-get
add0: 2d 65 76 65 6e 74 5f 74 69 6d 65 20 73 74 65 70 -event_time step
ade0: 29 29 0a 09 20 20 20 20 20 20 28 76 65 63 74 6f )).. (vecto
adf0: 72 2d 73 65 74 21 20 72 65 63 6f 72 64 20 33 20 r-set! record 3
ae00: 28 69 66 20 28 65 71 75 61 6c 3f 20 28 76 65 63 (if (equal? (vec
ae10: 74 6f 72 2d 72 65 66 20 72 65 63 6f 72 64 20 33 tor-ref record 3
ae20: 29 20 22 22 29 0a 09 09 09 09 09 28 74 64 62 3a ) "")......(tdb:
ae30: 73 74 65 70 2d 67 65 74 2d 73 74 61 74 75 73 20 step-get-status
ae40: 73 74 65 70 29 29 29 0a 09 20 20 20 20 20 20 28 step))).. (
ae50: 69 66 20 28 3e 20 28 73 74 72 69 6e 67 2d 6c 65 if (> (string-le
ae60: 6e 67 74 68 20 28 74 64 62 3a 73 74 65 70 2d 67 ngth (tdb:step-g
ae70: 65 74 2d 6c 6f 67 66 69 6c 65 20 73 74 65 70 29 et-logfile step)
ae80: 29 0a 09 09 20 20 20 20 20 30 29 0a 09 09 20 20 )... 0)...
ae90: 28 76 65 63 74 6f 72 2d 73 65 74 21 20 72 65 63 (vector-set! rec
aea0: 6f 72 64 20 35 20 28 74 64 62 3a 73 74 65 70 2d ord 5 (tdb:step-
aeb0: 67 65 74 2d 6c 6f 67 66 69 6c 65 20 73 74 65 70 get-logfile step
aec0: 29 29 29 29 0a 09 20 20 20 20 20 28 28 65 6e 64 )))).. ((end
aed0: 29 20 20 0a 09 20 20 20 20 20 20 28 76 65 63 74 ) .. (vect
aee0: 6f 72 2d 73 65 74 21 20 72 65 63 6f 72 64 20 32 or-set! record 2
aef0: 20 28 61 6e 79 2d 3e 6e 75 6d 62 65 72 20 28 74 (any->number (t
af00: 64 62 3a 73 74 65 70 2d 67 65 74 2d 65 76 65 6e db:step-get-even
af10: 74 5f 74 69 6d 65 20 73 74 65 70 29 29 29 0a 09 t_time step)))..
af20: 20 20 20 20 20 20 28 76 65 63 74 6f 72 2d 73 65 (vector-se
af30: 74 21 20 72 65 63 6f 72 64 20 33 20 28 74 64 62 t! record 3 (tdb
af40: 3a 73 74 65 70 2d 67 65 74 2d 73 74 61 74 75 73 :step-get-status
af50: 20 73 74 65 70 29 29 0a 09 20 20 20 20 20 20 28 step)).. (
af60: 76 65 63 74 6f 72 2d 73 65 74 21 20 72 65 63 6f vector-set! reco
af70: 72 64 20 34 20 28 6c 65 74 20 28 28 73 74 61 72 rd 4 (let ((star
af80: 74 74 20 28 61 6e 79 2d 3e 6e 75 6d 62 65 72 20 tt (any->number
af90: 28 76 65 63 74 6f 72 2d 72 65 66 20 72 65 63 6f (vector-ref reco
afa0: 72 64 20 31 29 29 29 0a 09 09 09 09 09 20 20 28 rd 1)))...... (
afb0: 65 6e 64 74 20 20 20 28 61 6e 79 2d 3e 6e 75 6d endt (any->num
afc0: 62 65 72 20 28 76 65 63 74 6f 72 2d 72 65 66 20 ber (vector-ref
afd0: 72 65 63 6f 72 64 20 32 29 29 29 29 0a 09 09 09 record 2))))....
afe0: 09 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 . (debug:pr
aff0: 69 6e 74 20 34 20 2a 64 65 66 61 75 6c 74 2d 6c int 4 *default-l
b000: 6f 67 2d 70 6f 72 74 2a 20 22 72 65 63 6f 72 64 og-port* "record
b010: 5b 31 5d 3d 22 20 28 76 65 63 74 6f 72 2d 72 65 [1]=" (vector-re
b020: 66 20 72 65 63 6f 72 64 20 31 29 20 0a 09 09 09 f record 1) ....
b030: 09 09 09 20 20 20 22 2c 20 73 74 61 72 74 74 3d ... ", startt=
b040: 22 20 73 74 61 72 74 74 20 22 2c 20 65 6e 64 74 " startt ", endt
b050: 3d 22 20 65 6e 64 74 0a 09 09 09 09 09 09 20 20 =" endt.......
b060: 20 22 2c 20 67 65 74 2d 73 74 61 74 75 73 3a 20 ", get-status:
b070: 22 20 28 74 64 62 3a 73 74 65 70 2d 67 65 74 2d " (tdb:step-get-
b080: 73 74 61 74 75 73 20 73 74 65 70 29 29 0a 09 09 status step))...
b090: 09 09 20 20 20 20 20 20 28 69 66 20 28 61 6e 64 .. (if (and
b0a0: 20 28 6e 75 6d 62 65 72 3f 20 73 74 61 72 74 74 (number? startt
b0b0: 29 28 6e 75 6d 62 65 72 3f 20 65 6e 64 74 29 29 )(number? endt))
b0c0: 0a 09 09 09 09 09 20 20 28 73 65 63 6f 6e 64 73 ...... (seconds
b0d0: 2d 3e 68 72 2d 6d 69 6e 2d 73 65 63 20 28 2d 20 ->hr-min-sec (-
b0e0: 65 6e 64 74 20 73 74 61 72 74 74 29 29 20 22 2d endt startt)) "-
b0f0: 31 22 29 29 29 0a 09 20 20 20 20 20 20 28 69 66 1"))).. (if
b100: 20 28 3e 20 28 73 74 72 69 6e 67 2d 6c 65 6e 67 (> (string-leng
b110: 74 68 20 28 74 64 62 3a 73 74 65 70 2d 67 65 74 th (tdb:step-get
b120: 2d 6c 6f 67 66 69 6c 65 20 73 74 65 70 29 29 0a -logfile step)).
b130: 09 09 20 20 20 20 20 30 29 0a 09 09 20 20 28 76 .. 0)... (v
b140: 65 63 74 6f 72 2d 73 65 74 21 20 72 65 63 6f 72 ector-set! recor
b150: 64 20 35 20 28 74 64 62 3a 73 74 65 70 2d 67 65 d 5 (tdb:step-ge
b160: 74 2d 6c 6f 67 66 69 6c 65 20 73 74 65 70 29 29 t-logfile step))
b170: 29 0a 09 20 20 20 20 20 20 28 69 66 20 28 3e 20 ).. (if (>
b180: 28 73 74 72 69 6e 67 2d 6c 65 6e 67 74 68 20 28 (string-length (
b190: 74 64 62 3a 73 74 65 70 2d 67 65 74 2d 63 6f 6d tdb:step-get-com
b1a0: 6d 65 6e 74 20 73 74 65 70 29 29 0a 09 09 20 20 ment step))...
b1b0: 20 20 20 30 29 0a 09 09 20 20 28 76 65 63 74 6f 0)... (vecto
b1c0: 72 2d 73 65 74 21 20 72 65 63 6f 72 64 20 36 20 r-set! record 6
b1d0: 28 74 64 62 3a 73 74 65 70 2d 67 65 74 2d 63 6f (tdb:step-get-co
b1e0: 6d 6d 65 6e 74 20 73 74 65 70 29 29 29 29 0a 09 mment step))))..
b1f0: 20 20 20 20 20 28 65 6c 73 65 0a 09 20 20 20 20 (else..
b200: 20 20 28 76 65 63 74 6f 72 2d 73 65 74 21 20 72 (vector-set! r
b210: 65 63 6f 72 64 20 32 20 28 74 64 62 3a 73 74 65 ecord 2 (tdb:ste
b220: 70 2d 67 65 74 2d 73 74 61 74 65 20 73 74 65 70 p-get-state step
b230: 29 29 0a 09 20 20 20 20 20 20 28 76 65 63 74 6f )).. (vecto
b240: 72 2d 73 65 74 21 20 72 65 63 6f 72 64 20 33 20 r-set! record 3
b250: 28 74 64 62 3a 73 74 65 70 2d 67 65 74 2d 73 74 (tdb:step-get-st
b260: 61 74 75 73 20 73 74 65 70 29 29 0a 09 20 20 20 atus step))..
b270: 20 20 20 28 76 65 63 74 6f 72 2d 73 65 74 21 20 (vector-set!
b280: 72 65 63 6f 72 64 20 34 20 28 74 64 62 3a 73 74 record 4 (tdb:st
b290: 65 70 2d 67 65 74 2d 65 76 65 6e 74 5f 74 69 6d ep-get-event_tim
b2a0: 65 20 73 74 65 70 29 29 0a 09 20 20 20 20 20 20 e step))..
b2b0: 28 76 65 63 74 6f 72 2d 73 65 74 21 20 72 65 63 (vector-set! rec
b2c0: 6f 72 64 20 36 20 28 74 64 62 3a 73 74 65 70 2d ord 6 (tdb:step-
b2d0: 67 65 74 2d 63 6f 6d 6d 65 6e 74 20 73 74 65 70 get-comment step
b2e0: 29 29 29 29 0a 09 20 20 20 28 68 61 73 68 2d 74 )))).. (hash-t
b2f0: 61 62 6c 65 2d 73 65 74 21 20 72 65 73 20 28 74 able-set! res (t
b300: 64 62 3a 73 74 65 70 2d 67 65 74 2d 73 74 65 70 db:step-get-step
b310: 6e 61 6d 65 20 73 74 65 70 29 20 72 65 63 6f 72 name step) recor
b320: 64 29 0a 09 20 20 20 28 64 65 62 75 67 3a 70 72 d).. (debug:pr
b330: 69 6e 74 20 36 20 2a 64 65 66 61 75 6c 74 2d 6c int 6 *default-l
b340: 6f 67 2d 70 6f 72 74 2a 20 22 72 65 63 6f 72 64 og-port* "record
b350: 28 61 66 74 65 72 29 20 20 3d 20 22 20 72 65 63 (after) = " rec
b360: 6f 72 64 20 0a 09 09 09 22 5c 6e 69 64 3a 20 20 ord ...."\nid:
b370: 20 20 20 20 20 22 20 28 74 64 62 3a 73 74 65 70 " (tdb:step
b380: 2d 67 65 74 2d 69 64 20 73 74 65 70 29 0a 09 09 -get-id step)...
b390: 09 22 5c 6e 73 74 65 70 6e 61 6d 65 3a 20 22 20 ."\nstepname: "
b3a0: 28 74 64 62 3a 73 74 65 70 2d 67 65 74 2d 73 74 (tdb:step-get-st
b3b0: 65 70 6e 61 6d 65 20 73 74 65 70 29 0a 09 09 09 epname step)....
b3c0: 22 5c 6e 73 74 61 74 65 3a 20 20 20 20 22 20 28 "\nstate: " (
b3d0: 74 64 62 3a 73 74 65 70 2d 67 65 74 2d 73 74 61 tdb:step-get-sta
b3e0: 74 65 20 73 74 65 70 29 0a 09 09 09 22 5c 6e 73 te step)...."\ns
b3f0: 74 61 74 75 73 3a 20 20 20 22 20 28 74 64 62 3a tatus: " (tdb:
b400: 73 74 65 70 2d 67 65 74 2d 73 74 61 74 75 73 20 step-get-status
b410: 73 74 65 70 29 0a 09 09 09 22 5c 6e 74 69 6d 65 step)...."\ntime
b420: 3a 20 20 20 20 20 22 20 28 74 64 62 3a 73 74 65 : " (tdb:ste
b430: 70 2d 67 65 74 2d 65 76 65 6e 74 5f 74 69 6d 65 p-get-event_time
b440: 20 73 74 65 70 29 29 29 29 0a 20 20 20 20 20 20 step)))).
b450: 20 3b 3b 20 28 65 6c 73 65 20 20 20 28 76 65 63 ;; (else (vec
b460: 74 6f 72 2d 73 65 74 21 20 72 65 63 6f 72 64 20 tor-set! record
b470: 31 20 28 74 64 62 3a 73 74 65 70 2d 67 65 74 2d 1 (tdb:step-get-
b480: 65 76 65 6e 74 5f 74 69 6d 65 20 73 74 65 70 29 event_time step)
b490: 29 29 0a 20 20 20 20 20 20 20 28 73 6f 72 74 20 )). (sort
b4a0: 73 74 65 70 73 20 28 6c 61 6d 62 64 61 20 28 61 steps (lambda (a
b4b0: 20 62 29 0a 09 09 20 20 20 20 20 28 63 6f 6e 64 b)... (cond
b4c0: 0a 09 09 20 20 20 20 20 20 28 28 3c 20 20 20 28 ... ((< (
b4d0: 74 64 62 3a 73 74 65 70 2d 67 65 74 2d 65 76 65 tdb:step-get-eve
b4e0: 6e 74 5f 74 69 6d 65 20 61 29 28 74 64 62 3a 73 nt_time a)(tdb:s
b4f0: 74 65 70 2d 67 65 74 2d 65 76 65 6e 74 5f 74 69 tep-get-event_ti
b500: 6d 65 20 62 29 29 20 23 74 29 0a 09 09 20 20 20 me b)) #t)...
b510: 20 20 20 28 28 65 71 3f 20 28 74 64 62 3a 73 74 ((eq? (tdb:st
b520: 65 70 2d 67 65 74 2d 65 76 65 6e 74 5f 74 69 6d ep-get-event_tim
b530: 65 20 61 29 28 74 64 62 3a 73 74 65 70 2d 67 65 e a)(tdb:step-ge
b540: 74 2d 65 76 65 6e 74 5f 74 69 6d 65 20 62 29 29 t-event_time b))
b550: 20 0a 09 09 20 20 20 20 20 20 20 28 3c 20 20 20 ... (<
b560: 28 74 64 62 3a 73 74 65 70 2d 67 65 74 2d 69 64 (tdb:step-get-id
b570: 20 61 29 20 20 20 20 20 20 20 20 28 74 64 62 3a a) (tdb:
b580: 73 74 65 70 2d 67 65 74 2d 69 64 20 62 29 29 29 step-get-id b)))
b590: 0a 09 09 20 20 20 20 20 20 28 65 6c 73 65 20 23 ... (else #
b5a0: 66 29 29 29 29 29 0a 20 20 20 20 20 20 72 65 73 f))))). res
b5b0: 29 29 0a 0a 3b 3b 20 0a 3b 3b 0a 28 64 65 66 69 ))..;; .;;.(defi
b5c0: 6e 65 20 28 74 65 73 74 73 3a 67 65 74 2d 63 6f ne (tests:get-co
b5d0: 6d 70 72 65 73 73 65 64 2d 73 74 65 70 73 20 72 mpressed-steps r
b5e0: 75 6e 2d 69 64 20 74 65 73 74 2d 69 64 29 0a 20 un-id test-id).
b5f0: 20 28 6c 65 74 2a 20 28 28 73 74 65 70 73 2d 64 (let* ((steps-d
b600: 61 74 61 20 20 28 72 6d 74 3a 67 65 74 2d 73 74 ata (rmt:get-st
b610: 65 70 73 2d 66 6f 72 2d 74 65 73 74 20 72 75 6e eps-for-test run
b620: 2d 69 64 20 74 65 73 74 2d 69 64 29 29 20 3b 3b -id test-id)) ;;
b630: 20 20 20 20 20 20 30 20 20 20 20 20 20 20 31 20 0 1
b640: 20 20 20 32 20 20 20 20 33 20 20 20 20 20 20 20 2 3
b650: 34 20 20 20 20 20 20 20 35 20 20 20 20 20 20 20 4 5
b660: 36 20 20 20 20 20 20 37 20 20 20 20 20 20 20 0a 6 7 .
b670: 09 20 28 63 6f 6d 70 72 73 74 65 70 73 20 20 28 . (comprsteps (
b680: 74 65 73 74 73 3a 70 72 6f 63 65 73 73 2d 73 74 tests:process-st
b690: 65 70 73 2d 74 61 62 6c 65 20 73 74 65 70 73 2d eps-table steps-
b6a0: 64 61 74 61 29 29 29 20 3b 3b 20 23 3c 73 74 65 data))) ;; #<ste
b6b0: 70 6e 61 6d 65 20 73 74 61 72 74 20 65 6e 64 20 pname start end
b6c0: 73 74 61 74 75 73 20 44 75 72 61 74 69 6f 6e 20 status Duration
b6d0: 4c 6f 67 66 69 6c 65 20 43 6f 6d 6d 65 6e 74 20 Logfile Comment
b6e0: 69 64 3e 0a 20 20 20 20 28 6d 61 70 20 28 6c 61 id>. (map (la
b6f0: 6d 62 64 61 20 28 78 29 0a 09 20 20 20 3b 3b 20 mbda (x).. ;;
b700: 74 61 6b 65 20 61 64 76 61 6e 74 61 67 65 20 6f take advantage o
b710: 66 20 74 68 65 20 5c 6e 20 6f 6e 20 74 69 6d 65 f the \n on time
b720: 2d 3e 73 74 72 69 6e 67 0a 09 20 20 20 28 76 65 ->string.. (ve
b730: 63 74 6f 72 20 20 20 20 3b 3b 20 77 65 20 61 72 ctor ;; we ar
b740: 65 20 63 6f 6e 73 74 72 75 63 74 69 6e 67 20 62 e constructing b
b750: 61 73 69 63 61 6c 6c 79 20 74 68 65 20 6f 72 69 asically the ori
b760: 67 69 6e 61 6c 20 76 65 63 74 6f 72 20 62 75 74 ginal vector but
b770: 20 63 6f 6c 6c 61 70 73 69 6e 67 20 73 74 61 72 collapsing star
b780: 74 20 65 6e 64 20 72 65 63 6f 72 64 73 0a 09 20 t end records..
b790: 20 20 20 28 76 65 63 74 6f 72 2d 72 65 66 20 78 (vector-ref x
b7a0: 20 30 29 20 20 20 20 20 20 20 20 20 20 20 20 20 0)
b7b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
b7c0: 20 3b 3b 20 69 64 20 20 20 20 20 20 20 20 30 0a ;; id 0.
b7d0: 09 20 20 20 20 28 6c 65 74 20 28 28 73 20 28 76 . (let ((s (v
b7e0: 65 63 74 6f 72 2d 72 65 66 20 78 20 31 29 29 29 ector-ref x 1)))
b7f0: 0a 09 20 20 20 20 20 20 28 69 66 20 28 6e 75 6d .. (if (num
b800: 62 65 72 3f 20 73 29 28 73 65 63 6f 6e 64 73 2d ber? s)(seconds-
b810: 3e 74 69 6d 65 2d 73 74 72 69 6e 67 20 73 29 20 >time-string s)
b820: 73 29 29 20 3b 3b 20 73 74 61 72 74 74 69 6d 65 s)) ;; starttime
b830: 20 31 0a 09 20 20 20 20 28 6c 65 74 20 28 28 73 1.. (let ((s
b840: 20 28 76 65 63 74 6f 72 2d 72 65 66 20 78 20 32 (vector-ref x 2
b850: 29 29 29 0a 09 20 20 20 20 20 20 28 69 66 20 28 ))).. (if (
b860: 6e 75 6d 62 65 72 3f 20 73 29 28 73 65 63 6f 6e number? s)(secon
b870: 64 73 2d 3e 74 69 6d 65 2d 73 74 72 69 6e 67 20 ds->time-string
b880: 73 29 20 73 29 29 20 3b 3b 20 65 6e 64 74 69 6d s) s)) ;; endtim
b890: 65 20 20 20 32 0a 09 20 20 20 20 28 76 65 63 74 e 2.. (vect
b8a0: 6f 72 2d 72 65 66 20 78 20 33 29 20 20 20 20 20 or-ref x 3)
b8b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
b8c0: 20 20 20 20 20 20 20 20 20 3b 3b 20 73 74 61 74 ;; stat
b8d0: 75 73 20 20 20 20 33 20 20 20 20 0a 09 20 20 20 us 3 ..
b8e0: 20 28 76 65 63 74 6f 72 2d 72 65 66 20 78 20 34 (vector-ref x 4
b8f0: 29 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 )
b900: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 3b ;
b910: 3b 20 64 75 72 61 74 69 6f 6e 20 20 34 0a 09 20 ; duration 4..
b920: 20 20 20 28 76 65 63 74 6f 72 2d 72 65 66 20 78 (vector-ref x
b930: 20 35 29 20 20 20 20 20 20 20 20 20 20 20 20 20 5)
b940: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
b950: 20 3b 3b 20 6c 6f 67 66 69 6c 65 20 20 20 35 0a ;; logfile 5.
b960: 09 20 20 20 20 28 76 65 63 74 6f 72 2d 72 65 66 . (vector-ref
b970: 20 78 20 36 29 20 20 20 20 20 20 20 20 20 20 20 x 6)
b980: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
b990: 20 20 20 3b 3b 20 63 6f 6d 6d 65 6e 74 20 20 20 ;; comment
b9a0: 36 0a 09 20 20 20 20 28 76 65 63 74 6f 72 2d 72 6.. (vector-r
b9b0: 65 66 20 78 20 37 29 29 29 20 20 20 20 20 20 20 ef x 7)))
b9c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
b9d0: 20 20 20 20 20 3b 3b 20 69 64 20 20 20 20 20 20 ;; id
b9e0: 20 20 37 0a 09 20 28 73 6f 72 74 20 28 68 61 73 7.. (sort (has
b9f0: 68 2d 74 61 62 6c 65 2d 76 61 6c 75 65 73 20 63 h-table-values c
ba00: 6f 6d 70 72 73 74 65 70 73 29 0a 09 20 20 20 20 omprsteps)..
ba10: 20 20 20 28 6c 61 6d 62 64 61 20 28 61 20 62 29 (lambda (a b)
ba20: 0a 09 09 20 28 6c 65 74 20 28 28 74 69 6d 65 2d ... (let ((time-
ba30: 61 20 28 76 65 63 74 6f 72 2d 72 65 66 20 61 20 a (vector-ref a
ba40: 31 29 29 0a 09 09 20 20 20 20 20 20 20 28 74 69 1))... (ti
ba50: 6d 65 2d 62 20 28 76 65 63 74 6f 72 2d 72 65 66 me-b (vector-ref
ba60: 20 62 20 31 29 29 0a 09 09 20 20 20 20 20 20 20 b 1))...
ba70: 28 69 64 2d 61 20 20 20 28 76 65 63 74 6f 72 2d (id-a (vector-
ba80: 72 65 66 20 61 20 37 29 29 0a 09 09 20 20 20 20 ref a 7))...
ba90: 20 20 20 28 69 64 2d 62 20 20 20 28 76 65 63 74 (id-b (vect
baa0: 6f 72 2d 72 65 66 20 62 20 37 29 29 29 0a 09 09 or-ref b 7)))...
bab0: 20 20 20 28 69 66 20 28 61 6e 64 20 28 6e 75 6d (if (and (num
bac0: 62 65 72 3f 20 74 69 6d 65 2d 61 29 28 6e 75 6d ber? time-a)(num
bad0: 62 65 72 3f 20 74 69 6d 65 2d 62 29 29 0a 09 09 ber? time-b))...
bae0: 20 20 20 20 20 20 20 28 69 66 20 28 3c 20 74 69 (if (< ti
baf0: 6d 65 2d 61 20 74 69 6d 65 2d 62 29 0a 09 09 09 me-a time-b)....
bb00: 20 20 20 23 74 0a 09 09 09 20 20 20 28 69 66 20 #t.... (if
bb10: 28 65 71 3f 20 74 69 6d 65 2d 61 20 74 69 6d 65 (eq? time-a time
bb20: 2d 62 29 0a 09 09 09 20 20 20 20 20 20 20 28 3c -b).... (<
bb30: 20 69 64 2d 61 20 69 64 2d 62 29 0a 09 09 09 20 id-a id-b)....
bb40: 20 20 20 20 20 20 3b 3b 20 28 73 74 72 69 6e 67 ;; (string
bb50: 3c 3f 20 28 63 6f 6e 63 20 28 76 65 63 74 6f 72 <? (conc (vector
bb60: 2d 72 65 66 20 61 20 32 29 29 0a 09 09 09 20 20 -ref a 2))....
bb70: 20 20 20 20 20 3b 3b 09 20 20 20 20 28 63 6f 6e ;;. (con
bb80: 63 20 28 76 65 63 74 6f 72 2d 72 65 66 20 62 20 c (vector-ref b
bb90: 32 29 29 29 0a 09 09 09 20 20 20 20 20 20 20 23 2))).... #
bba0: 66 29 29 0a 09 09 20 20 20 20 20 20 20 28 73 74 f))... (st
bbb0: 72 69 6e 67 3c 3f 20 28 63 6f 6e 63 20 74 69 6d ring<? (conc tim
bbc0: 65 2d 61 29 28 63 6f 6e 63 20 74 69 6d 65 2d 62 e-a)(conc time-b
bbd0: 29 29 29 29 29 29 29 29 29 0a 0a 0a 3b 3b 20 73 )))))))))...;; s
bbe0: 75 6d 6d 61 72 69 7a 65 20 74 65 73 74 20 69 6e ummarize test in
bbf0: 20 74 6f 20 61 20 66 69 6c 65 20 74 65 73 74 2d to a file test-
bc00: 73 75 6d 6d 61 72 79 2e 68 74 6d 6c 20 69 6e 20 summary.html in
bc10: 74 68 65 20 74 65 73 74 20 64 69 72 65 63 74 6f the test directo
bc20: 72 79 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 74 ry.;;.(define (t
bc30: 65 73 74 73 3a 73 75 6d 6d 61 72 69 7a 65 2d 74 ests:summarize-t
bc40: 65 73 74 20 72 75 6e 2d 69 64 20 74 65 73 74 2d est run-id test-
bc50: 69 64 29 0a 20 20 28 6c 65 74 2a 20 28 28 74 65 id). (let* ((te
bc60: 73 74 2d 64 61 74 20 20 28 72 6d 74 3a 67 65 74 st-dat (rmt:get
bc70: 2d 74 65 73 74 2d 69 6e 66 6f 2d 62 79 2d 69 64 -test-info-by-id
bc80: 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 69 64 29 run-id test-id)
bc90: 29 0a 09 20 28 6f 75 74 2d 64 69 72 20 20 20 28 ).. (out-dir (
bca0: 64 62 3a 74 65 73 74 2d 67 65 74 2d 72 75 6e 64 db:test-get-rund
bcb0: 69 72 20 74 65 73 74 2d 64 61 74 29 29 0a 09 20 ir test-dat))..
bcc0: 28 6f 75 74 2d 66 69 6c 65 20 20 28 63 6f 6e 63 (out-file (conc
bcd0: 20 6f 75 74 2d 64 69 72 20 22 2f 74 65 73 74 2d out-dir "/test-
bce0: 73 75 6d 6d 61 72 79 2e 68 74 6d 6c 22 29 29 29 summary.html")))
bcf0: 0a 20 20 20 20 3b 3b 20 66 69 72 73 74 20 76 65 . ;; first ve
bd00: 72 69 66 79 20 77 65 20 61 72 65 20 61 62 6c 65 rify we are able
bd10: 20 74 6f 20 77 72 69 74 65 20 74 68 65 20 6f 75 to write the ou
bd20: 74 70 75 74 20 66 69 6c 65 0a 20 20 20 20 28 69 tput file. (i
bd30: 66 20 28 6e 6f 74 20 28 66 69 6c 65 2d 77 72 69 f (not (file-wri
bd40: 74 65 2d 61 63 63 65 73 73 3f 20 6f 75 74 2d 64 te-access? out-d
bd50: 69 72 29 29 0a 09 28 64 65 62 75 67 3a 70 72 69 ir))..(debug:pri
bd60: 6e 74 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f nt 0 *default-lo
bd70: 67 2d 70 6f 72 74 2a 20 22 45 52 52 4f 52 3a 20 g-port* "ERROR:
bd80: 63 61 6e 6e 6f 74 20 77 72 69 74 65 20 74 65 73 cannot write tes
bd90: 74 2d 73 75 6d 6d 61 72 79 2e 68 74 6d 6c 20 74 t-summary.html t
bda0: 6f 20 22 20 6f 75 74 2d 64 69 72 29 0a 09 28 6c o " out-dir)..(l
bdb0: 65 74 2a 20 28 3b 3b 20 28 73 74 65 70 73 2d 64 et* (;; (steps-d
bdc0: 61 74 20 28 72 6d 74 3a 67 65 74 2d 73 74 65 70 at (rmt:get-step
bdd0: 73 2d 66 6f 72 2d 74 65 73 74 20 72 75 6e 2d 69 s-for-test run-i
bde0: 64 20 74 65 73 74 2d 69 64 29 29 0a 09 20 20 20 d test-id))..
bdf0: 20 20 20 20 28 74 65 73 74 2d 6e 61 6d 65 20 28 (test-name (
be00: 64 62 3a 74 65 73 74 2d 67 65 74 2d 74 65 73 74 db:test-get-test
be10: 6e 61 6d 65 20 74 65 73 74 2d 64 61 74 29 29 0a name test-dat)).
be20: 09 20 20 20 20 20 20 20 28 69 74 65 6d 2d 70 61 . (item-pa
be30: 74 68 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d th (db:test-get-
be40: 69 74 65 6d 2d 70 61 74 68 20 74 65 73 74 2d 64 item-path test-d
be50: 61 74 29 29 0a 09 20 20 20 20 20 20 20 28 66 75 at)).. (fu
be60: 6c 6c 2d 6e 61 6d 65 20 28 64 62 3a 74 65 73 74 ll-name (db:test
be70: 2d 6d 61 6b 65 2d 66 75 6c 6c 2d 6e 61 6d 65 20 -make-full-name
be80: 74 65 73 74 2d 6e 61 6d 65 20 69 74 65 6d 2d 70 test-name item-p
be90: 61 74 68 29 29 0a 09 20 20 20 20 20 20 20 28 6f ath)).. (o
bea0: 75 70 20 20 20 20 20 20 20 28 6f 70 65 6e 2d 6f up (open-o
beb0: 75 74 70 75 74 2d 66 69 6c 65 20 6f 75 74 2d 66 utput-file out-f
bec0: 69 6c 65 29 29 0a 09 20 20 20 20 20 20 20 28 73 ile)).. (s
bed0: 74 61 74 75 73 20 20 20 20 28 64 62 3a 74 65 73 tatus (db:tes
bee0: 74 2d 67 65 74 2d 73 74 61 74 75 73 20 20 20 74 t-get-status t
bef0: 65 73 74 2d 64 61 74 29 29 0a 09 20 20 20 20 20 est-dat))..
bf00: 20 20 28 63 6f 6c 6f 72 20 20 20 20 20 28 63 6f (color (co
bf10: 6d 6d 6f 6e 3a 67 65 74 2d 63 6f 6c 6f 72 2d 66 mmon:get-color-f
bf20: 72 6f 6d 2d 73 74 61 74 75 73 20 73 74 61 74 75 rom-status statu
bf30: 73 29 29 0a 09 20 20 20 20 20 20 20 28 6c 6f 67 s)).. (log
bf40: 66 20 20 20 20 20 20 28 64 62 3a 74 65 73 74 2d f (db:test-
bf50: 67 65 74 2d 66 69 6e 61 6c 5f 6c 6f 67 66 20 74 get-final_logf t
bf60: 65 73 74 2d 64 61 74 29 29 0a 09 20 20 20 20 20 est-dat))..
bf70: 20 20 28 73 74 65 70 73 2d 64 61 74 20 28 74 65 (steps-dat (te
bf80: 73 74 73 3a 67 65 74 2d 63 6f 6d 70 72 65 73 73 sts:get-compress
bf90: 65 64 2d 73 74 65 70 73 20 72 75 6e 2d 69 64 20 ed-steps run-id
bfa0: 74 65 73 74 2d 69 64 29 29 29 0a 09 20 20 3b 3b test-id))).. ;;
bfb0: 20 28 64 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 63 6f (dcommon:get-co
bfc0: 6d 70 72 65 73 73 65 64 2d 73 74 65 70 73 20 23 mpressed-steps #
bfd0: 66 20 31 20 33 30 30 34 35 29 0a 09 20 20 3b 3b f 1 30045).. ;;
bfe0: 20 28 23 28 22 77 61 73 74 69 6e 67 5f 74 69 6d (#("wasting_tim
bff0: 65 22 20 22 32 33 3a 33 36 3a 31 33 22 20 22 32 e" "23:36:13" "2
c000: 33 3a 33 36 3a 32 31 22 20 22 30 22 20 22 38 2e 3:36:21" "0" "8.
c010: 30 73 22 20 22 77 61 73 74 69 6e 67 5f 74 69 6d 0s" "wasting_tim
c020: 65 2e 6c 6f 67 22 29 29 0a 09 20 20 0a 09 20 20 e.log")).. ..
c030: 28 73 3a 6f 75 74 70 75 74 2d 6e 65 77 0a 09 20 (s:output-new..
c040: 20 20 6f 75 70 0a 09 20 20 20 28 73 3a 68 74 6d oup.. (s:htm
c050: 6c 0a 09 20 20 20 20 28 73 3a 74 69 74 6c 65 20 l.. (s:title
c060: 22 53 75 6d 6d 61 72 79 20 66 6f 72 20 22 20 66 "Summary for " f
c070: 75 6c 6c 2d 6e 61 6d 65 29 0a 09 20 20 20 20 28 ull-name).. (
c080: 73 3a 62 6f 64 79 20 0a 09 20 20 20 20 20 28 73 s:body .. (s
c090: 3a 68 32 20 22 53 75 6d 6d 61 72 79 20 66 6f 72 :h2 "Summary for
c0a0: 20 22 20 66 75 6c 6c 2d 6e 61 6d 65 29 0a 09 20 " full-name)..
c0b0: 20 20 20 20 28 73 3a 74 61 62 6c 65 20 27 63 65 (s:table 'ce
c0c0: 6c 6c 73 70 61 63 69 6e 67 20 22 30 22 20 27 62 llspacing "0" 'b
c0d0: 6f 72 64 65 72 20 22 31 22 0a 09 09 20 20 20 20 order "1"...
c0e0: 20 20 28 73 3a 74 72 20 28 73 3a 74 64 20 22 72 (s:tr (s:td "r
c0f0: 75 6e 20 69 64 22 29 20 20 20 28 73 3a 74 64 20 un id") (s:td
c100: 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 72 75 6e (db:test-get-run
c110: 5f 69 64 20 20 20 74 65 73 74 2d 64 61 74 29 29 _id test-dat))
c120: 0a 09 09 09 20 20 20 20 28 73 3a 74 64 20 22 74 .... (s:td "t
c130: 65 73 74 20 69 64 22 29 20 20 28 73 3a 74 64 20 est id") (s:td
c140: 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 69 64 20 (db:test-get-id
c150: 20 20 20 20 20 20 74 65 73 74 2d 64 61 74 29 29 test-dat))
c160: 29 0a 09 09 20 20 20 20 20 20 28 73 3a 74 72 20 )... (s:tr
c170: 28 73 3a 74 64 20 22 74 65 73 74 6e 61 6d 65 22 (s:td "testname"
c180: 29 20 28 73 3a 74 64 20 74 65 73 74 2d 6e 61 6d ) (s:td test-nam
c190: 65 29 0a 09 09 09 20 20 20 20 28 73 3a 74 64 20 e).... (s:td
c1a0: 22 69 74 65 6d 70 61 74 68 22 29 20 28 73 3a 74 "itempath") (s:t
c1b0: 64 20 69 74 65 6d 2d 70 61 74 68 29 29 0a 09 09 d item-path))...
c1c0: 20 20 20 20 20 20 28 73 3a 74 72 20 28 73 3a 74 (s:tr (s:t
c1d0: 64 20 22 73 74 61 74 65 22 29 20 20 20 20 28 73 d "state") (s
c1e0: 3a 74 64 20 28 64 62 3a 74 65 73 74 2d 67 65 74 :td (db:test-get
c1f0: 2d 73 74 61 74 65 20 20 20 20 74 65 73 74 2d 64 -state test-d
c200: 61 74 29 29 0a 09 09 09 20 20 20 20 28 73 3a 74 at)).... (s:t
c210: 64 20 22 73 74 61 74 75 73 22 29 20 20 20 28 73 d "status") (s
c220: 3a 74 64 20 28 73 3a 61 20 27 68 72 65 66 20 6c :td (s:a 'href l
c230: 6f 67 66 20 28 73 3a 66 6f 6e 74 20 27 63 6f 6c ogf (s:font 'col
c240: 6f 72 20 63 6f 6c 6f 72 20 73 74 61 74 75 73 29 or color status)
c250: 29 29 29 0a 09 09 20 20 20 20 20 20 28 73 3a 74 )))... (s:t
c260: 72 20 28 73 3a 74 64 20 22 54 65 73 74 44 61 74 r (s:td "TestDat
c270: 65 22 29 20 28 73 3a 74 64 20 28 73 65 63 6f 6e e") (s:td (secon
c280: 64 73 2d 3e 77 6f 72 6b 2d 77 65 65 6b 2f 64 61 ds->work-week/da
c290: 79 2d 74 69 6d 65 20 0a 09 09 09 09 09 09 20 20 y-time .......
c2a0: 20 20 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d (db:test-get-
c2b0: 65 76 65 6e 74 5f 74 69 6d 65 20 74 65 73 74 2d event_time test-
c2c0: 64 61 74 29 29 29 0a 09 09 09 20 20 20 20 28 73 dat))).... (s
c2d0: 3a 74 64 20 22 44 75 72 61 74 69 6f 6e 22 29 20 :td "Duration")
c2e0: 28 73 3a 74 64 20 28 73 65 63 6f 6e 64 73 2d 3e (s:td (seconds->
c2f0: 68 72 2d 6d 69 6e 2d 73 65 63 20 28 64 62 3a 74 hr-min-sec (db:t
c300: 65 73 74 2d 67 65 74 2d 72 75 6e 5f 64 75 72 61 est-get-run_dura
c310: 74 69 6f 6e 20 74 65 73 74 2d 64 61 74 29 29 29 tion test-dat)))
c320: 29 29 0a 09 20 20 20 20 20 28 73 3a 68 33 20 22 )).. (s:h3 "
c330: 4c 6f 67 20 66 69 6c 65 73 22 29 0a 09 20 20 20 Log files")..
c340: 20 20 28 73 3a 74 61 62 6c 65 0a 09 20 20 20 20 (s:table..
c350: 20 20 27 63 65 6c 6c 73 70 61 63 69 6e 67 20 22 'cellspacing "
c360: 30 22 20 27 62 6f 72 64 65 72 20 22 31 22 0a 09 0" 'border "1"..
c370: 20 20 20 20 20 20 28 73 3a 74 72 20 28 73 3a 74 (s:tr (s:t
c380: 64 20 22 46 69 6e 61 6c 20 6c 6f 67 22 29 28 73 d "Final log")(s
c390: 3a 74 64 20 28 73 3a 61 20 27 68 72 65 66 20 6c :td (s:a 'href l
c3a0: 6f 67 66 20 6c 6f 67 66 29 29 29 29 0a 09 20 20 ogf logf))))..
c3b0: 20 20 20 28 73 3a 74 61 62 6c 65 0a 09 20 20 20 (s:table..
c3c0: 20 20 20 27 63 65 6c 6c 73 70 61 63 69 6e 67 20 'cellspacing
c3d0: 22 30 22 20 27 62 6f 72 64 65 72 20 22 31 22 0a "0" 'border "1".
c3e0: 09 20 20 20 20 20 20 28 73 3a 74 72 20 28 73 3a . (s:tr (s:
c3f0: 74 64 20 22 53 74 65 70 20 4e 61 6d 65 22 29 28 td "Step Name")(
c400: 73 3a 74 64 20 22 53 74 61 72 74 22 29 28 73 3a s:td "Start")(s:
c410: 74 64 20 22 45 6e 64 22 29 28 73 3a 74 64 20 22 td "End")(s:td "
c420: 53 74 61 74 75 73 22 29 28 73 3a 74 64 20 22 44 Status")(s:td "D
c430: 75 72 61 74 69 6f 6e 22 29 28 73 3a 74 64 20 22 uration")(s:td "
c440: 4c 6f 67 20 46 69 6c 65 22 29 29 0a 09 20 20 20 Log File"))..
c450: 20 20 20 28 6d 61 70 20 28 6c 61 6d 62 64 61 20 (map (lambda
c460: 28 73 74 65 70 2d 64 61 74 29 0a 09 09 20 20 20 (step-dat)...
c470: 20 20 28 73 3a 74 72 20 28 73 3a 74 64 20 28 74 (s:tr (s:td (t
c480: 64 62 3a 73 74 65 70 73 2d 74 61 62 6c 65 2d 67 db:steps-table-g
c490: 65 74 2d 73 74 65 70 6e 61 6d 65 20 73 74 65 70 et-stepname step
c4a0: 2d 64 61 74 29 29 0a 09 09 09 20 20 20 28 73 3a -dat)).... (s:
c4b0: 74 64 20 28 74 64 62 3a 73 74 65 70 73 2d 74 61 td (tdb:steps-ta
c4c0: 62 6c 65 2d 67 65 74 2d 73 74 61 72 74 20 20 20 ble-get-start
c4d0: 20 73 74 65 70 2d 64 61 74 29 29 0a 09 09 09 20 step-dat))....
c4e0: 20 20 28 73 3a 74 64 20 28 74 64 62 3a 73 74 65 (s:td (tdb:ste
c4f0: 70 73 2d 74 61 62 6c 65 2d 67 65 74 2d 65 6e 64 ps-table-get-end
c500: 20 20 20 20 20 20 73 74 65 70 2d 64 61 74 29 29 step-dat))
c510: 0a 09 09 09 20 20 20 28 73 3a 74 64 20 28 74 64 .... (s:td (td
c520: 62 3a 73 74 65 70 73 2d 74 61 62 6c 65 2d 67 65 b:steps-table-ge
c530: 74 2d 73 74 61 74 75 73 20 20 20 73 74 65 70 2d t-status step-
c540: 64 61 74 29 29 0a 09 09 09 20 20 20 28 73 3a 74 dat)).... (s:t
c550: 64 20 28 74 64 62 3a 73 74 65 70 73 2d 74 61 62 d (tdb:steps-tab
c560: 6c 65 2d 67 65 74 2d 72 75 6e 74 69 6d 65 20 20 le-get-runtime
c570: 73 74 65 70 2d 64 61 74 29 29 0a 09 09 09 20 20 step-dat))....
c580: 20 28 73 3a 74 64 20 28 6c 65 74 20 28 28 73 74 (s:td (let ((st
c590: 65 70 2d 6c 6f 67 20 28 74 64 62 3a 73 74 65 70 ep-log (tdb:step
c5a0: 73 2d 74 61 62 6c 65 2d 67 65 74 2d 6c 6f 67 2d s-table-get-log-
c5b0: 66 69 6c 65 20 73 74 65 70 2d 64 61 74 29 29 29 file step-dat)))
c5c0: 0a 09 09 09 09 20 20 20 28 73 3a 61 20 27 68 72 ..... (s:a 'hr
c5d0: 65 66 20 73 74 65 70 2d 6c 6f 67 20 73 74 65 70 ef step-log step
c5e0: 2d 6c 6f 67 29 29 29 29 29 0a 09 09 20 20 20 73 -log)))))... s
c5f0: 74 65 70 73 2d 64 61 74 29 29 0a 09 20 20 20 20 teps-dat))..
c600: 20 29 29 29 0a 09 20 20 28 63 6c 6f 73 65 2d 6f ))).. (close-o
c610: 75 74 70 75 74 2d 70 6f 72 74 20 6f 75 70 29 29 utput-port oup))
c620: 29 29 29 0a 09 20 20 0a 09 20 20 0a 3b 3b 20 4d ))).. .. .;; M
c630: 55 53 54 20 42 45 20 43 41 4c 4c 45 44 20 6c 6f UST BE CALLED lo
c640: 63 61 6c 21 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 cal!.;;.(define
c650: 28 74 65 73 74 73 3a 74 65 73 74 2d 67 65 74 2d (tests:test-get-
c660: 70 61 74 68 73 2d 6d 61 74 63 68 69 6e 67 20 6b paths-matching k
c670: 65 79 6e 61 6d 65 73 20 74 61 72 67 65 74 20 66 eynames target f
c680: 6e 61 6d 65 70 61 74 74 20 23 21 6b 65 79 20 28 namepatt #!key (
c690: 72 65 73 20 27 28 29 29 29 0a 20 20 3b 3b 20 42 res '())). ;; B
c6a0: 55 47 3a 20 4d 6f 76 65 20 74 68 65 20 76 61 6c UG: Move the val
c6b0: 75 65 73 20 64 65 72 69 76 65 64 20 66 72 6f 6d ues derived from
c6c0: 20 61 72 67 73 20 74 6f 20 70 61 72 61 6d 65 74 args to paramet
c6d0: 65 72 73 20 61 6e 64 20 70 75 73 68 20 74 6f 20 ers and push to
c6e0: 6d 65 67 61 74 65 73 74 2e 73 63 6d 0a 20 20 28 megatest.scm. (
c6f0: 6c 65 74 2a 20 28 28 74 65 73 74 70 61 74 74 20 let* ((testpatt
c700: 20 20 28 6f 72 20 28 61 72 67 73 3a 67 65 74 2d (or (args:get-
c710: 61 72 67 20 22 2d 74 65 73 74 70 61 74 74 22 29 arg "-testpatt")
c720: 28 61 72 67 73 3a 67 65 74 2d 61 72 67 20 22 2d (args:get-arg "-
c730: 74 65 73 74 70 61 74 74 22 29 20 22 25 22 29 29 testpatt") "%"))
c740: 0a 09 20 28 73 74 61 74 65 70 61 74 74 20 20 28 .. (statepatt (
c750: 6f 72 20 28 61 72 67 73 3a 67 65 74 2d 61 72 67 or (args:get-arg
c760: 20 22 2d 73 74 61 74 65 22 29 20 20 20 28 61 72 "-state") (ar
c770: 67 73 3a 67 65 74 2d 61 72 67 20 22 3a 73 74 61 gs:get-arg ":sta
c780: 74 65 22 29 20 20 20 20 22 25 22 29 29 0a 09 20 te") "%"))..
c790: 28 73 74 61 74 75 73 70 61 74 74 20 28 6f 72 20 (statuspatt (or
c7a0: 28 61 72 67 73 3a 67 65 74 2d 61 72 67 20 22 2d (args:get-arg "-
c7b0: 73 74 61 74 75 73 22 29 20 20 28 61 72 67 73 3a status") (args:
c7c0: 67 65 74 2d 61 72 67 20 22 3a 73 74 61 74 75 73 get-arg ":status
c7d0: 22 29 20 20 20 22 25 22 29 29 0a 09 20 28 72 75 ") "%")).. (ru
c7e0: 6e 6e 61 6d 65 20 20 20 20 28 6f 72 20 28 61 72 nname (or (ar
c7f0: 67 73 3a 67 65 74 2d 61 72 67 20 22 2d 72 75 6e gs:get-arg "-run
c800: 6e 61 6d 65 22 29 20 28 61 72 67 73 3a 67 65 74 name") (args:get
c810: 2d 61 72 67 20 22 3a 72 75 6e 6e 61 6d 65 22 29 -arg ":runname")
c820: 20 20 22 25 22 29 29 0a 09 20 28 70 61 74 68 73 "%")).. (paths
c830: 2d 66 72 6f 6d 2d 64 62 20 28 72 6d 74 3a 74 65 -from-db (rmt:te
c840: 73 74 2d 67 65 74 2d 70 61 74 68 73 2d 6d 61 74 st-get-paths-mat
c850: 63 68 69 6e 67 2d 6b 65 79 6e 61 6d 65 73 2d 74 ching-keynames-t
c860: 61 72 67 65 74 2d 6e 65 77 20 6b 65 79 6e 61 6d arget-new keynam
c870: 65 73 20 74 61 72 67 65 74 20 72 65 73 0a 09 09 es target res...
c880: 09 09 09 74 65 73 74 70 61 74 74 0a 09 09 09 09 ...testpatt.....
c890: 09 73 74 61 74 65 70 61 74 74 0a 09 09 09 09 09 .statepatt......
c8a0: 73 74 61 74 75 73 70 61 74 74 0a 09 09 09 09 09 statuspatt......
c8b0: 72 75 6e 6e 61 6d 65 29 29 29 0a 20 20 20 20 28 runname))). (
c8c0: 69 66 20 66 6e 61 6d 65 70 61 74 74 0a 09 28 61 if fnamepatt..(a
c8d0: 70 70 6c 79 20 61 70 70 65 6e 64 20 0a 09 20 20 pply append ..
c8e0: 20 20 20 20 20 28 6d 61 70 20 28 6c 61 6d 62 64 (map (lambd
c8f0: 61 20 28 70 29 0a 09 09 20 20 20 20 20 20 28 69 a (p)... (i
c900: 66 20 28 64 69 72 65 63 74 6f 72 79 2d 65 78 69 f (directory-exi
c910: 73 74 73 3f 20 70 29 0a 09 09 09 20 20 28 6c 65 sts? p).... (le
c920: 74 20 28 28 67 6c 6f 62 2d 71 75 65 72 79 20 28 t ((glob-query (
c930: 63 6f 6e 63 20 70 20 22 2f 22 20 66 6e 61 6d 65 conc p "/" fname
c940: 70 61 74 74 29 29 29 0a 09 09 09 20 20 20 20 28 patt))).... (
c950: 68 61 6e 64 6c 65 2d 65 78 63 65 70 74 69 6f 6e handle-exception
c960: 73 0a 09 09 09 09 65 78 6e 0a 09 09 09 09 28 77 s.....exn.....(w
c970: 69 74 68 2d 69 6e 70 75 74 2d 66 72 6f 6d 2d 70 ith-input-from-p
c980: 69 70 65 0a 09 09 09 09 20 20 20 20 28 63 6f 6e ipe..... (con
c990: 63 20 22 65 63 68 6f 20 22 20 67 6c 6f 62 2d 71 c "echo " glob-q
c9a0: 75 65 72 79 29 0a 09 09 09 09 20 20 72 65 61 64 uery)..... read
c9b0: 2d 6c 69 6e 65 73 29 20 20 3b 3b 20 77 65 20 61 -lines) ;; we a
c9c0: 72 65 6e 27 74 20 67 6f 69 6e 67 20 74 6f 20 74 ren't going to t
c9d0: 72 79 20 74 6f 6f 20 68 61 72 64 2e 20 49 66 20 ry too hard. If
c9e0: 67 6c 6f 62 20 62 72 65 61 6b 73 20 69 74 20 69 glob breaks it i
c9f0: 73 20 6c 69 6b 65 6c 79 20 62 65 63 61 75 73 65 s likely because
ca00: 20 73 6f 6d 65 6f 6e 65 20 74 72 69 65 64 20 74 someone tried t
ca10: 6f 20 64 6f 20 2a 2f 2a 2f 2a 2e 6c 6f 67 20 6f o do */*/*.log o
ca20: 72 20 73 69 6d 69 6c 61 72 0a 09 09 09 20 20 20 r similar....
ca30: 20 20 20 28 67 6c 6f 62 20 67 6c 6f 62 2d 71 75 (glob glob-qu
ca40: 65 72 79 29 29 29 0a 09 09 09 20 20 27 28 29 29 ery))).... '())
ca50: 29 0a 09 09 20 20 20 20 70 61 74 68 73 2d 66 72 )... paths-fr
ca60: 6f 6d 2d 64 62 29 29 0a 09 70 61 74 68 73 2d 66 om-db))..paths-f
ca70: 72 6f 6d 2d 64 62 29 29 29 0a 0a 09 09 09 20 20 rom-db))).....
ca80: 20 20 20 20 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d .;;=========
ca90: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
caa0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
cab0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
cac0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b =============.;;
cad0: 20 47 61 74 68 65 72 20 64 61 74 61 20 66 72 6f Gather data fro
cae0: 6d 20 74 65 73 74 2f 74 61 73 6b 20 73 70 65 63 m test/task spec
caf0: 69 66 69 63 61 74 69 6f 6e 73 0a 3b 3b 3d 3d 3d ifications.;;===
cb00: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
cb10: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
cb20: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
cb30: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
cb40: 3d 3d 3d 0a 0a 3b 3b 20 28 64 65 66 69 6e 65 20 ===..;; (define
cb50: 28 74 65 73 74 73 3a 67 65 74 2d 76 61 6c 69 64 (tests:get-valid
cb60: 2d 74 65 73 74 73 20 74 65 73 74 73 64 69 72 20 -tests testsdir
cb70: 74 65 73 74 2d 70 61 74 74 73 29 20 3b 3b 20 20 test-patts) ;;
cb80: 23 21 6b 65 79 20 28 74 65 73 74 2d 6e 61 6d 65 #!key (test-name
cb90: 73 20 27 28 29 29 29 0a 3b 3b 20 20 20 28 6c 65 s '())).;; (le
cba0: 74 20 28 28 74 65 73 74 73 20 28 67 6c 6f 62 20 t ((tests (glob
cbb0: 28 63 6f 6e 63 20 74 65 73 74 73 64 69 72 20 22 (conc testsdir "
cbc0: 2f 74 65 73 74 73 2f 2a 22 29 29 29 29 20 3b 3b /tests/*")))) ;;
cbd0: 20 22 20 28 73 74 72 69 6e 67 2d 74 72 61 6e 73 " (string-trans
cbe0: 6c 61 74 65 20 70 61 74 74 20 22 25 22 20 22 2a late patt "%" "*
cbf0: 22 29 29 29 29 29 0a 3b 3b 20 20 20 20 20 28 73 "))))).;; (s
cc00: 65 74 21 20 74 65 73 74 73 20 28 66 69 6c 74 65 et! tests (filte
cc10: 72 20 28 6c 61 6d 62 64 61 20 28 74 65 73 74 29 r (lambda (test)
cc20: 28 63 6f 6d 6d 6f 6e 3a 66 69 6c 65 2d 65 78 69 (common:file-exi
cc30: 73 74 73 3f 20 28 63 6f 6e 63 20 74 65 73 74 20 sts? (conc test
cc40: 22 2f 74 65 73 74 63 6f 6e 66 69 67 22 29 29 29 "/testconfig")))
cc50: 20 74 65 73 74 73 29 29 0a 3b 3b 20 20 20 20 20 tests)).;;
cc60: 28 64 65 6c 65 74 65 2d 64 75 70 6c 69 63 61 74 (delete-duplicat
cc70: 65 73 0a 3b 3b 20 20 20 20 20 20 28 66 69 6c 74 es.;; (filt
cc80: 65 72 20 28 6c 61 6d 62 64 61 20 28 74 65 73 74 er (lambda (test
cc90: 6e 61 6d 65 29 0a 3b 3b 20 09 20 20 20 20 20 20 name).;; .
cca0: 20 28 74 65 73 74 73 3a 6d 61 74 63 68 20 74 65 (tests:match te
ccb0: 73 74 2d 70 61 74 74 73 20 74 65 73 74 6e 61 6d st-patts testnam
ccc0: 65 20 23 66 29 29 0a 3b 3b 20 09 20 20 20 20 20 e #f)).;; .
ccd0: 28 6d 61 70 20 28 6c 61 6d 62 64 61 20 28 74 65 (map (lambda (te
cce0: 73 74 70 29 0a 3b 3b 20 09 09 20 20 20 20 28 6c stp).;; .. (l
ccf0: 61 73 74 20 28 73 74 72 69 6e 67 2d 73 70 6c 69 ast (string-spli
cd00: 74 20 74 65 73 74 70 20 22 2f 22 29 29 29 0a 3b t testp "/"))).;
cd10: 3b 20 09 09 20 20 74 65 73 74 73 29 29 29 29 29 ; .. tests)))))
cd20: 0a 0a 28 64 65 66 69 6e 65 20 28 74 65 73 74 73 ..(define (tests
cd30: 3a 67 65 74 2d 74 65 73 74 2d 70 61 74 68 2d 66 :get-test-path-f
cd40: 72 6f 6d 2d 65 6e 76 69 72 6f 6e 6d 65 6e 74 29 rom-environment)
cd50: 0a 20 20 28 69 66 20 28 61 6e 64 20 28 67 65 74 . (if (and (get
cd60: 65 6e 76 20 22 4d 54 5f 4c 49 4e 4b 54 52 45 45 env "MT_LINKTREE
cd70: 22 29 0a 09 20 20 20 28 67 65 74 65 6e 76 20 22 ").. (getenv "
cd80: 4d 54 5f 54 41 52 47 45 54 22 29 0a 09 20 20 20 MT_TARGET")..
cd90: 28 67 65 74 65 6e 76 20 22 4d 54 5f 52 55 4e 4e (getenv "MT_RUNN
cda0: 41 4d 45 22 29 0a 09 20 20 20 28 67 65 74 65 6e AME").. (geten
cdb0: 76 20 22 4d 54 5f 54 45 53 54 5f 4e 41 4d 45 22 v "MT_TEST_NAME"
cdc0: 29 0a 09 20 20 20 28 67 65 74 65 6e 76 20 22 4d ).. (getenv "M
cdd0: 54 5f 49 54 45 4d 50 41 54 48 22 29 29 0a 20 20 T_ITEMPATH")).
cde0: 20 20 20 20 28 63 6f 6e 63 20 28 67 65 74 65 6e (conc (geten
cdf0: 76 20 22 4d 54 5f 4c 49 4e 4b 54 52 45 45 22 29 v "MT_LINKTREE")
ce00: 20 20 22 2f 22 0a 09 20 20 20 20 28 67 65 74 65 "/".. (gete
ce10: 6e 76 20 22 4d 54 5f 54 41 52 47 45 54 22 29 20 nv "MT_TARGET")
ce20: 20 20 20 22 2f 22 0a 09 20 20 20 20 28 67 65 74 "/".. (get
ce30: 65 6e 76 20 22 4d 54 5f 52 55 4e 4e 41 4d 45 22 env "MT_RUNNAME"
ce40: 29 20 20 20 22 2f 22 0a 09 20 20 20 20 28 67 65 ) "/".. (ge
ce50: 74 65 6e 76 20 22 4d 54 5f 54 45 53 54 5f 4e 41 tenv "MT_TEST_NA
ce60: 4d 45 22 29 0a 09 20 20 20 20 28 69 66 20 28 61 ME").. (if (a
ce70: 6e 64 20 28 67 65 74 65 6e 76 20 22 4d 54 5f 49 nd (getenv "MT_I
ce80: 54 45 4d 50 41 54 48 22 29 0a 20 20 20 20 20 20 TEMPATH").
ce90: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
cea0: 6e 6f 74 20 28 73 74 72 69 6e 67 3d 3f 20 22 22 not (string=? ""
ceb0: 20 28 67 65 74 65 6e 76 20 22 4d 54 5f 49 54 45 (getenv "MT_ITE
cec0: 4d 50 41 54 48 22 29 29 29 29 0a 09 09 28 63 6f MPATH"))))...(co
ced0: 6e 63 20 22 2f 22 20 28 67 65 74 65 6e 76 20 22 nc "/" (getenv "
cee0: 4d 54 5f 49 54 45 4d 50 41 54 48 22 29 29 0a 20 MT_ITEMPATH")).
cef0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 22 "
cf00: 22 29 29 0a 20 20 20 20 20 20 23 66 29 29 0a 0a ")). #f))..
cf10: 3b 3b 20 69 66 20 2e 74 65 73 74 63 6f 6e 66 69 ;; if .testconfi
cf20: 67 20 65 78 69 73 74 73 20 69 6e 20 74 65 73 74 g exists in test
cf30: 20 64 69 72 65 63 74 6f 72 79 20 72 65 61 64 20 directory read
cf40: 61 6e 64 20 72 65 74 75 72 6e 20 69 74 0a 3b 3b and return it.;;
cf50: 20 65 6c 73 65 20 69 66 20 68 61 76 65 20 63 61 else if have ca
cf60: 63 68 65 64 20 63 6f 70 79 20 69 6e 20 2a 74 65 ched copy in *te
cf70: 73 74 63 6f 6e 66 69 67 73 2a 20 72 65 74 75 72 stconfigs* retur
cf80: 6e 20 69 74 20 49 46 46 20 74 68 65 72 65 20 69 n it IFF there i
cf90: 73 20 61 20 73 65 63 74 69 6f 6e 20 22 68 61 76 s a section "hav
cfa0: 65 20 66 75 6c 6c 64 61 74 61 22 0a 3b 3b 20 65 e fulldata".;; e
cfb0: 6c 73 65 20 72 65 61 64 20 74 68 65 20 74 65 73 lse read the tes
cfc0: 74 63 6f 6e 66 69 67 20 66 69 6c 65 0a 3b 3b 20 tconfig file.;;
cfd0: 20 20 69 66 20 68 61 76 65 20 70 61 74 68 20 74 if have path t
cfe0: 6f 20 74 65 73 74 20 64 69 72 65 63 74 6f 72 79 o test directory
cff0: 20 73 61 76 65 20 74 68 65 20 63 6f 6e 66 69 67 save the config
d000: 20 61 73 20 2e 74 65 73 74 63 6f 6e 66 69 67 20 as .testconfig
d010: 61 6e 64 20 72 65 74 75 72 6e 20 69 74 0a 3b 3b and return it.;;
d020: 0a 28 64 65 66 69 6e 65 20 28 74 65 73 74 73 3a .(define (tests:
d030: 67 65 74 2d 74 65 73 74 63 6f 6e 66 69 67 20 74 get-testconfig t
d040: 65 73 74 2d 6e 61 6d 65 20 69 74 65 6d 2d 70 61 est-name item-pa
d050: 74 68 20 74 65 73 74 2d 72 65 67 69 73 74 72 79 th test-registry
d060: 20 73 79 73 74 65 6d 2d 61 6c 6c 6f 77 65 64 20 system-allowed
d070: 23 21 6b 65 79 20 28 66 6f 72 63 65 2d 63 72 65 #!key (force-cre
d080: 61 74 65 20 23 66 29 28 61 6c 6c 6f 77 2d 77 72 ate #f)(allow-wr
d090: 69 74 65 2d 63 61 63 68 65 20 23 74 29 29 0a 20 ite-cache #t)).
d0a0: 20 28 6c 65 74 2a 20 28 28 75 73 65 2d 63 61 63 (let* ((use-cac
d0b0: 68 65 20 20 20 20 28 63 6f 6d 6d 6f 6e 3a 75 73 he (common:us
d0c0: 65 2d 63 61 63 68 65 3f 29 29 0a 09 20 28 63 61 e-cache?)).. (ca
d0d0: 63 68 65 2d 70 61 74 68 20 20 20 28 74 65 73 74 che-path (test
d0e0: 73 3a 67 65 74 2d 74 65 73 74 2d 70 61 74 68 2d s:get-test-path-
d0f0: 66 72 6f 6d 2d 65 6e 76 69 72 6f 6e 6d 65 6e 74 from-environment
d100: 29 29 0a 09 20 28 63 61 63 68 65 2d 66 69 6c 65 )).. (cache-file
d110: 20 20 20 28 61 6e 64 20 63 61 63 68 65 2d 70 61 (and cache-pa
d120: 74 68 20 28 63 6f 6e 63 20 63 61 63 68 65 2d 70 th (conc cache-p
d130: 61 74 68 20 22 2f 2e 74 65 73 74 63 6f 6e 66 69 ath "/.testconfi
d140: 67 22 29 29 29 0a 09 20 28 63 61 63 68 65 2d 65 g"))).. (cache-e
d150: 78 69 73 74 73 20 28 61 6e 64 20 63 61 63 68 65 xists (and cache
d160: 2d 66 69 6c 65 0a 09 09 09 20 20 20 20 28 6e 6f -file.... (no
d170: 74 20 66 6f 72 63 65 2d 63 72 65 61 74 65 29 20 t force-create)
d180: 20 3b 3b 20 69 66 20 66 6f 72 63 65 2d 63 72 65 ;; if force-cre
d190: 61 74 65 20 74 68 65 6e 20 70 72 65 74 65 6e 64 ate then pretend
d1a0: 20 74 68 65 72 65 20 69 73 20 6e 6f 20 63 61 63 there is no cac
d1b0: 68 65 20 74 6f 20 72 65 61 64 0a 09 09 09 20 20 he to read....
d1c0: 20 20 28 63 6f 6d 6d 6f 6e 3a 66 69 6c 65 2d 65 (common:file-e
d1d0: 78 69 73 74 73 3f 20 63 61 63 68 65 2d 66 69 6c xists? cache-fil
d1e0: 65 29 29 29 0a 09 20 28 63 61 63 68 65 64 2d 64 e))).. (cached-d
d1f0: 61 74 20 20 20 28 69 66 20 28 61 6e 64 20 28 6e at (if (and (n
d200: 6f 74 20 66 6f 72 63 65 2d 63 72 65 61 74 65 29 ot force-create)
d210: 0a 09 09 09 09 63 61 63 68 65 2d 65 78 69 73 74 .....cache-exist
d220: 73 0a 09 09 09 09 75 73 65 2d 63 61 63 68 65 29 s.....use-cache)
d230: 0a 09 09 09 20 20 20 28 68 61 6e 64 6c 65 2d 65 .... (handle-e
d240: 78 63 65 70 74 69 6f 6e 73 0a 09 09 09 20 20 20 xceptions....
d250: 20 65 78 6e 0a 09 09 09 20 20 20 20 23 66 20 3b exn.... #f ;
d260: 3b 20 61 6e 79 20 69 73 73 75 65 73 2c 20 6a 75 ; any issues, ju
d270: 73 74 20 67 69 76 65 20 75 70 20 77 69 74 68 20 st give up with
d280: 74 68 65 20 63 61 63 68 65 64 20 76 65 72 73 69 the cached versi
d290: 6f 6e 20 61 6e 64 20 72 65 2d 72 65 61 64 0a 09 on and re-read..
d2a0: 09 09 20 20 20 20 28 63 6f 6e 66 69 67 66 3a 72 .. (configf:r
d2b0: 65 61 64 2d 61 6c 69 73 74 20 63 61 63 68 65 2d ead-alist cache-
d2c0: 66 69 6c 65 29 29 0a 09 09 09 20 20 20 23 66 29 file)).... #f)
d2d0: 29 0a 20 20 20 20 20 20 20 20 20 28 74 65 73 74 ). (test
d2e0: 2d 66 75 6c 6c 2d 6e 61 6d 65 20 28 69 66 20 28 -full-name (if (
d2f0: 61 6e 64 20 69 74 65 6d 2d 70 61 74 68 20 28 6e and item-path (n
d300: 6f 74 20 28 73 74 72 69 6e 67 2d 6e 75 6c 6c 3f ot (string-null?
d310: 20 69 74 65 6d 2d 70 61 74 68 29 29 29 0a 20 20 item-path))).
d320: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d330: 20 20 20 20 20 20 20 20 20 20 20 28 63 6f 6e 63 (conc
d340: 20 74 65 73 74 2d 6e 61 6d 65 20 22 2f 22 20 69 test-name "/" i
d350: 74 65 6d 2d 70 61 74 68 29 0a 20 20 20 20 20 20 tem-path).
d360: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d370: 20 20 20 20 20 20 20 74 65 73 74 2d 6e 61 6d 65 test-name
d380: 29 29 29 0a 20 20 20 20 28 69 66 20 63 61 63 68 ))). (if cach
d390: 65 64 2d 64 61 74 0a 09 63 61 63 68 65 64 2d 64 ed-dat..cached-d
d3a0: 61 74 0a 09 28 6c 65 74 20 28 28 64 61 74 20 28 at..(let ((dat (
d3b0: 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 hash-table-ref/d
d3c0: 65 66 61 75 6c 74 20 2a 74 65 73 74 63 6f 6e 66 efault *testconf
d3d0: 69 67 73 2a 20 74 65 73 74 2d 66 75 6c 6c 2d 6e igs* test-full-n
d3e0: 61 6d 65 20 23 66 29 29 29 0a 09 20 20 28 69 66 ame #f))).. (if
d3f0: 20 28 61 6e 64 20 20 64 61 74 20 3b 3b 20 68 61 (and dat ;; ha
d400: 76 65 20 61 20 6c 6f 63 61 6c 6c 79 20 63 61 63 ve a locally cac
d410: 68 65 64 20 76 65 72 73 69 6f 6e 0a 09 09 20 20 hed version...
d420: 20 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 (hash-table-re
d430: 66 2f 64 65 66 61 75 6c 74 20 64 61 74 20 22 68 f/default dat "h
d440: 61 76 65 20 66 75 6c 6c 64 61 74 61 22 20 23 66 ave fulldata" #f
d450: 29 29 20 3b 3b 20 6d 61 72 6b 65 64 20 61 73 20 )) ;; marked as
d460: 67 6f 6f 64 20 64 61 74 61 3f 0a 09 20 20 20 20 good data?..
d470: 20 20 64 61 74 0a 09 20 20 20 20 20 20 3b 3b 20 dat.. ;;
d480: 6e 6f 20 63 61 63 68 65 64 20 64 61 74 61 20 61 no cached data a
d490: 76 61 69 6c 61 62 6c 65 0a 09 20 20 20 20 20 20 vailable..
d4a0: 28 6c 65 74 2a 20 28 28 74 72 65 67 20 20 20 20 (let* ((treg
d4b0: 20 20 20 20 20 28 6f 72 20 74 65 73 74 2d 72 65 (or test-re
d4c0: 67 69 73 74 72 79 0a 09 09 09 09 20 20 20 20 20 gistry.....
d4d0: 20 20 28 74 65 73 74 73 3a 67 65 74 2d 61 6c 6c (tests:get-all
d4e0: 29 29 29 0a 09 09 20 20 20 20 20 28 74 65 73 74 )))... (test
d4f0: 2d 70 61 74 68 20 20 20 20 28 6f 72 20 28 68 61 -path (or (ha
d500: 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 sh-table-ref/def
d510: 61 75 6c 74 20 74 72 65 67 20 74 65 73 74 2d 6e ault treg test-n
d520: 61 6d 65 20 23 66 29 0a 09 09 09 09 20 20 20 20 ame #f).....
d530: 20 20 20 28 63 6f 6e 63 20 2a 74 6f 70 70 61 74 (conc *toppat
d540: 68 2a 20 22 2f 74 65 73 74 73 2f 22 20 74 65 73 h* "/tests/" tes
d550: 74 2d 6e 61 6d 65 29 29 29 0a 09 09 20 20 20 20 t-name)))...
d560: 20 28 74 65 73 74 2d 63 6f 6e 66 69 67 66 20 28 (test-configf (
d570: 63 6f 6e 63 20 74 65 73 74 2d 70 61 74 68 20 22 conc test-path "
d580: 2f 74 65 73 74 63 6f 6e 66 69 67 22 29 29 0a 09 /testconfig"))..
d590: 09 20 20 20 20 20 28 74 65 73 74 65 78 69 73 74 . (testexist
d5a0: 73 20 20 20 28 61 6e 64 20 28 63 6f 6d 6d 6f 6e s (and (common
d5b0: 3a 66 69 6c 65 2d 65 78 69 73 74 73 3f 20 74 65 :file-exists? te
d5c0: 73 74 2d 63 6f 6e 66 69 67 66 29 28 66 69 6c 65 st-configf)(file
d5d0: 2d 72 65 61 64 2d 61 63 63 65 73 73 3f 20 74 65 -read-access? te
d5e0: 73 74 2d 63 6f 6e 66 69 67 66 29 29 29 0a 09 09 st-configf)))...
d5f0: 20 20 20 20 20 28 74 63 66 67 20 20 20 20 20 20 (tcfg
d600: 20 20 20 28 69 66 20 74 65 73 74 65 78 69 73 74 (if testexist
d610: 73 0a 09 09 09 09 20 20 20 20 20 20 20 28 72 65 s..... (re
d620: 61 64 2d 63 6f 6e 66 69 67 20 74 65 73 74 2d 63 ad-config test-c
d630: 6f 6e 66 69 67 66 20 23 66 20 73 79 73 74 65 6d onfigf #f system
d640: 2d 61 6c 6c 6f 77 65 64 0a 09 09 09 09 09 09 20 -allowed.......
d650: 20 20 20 65 6e 76 69 72 6f 6e 2d 70 61 74 74 3a environ-patt:
d660: 20 28 69 66 20 73 79 73 74 65 6d 2d 61 6c 6c 6f (if system-allo
d670: 77 65 64 0a 09 09 09 09 09 09 09 09 20 20 20 20 wed.........
d680: 20 20 22 70 72 65 2d 6c 61 75 6e 63 68 2d 65 6e "pre-launch-en
d690: 76 2d 76 61 72 73 22 0a 09 09 09 09 09 09 09 09 v-vars".........
d6a0: 20 20 20 20 20 20 23 66 29 29 0a 09 09 09 09 20 #f)).....
d6b0: 20 20 20 20 20 20 23 66 29 29 29 0a 09 09 28 69 #f)))...(i
d6c0: 66 20 28 61 6e 64 20 74 63 66 67 20 63 61 63 68 f (and tcfg cach
d6d0: 65 2d 66 69 6c 65 29 20 28 68 61 73 68 2d 74 61 e-file) (hash-ta
d6e0: 62 6c 65 2d 73 65 74 21 20 74 63 66 67 20 22 68 ble-set! tcfg "h
d6f0: 61 76 65 20 66 75 6c 6c 64 61 74 61 22 20 23 74 ave fulldata" #t
d700: 29 29 20 3b 3b 20 6d 61 72 6b 20 74 68 69 73 20 )) ;; mark this
d710: 61 73 20 66 75 6c 6c 79 20 72 65 61 64 20 64 61 as fully read da
d720: 74 61 0a 09 09 28 69 66 20 74 63 66 67 20 28 68 ta...(if tcfg (h
d730: 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 2a ash-table-set! *
d740: 74 65 73 74 63 6f 6e 66 69 67 73 2a 20 74 65 73 testconfigs* tes
d750: 74 2d 66 75 6c 6c 2d 6e 61 6d 65 20 74 63 66 67 t-full-name tcfg
d760: 29 29 0a 09 09 28 69 66 20 28 61 6e 64 20 74 65 ))...(if (and te
d770: 73 74 65 78 69 73 74 73 0a 09 09 09 20 63 61 63 stexists.... cac
d780: 68 65 2d 66 69 6c 65 0a 09 09 09 20 28 66 69 6c he-file.... (fil
d790: 65 2d 77 72 69 74 65 2d 61 63 63 65 73 73 3f 20 e-write-access?
d7a0: 63 61 63 68 65 2d 70 61 74 68 29 0a 09 09 09 20 cache-path)....
d7b0: 61 6c 6c 6f 77 2d 77 72 69 74 65 2d 63 61 63 68 allow-write-cach
d7c0: 65 29 0a 09 09 20 20 20 20 28 6c 65 74 20 28 28 e)... (let ((
d7d0: 74 70 61 74 68 20 28 63 6f 6e 63 20 63 61 63 68 tpath (conc cach
d7e0: 65 2d 70 61 74 68 20 22 2f 2e 74 65 73 74 63 6f e-path "/.testco
d7f0: 6e 66 69 67 22 29 29 29 0a 09 09 20 20 20 20 20 nfig")))...
d800: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e (debug:print-in
d810: 66 6f 20 31 20 2a 64 65 66 61 75 6c 74 2d 6c 6f fo 1 *default-lo
d820: 67 2d 70 6f 72 74 2a 20 22 43 61 63 68 69 6e 67 g-port* "Caching
d830: 20 74 65 73 74 63 6f 6e 66 69 67 20 66 6f 72 20 testconfig for
d840: 22 20 74 65 73 74 2d 6e 61 6d 65 20 22 20 69 6e " test-name " in
d850: 20 22 20 74 70 61 74 68 29 0a 20 20 20 20 20 20 " tpath).
d860: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d870: 28 69 66 20 28 6e 6f 74 20 28 63 6f 6d 6d 6f 6e (if (not (common
d880: 3a 69 6e 2d 72 75 6e 6e 69 6e 67 2d 74 65 73 74 :in-running-test
d890: 3f 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 ?)).
d8a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 63 (c
d8b0: 6f 6e 66 69 67 66 3a 77 72 69 74 65 2d 61 6c 69 onfigf:write-ali
d8c0: 73 74 20 74 63 66 67 20 74 70 61 74 68 29 29 29 st tcfg tpath)))
d8d0: 29 0a 09 09 74 63 66 67 29 29 29 29 29 29 0a 20 )...tcfg)))))).
d8e0: 20 0a 3b 3b 20 73 6f 72 74 20 74 65 73 74 73 20 .;; sort tests
d8f0: 62 79 20 70 72 69 6f 72 69 74 79 20 61 6e 64 20 by priority and
d900: 77 61 69 74 6f 6e 0a 3b 3b 20 4d 6f 76 65 20 74 waiton.;; Move t
d910: 65 73 74 20 73 70 65 63 69 66 69 63 20 73 74 75 est specific stu
d920: 66 66 20 74 6f 20 61 20 74 65 73 74 20 75 6e 69 ff to a test uni
d930: 74 20 46 49 58 4d 45 20 6f 6e 65 20 6f 66 20 74 t FIXME one of t
d940: 68 65 73 65 20 64 61 79 73 0a 28 64 65 66 69 6e hese days.(defin
d950: 65 20 28 74 65 73 74 73 3a 73 6f 72 74 2d 62 79 e (tests:sort-by
d960: 2d 70 72 69 6f 72 69 74 79 2d 61 6e 64 2d 77 61 -priority-and-wa
d970: 69 74 6f 6e 20 74 65 73 74 2d 72 65 63 6f 72 64 iton test-record
d980: 73 29 0a 20 20 28 69 66 20 28 65 71 3f 20 28 68 s). (if (eq? (h
d990: 61 73 68 2d 74 61 62 6c 65 2d 73 69 7a 65 20 74 ash-table-size t
d9a0: 65 73 74 2d 72 65 63 6f 72 64 73 29 20 30 29 0a est-records) 0).
d9b0: 20 20 20 20 20 20 27 28 29 0a 20 20 20 20 20 20 '().
d9c0: 28 6c 65 74 2a 20 28 28 6d 75 6e 67 65 70 72 69 (let* ((mungepri
d9d0: 6f 72 69 74 79 20 28 6c 61 6d 62 64 61 20 28 70 ority (lambda (p
d9e0: 72 69 6f 72 69 74 79 29 0a 09 09 09 20 20 20 20 riority)....
d9f0: 20 20 28 69 66 20 70 72 69 6f 72 69 74 79 0a 09 (if priority..
da00: 09 09 09 20 20 28 6c 65 74 20 28 28 74 6d 70 20 ... (let ((tmp
da10: 28 61 6e 79 2d 3e 6e 75 6d 62 65 72 20 70 72 69 (any->number pri
da20: 6f 72 69 74 79 29 29 29 0a 09 09 09 09 20 20 20 ority))).....
da30: 20 28 69 66 20 74 6d 70 20 74 6d 70 20 28 62 65 (if tmp tmp (be
da40: 67 69 6e 20 28 64 65 62 75 67 3a 70 72 69 6e 74 gin (debug:print
da50: 2d 65 72 72 6f 72 20 30 20 2a 64 65 66 61 75 6c -error 0 *defaul
da60: 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 62 61 64 t-log-port* "bad
da70: 20 70 72 69 6f 72 69 74 79 20 76 61 6c 75 65 20 priority value
da80: 22 20 70 72 69 6f 72 69 74 79 20 22 2c 20 75 73 " priority ", us
da90: 69 6e 67 20 30 22 29 20 30 29 29 29 0a 09 09 09 ing 0") 0)))....
daa0: 09 20 20 30 29 29 29 0a 09 20 20 20 20 20 28 61 . 0))).. (a
dab0: 6c 6c 2d 74 65 73 74 73 20 20 20 20 20 20 28 68 ll-tests (h
dac0: 61 73 68 2d 74 61 62 6c 65 2d 6b 65 79 73 20 74 ash-table-keys t
dad0: 65 73 74 2d 72 65 63 6f 72 64 73 29 29 0a 09 20 est-records))..
dae0: 20 20 20 20 28 61 6c 6c 2d 77 61 69 74 65 64 2d (all-waited-
daf0: 6f 6e 20 20 28 6c 65 74 20 6c 6f 6f 70 20 28 28 on (let loop ((
db00: 68 65 64 20 28 63 61 72 20 61 6c 6c 2d 74 65 73 hed (car all-tes
db10: 74 73 29 29 0a 09 09 09 09 09 28 74 61 6c 20 28 ts))......(tal (
db20: 63 64 72 20 61 6c 6c 2d 74 65 73 74 73 29 29 0a cdr all-tests)).
db30: 09 09 09 09 09 28 72 65 73 20 27 28 29 29 29 0a .....(res '())).
db40: 09 09 09 20 20 20 20 20 20 20 28 6c 65 74 2a 20 ... (let*
db50: 28 28 74 72 65 63 20 20 20 20 28 68 61 73 68 2d ((trec (hash-
db60: 74 61 62 6c 65 2d 72 65 66 20 74 65 73 74 2d 72 table-ref test-r
db70: 65 63 6f 72 64 73 20 68 65 64 29 29 0a 09 09 09 ecords hed))....
db80: 09 20 20 20 20 20 20 28 77 61 69 74 6f 6e 73 20 . (waitons
db90: 28 6f 72 20 28 74 65 73 74 73 3a 74 65 73 74 71 (or (tests:testq
dba0: 75 65 75 65 2d 67 65 74 2d 77 61 69 74 6f 6e 73 ueue-get-waitons
dbb0: 20 74 72 65 63 29 20 27 28 29 29 29 29 0a 09 09 trec) '())))...
dbc0: 09 09 20 28 69 66 20 28 6e 75 6c 6c 3f 20 74 61 .. (if (null? ta
dbd0: 6c 29 0a 09 09 09 09 20 20 20 20 20 28 61 70 70 l)..... (app
dbe0: 65 6e 64 20 72 65 73 20 77 61 69 74 6f 6e 73 29 end res waitons)
dbf0: 0a 09 09 09 09 20 20 20 20 20 28 6c 6f 6f 70 20 ..... (loop
dc00: 28 63 61 72 20 74 61 6c 29 28 63 64 72 20 74 61 (car tal)(cdr ta
dc10: 6c 29 28 61 70 70 65 6e 64 20 72 65 73 20 77 61 l)(append res wa
dc20: 69 74 6f 6e 73 29 29 29 29 29 29 0a 09 20 20 20 itons))))))..
dc30: 20 20 28 73 6f 72 74 2d 66 6e 31 20 0a 09 20 20 (sort-fn1 ..
dc40: 20 20 20 20 28 6c 61 6d 62 64 61 20 28 61 20 62 (lambda (a b
dc50: 29 0a 09 09 28 6c 65 74 2a 20 28 28 61 2d 72 65 )...(let* ((a-re
dc60: 63 6f 72 64 20 20 20 28 68 61 73 68 2d 74 61 62 cord (hash-tab
dc70: 6c 65 2d 72 65 66 20 74 65 73 74 2d 72 65 63 6f le-ref test-reco
dc80: 72 64 73 20 61 29 29 0a 09 09 20 20 20 20 20 20 rds a))...
dc90: 20 28 62 2d 72 65 63 6f 72 64 20 20 20 28 68 61 (b-record (ha
dca0: 73 68 2d 74 61 62 6c 65 2d 72 65 66 20 74 65 73 sh-table-ref tes
dcb0: 74 2d 72 65 63 6f 72 64 73 20 62 29 29 0a 09 09 t-records b))...
dcc0: 20 20 20 20 20 20 20 28 61 2d 77 61 69 74 6f 6e (a-waiton
dcd0: 73 20 20 28 6f 72 20 28 74 65 73 74 73 3a 74 65 s (or (tests:te
dce0: 73 74 71 75 65 75 65 2d 67 65 74 2d 77 61 69 74 stqueue-get-wait
dcf0: 6f 6e 73 20 61 2d 72 65 63 6f 72 64 29 20 27 28 ons a-record) '(
dd00: 29 29 29 0a 09 09 20 20 20 20 20 20 20 28 62 2d )))... (b-
dd10: 77 61 69 74 6f 6e 73 20 20 28 6f 72 20 28 74 65 waitons (or (te
dd20: 73 74 73 3a 74 65 73 74 71 75 65 75 65 2d 67 65 sts:testqueue-ge
dd30: 74 2d 77 61 69 74 6f 6e 73 20 62 2d 72 65 63 6f t-waitons b-reco
dd40: 72 64 29 20 27 28 29 29 29 0a 09 09 20 20 20 20 rd) '()))...
dd50: 20 20 20 28 61 2d 63 6f 6e 66 69 67 20 20 20 28 (a-config (
dd60: 74 65 73 74 73 3a 74 65 73 74 71 75 65 75 65 2d tests:testqueue-
dd70: 67 65 74 2d 74 65 73 74 63 6f 6e 66 69 67 20 20 get-testconfig
dd80: 61 2d 72 65 63 6f 72 64 29 29 0a 09 09 20 20 20 a-record))...
dd90: 20 20 20 20 28 62 2d 63 6f 6e 66 69 67 20 20 20 (b-config
dda0: 28 74 65 73 74 73 3a 74 65 73 74 71 75 65 75 65 (tests:testqueue
ddb0: 2d 67 65 74 2d 74 65 73 74 63 6f 6e 66 69 67 20 -get-testconfig
ddc0: 20 62 2d 72 65 63 6f 72 64 29 29 0a 09 09 20 20 b-record))...
ddd0: 20 20 20 20 20 28 61 2d 72 61 77 2d 70 72 69 20 (a-raw-pri
dde0: 20 28 63 6f 6e 66 69 67 2d 6c 6f 6f 6b 75 70 20 (config-lookup
ddf0: 61 2d 63 6f 6e 66 69 67 20 22 72 65 71 75 69 72 a-config "requir
de00: 65 6d 65 6e 74 73 22 20 22 70 72 69 6f 72 69 74 ements" "priorit
de10: 79 22 29 29 0a 09 09 20 20 20 20 20 20 20 28 62 y"))... (b
de20: 2d 72 61 77 2d 70 72 69 20 20 28 63 6f 6e 66 69 -raw-pri (confi
de30: 67 2d 6c 6f 6f 6b 75 70 20 62 2d 63 6f 6e 66 69 g-lookup b-confi
de40: 67 20 22 72 65 71 75 69 72 65 6d 65 6e 74 73 22 g "requirements"
de50: 20 22 70 72 69 6f 72 69 74 79 22 29 29 0a 09 09 "priority"))...
de60: 20 20 20 20 20 20 20 28 61 2d 70 72 69 6f 72 69 (a-priori
de70: 74 79 20 28 6d 75 6e 67 65 70 72 69 6f 72 69 74 ty (mungepriorit
de80: 79 20 61 2d 72 61 77 2d 70 72 69 29 29 0a 09 09 y a-raw-pri))...
de90: 20 20 20 20 20 20 20 28 62 2d 70 72 69 6f 72 69 (b-priori
dea0: 74 79 20 28 6d 75 6e 67 65 70 72 69 6f 72 69 74 ty (mungepriorit
deb0: 79 20 62 2d 72 61 77 2d 70 72 69 29 29 29 0a 09 y b-raw-pri)))..
dec0: 09 20 20 28 74 65 73 74 73 3a 74 65 73 74 71 75 . (tests:testqu
ded0: 65 75 65 2d 73 65 74 2d 70 72 69 6f 72 69 74 79 eue-set-priority
dee0: 21 20 61 2d 72 65 63 6f 72 64 20 61 2d 70 72 69 ! a-record a-pri
def0: 6f 72 69 74 79 29 0a 09 09 20 20 28 74 65 73 74 ority)... (test
df00: 73 3a 74 65 73 74 71 75 65 75 65 2d 73 65 74 2d s:testqueue-set-
df10: 70 72 69 6f 72 69 74 79 21 20 62 2d 72 65 63 6f priority! b-reco
df20: 72 64 20 62 2d 70 72 69 6f 72 69 74 79 29 0a 09 rd b-priority)..
df30: 09 20 20 3b 3b 20 28 64 65 62 75 67 3a 70 72 69 . ;; (debug:pri
df40: 6e 74 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f nt 0 *default-lo
df50: 67 2d 70 6f 72 74 2a 20 22 61 3d 22 20 61 20 22 g-port* "a=" a "
df60: 2c 20 62 3d 22 20 62 20 22 2c 20 61 2d 77 61 69 , b=" b ", a-wai
df70: 74 6f 6e 73 3d 22 20 61 2d 77 61 69 74 6f 6e 73 tons=" a-waitons
df80: 20 22 2c 20 62 2d 77 61 69 74 6f 6e 73 3d 22 20 ", b-waitons="
df90: 62 2d 77 61 69 74 6f 6e 73 29 0a 09 09 20 20 28 b-waitons)... (
dfa0: 63 6f 6e 64 0a 09 09 20 20 20 3b 3b 20 69 73 20 cond... ;; is
dfb0: 0a 09 09 20 20 20 28 28 6d 65 6d 62 65 72 20 61 ... ((member a
dfc0: 20 62 2d 77 61 69 74 6f 6e 73 29 20 20 20 20 20 b-waitons)
dfd0: 20 20 20 20 20 3b 3b 20 69 73 20 62 20 77 61 69 ;; is b wai
dfe0: 74 69 6e 67 20 6f 6e 20 61 3f 0a 09 09 20 20 20 ting on a?...
dff0: 20 3b 3b 20 28 64 65 62 75 67 3a 70 72 69 6e 74 ;; (debug:print
e000: 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 0 *default-log-
e010: 70 6f 72 74 2a 20 22 63 61 73 65 31 22 29 0a 09 port* "case1")..
e020: 09 20 20 20 20 23 74 29 0a 09 09 20 20 20 28 28 . #t)... ((
e030: 6d 65 6d 62 65 72 20 62 20 61 2d 77 61 69 74 6f member b a-waito
e040: 6e 73 29 20 20 20 20 20 20 20 20 20 20 3b 3b 20 ns) ;;
e050: 69 73 20 61 20 77 61 69 74 69 6e 67 20 6f 6e 20 is a waiting on
e060: 62 3f 0a 09 09 20 20 20 20 3b 3b 20 28 64 65 62 b?... ;; (deb
e070: 75 67 3a 70 72 69 6e 74 20 30 20 2a 64 65 66 61 ug:print 0 *defa
e080: 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 63 ult-log-port* "c
e090: 61 73 65 32 22 29 0a 09 09 20 20 20 20 23 66 29 ase2")... #f)
e0a0: 0a 09 09 20 20 20 28 28 61 6e 64 20 28 6e 6f 74 ... ((and (not
e0b0: 20 28 6e 75 6c 6c 3f 20 61 2d 77 61 69 74 6f 6e (null? a-waiton
e0c0: 73 29 29 20 20 3b 3b 20 62 6f 74 68 20 68 61 76 s)) ;; both hav
e0d0: 65 20 77 61 69 74 6f 6e 73 20 2d 20 64 6f 20 6e e waitons - do n
e0e0: 6f 74 20 64 69 73 74 75 72 62 0a 09 09 09 20 28 ot disturb.... (
e0f0: 6e 6f 74 20 28 6e 75 6c 6c 3f 20 62 2d 77 61 69 not (null? b-wai
e100: 74 6f 6e 73 29 29 29 0a 09 09 20 20 20 20 3b 3b tons)))... ;;
e110: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 (debug:print 0
e120: 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 *default-log-por
e130: 74 2a 20 22 63 61 73 65 32 2e 31 22 29 0a 09 09 t* "case2.1")...
e140: 20 20 20 20 23 74 29 0a 09 09 20 20 20 28 28 61 #t)... ((a
e150: 6e 64 20 28 6e 75 6c 6c 3f 20 61 2d 77 61 69 74 nd (null? a-wait
e160: 6f 6e 73 29 20 20 20 20 20 20 20 20 3b 3b 20 6e ons) ;; n
e170: 6f 20 77 61 69 74 6f 6e 73 20 66 6f 72 20 61 20 o waitons for a
e180: 62 75 74 20 62 20 68 61 73 20 77 61 69 74 6f 6e but b has waiton
e190: 73 0a 09 09 09 20 28 6e 6f 74 20 28 6e 75 6c 6c s.... (not (null
e1a0: 3f 20 62 2d 77 61 69 74 6f 6e 73 29 29 29 0a 09 ? b-waitons)))..
e1b0: 09 20 20 20 20 3b 3b 20 28 64 65 62 75 67 3a 70 . ;; (debug:p
e1c0: 72 69 6e 74 20 30 20 2a 64 65 66 61 75 6c 74 2d rint 0 *default-
e1d0: 6c 6f 67 2d 70 6f 72 74 2a 20 22 63 61 73 65 33 log-port* "case3
e1e0: 22 29 0a 09 09 20 20 20 20 23 66 29 0a 09 09 20 ")... #f)...
e1f0: 20 20 28 28 61 6e 64 20 28 6e 6f 74 20 28 6e 75 ((and (not (nu
e200: 6c 6c 3f 20 61 2d 77 61 69 74 6f 6e 73 29 29 20 ll? a-waitons))
e210: 20 3b 3b 20 61 20 68 61 73 20 77 61 69 74 6f 6e ;; a has waiton
e220: 73 20 62 75 74 20 62 20 64 6f 65 73 20 6e 6f 74 s but b does not
e230: 0a 09 09 09 20 28 6e 75 6c 6c 3f 20 62 2d 77 61 .... (null? b-wa
e240: 69 74 6f 6e 73 29 29 20 0a 09 09 20 20 20 20 3b itons)) ... ;
e250: 3b 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 ; (debug:print 0
e260: 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f *default-log-po
e270: 72 74 2a 20 22 63 61 73 65 34 22 29 0a 09 09 20 rt* "case4")...
e280: 20 20 20 23 74 29 0a 09 09 20 20 20 28 28 6e 6f #t)... ((no
e290: 74 20 28 65 71 3f 20 61 2d 70 72 69 6f 72 69 74 t (eq? a-priorit
e2a0: 79 20 62 2d 70 72 69 6f 72 69 74 79 29 29 20 3b y b-priority)) ;
e2b0: 3b 20 75 73 65 0a 09 09 20 20 20 20 28 3e 20 61 ; use... (> a
e2c0: 2d 70 72 69 6f 72 69 74 79 20 62 2d 70 72 69 6f -priority b-prio
e2d0: 72 69 74 79 29 29 0a 09 09 20 20 20 28 65 6c 73 rity))... (els
e2e0: 65 0a 09 09 20 20 20 20 3b 3b 20 28 64 65 62 75 e... ;; (debu
e2f0: 67 3a 70 72 69 6e 74 20 30 20 2a 64 65 66 61 75 g:print 0 *defau
e300: 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 63 61 lt-log-port* "ca
e310: 73 65 35 22 29 0a 09 09 20 20 20 20 28 73 74 72 se5")... (str
e320: 69 6e 67 3e 3f 20 61 20 62 29 29 29 29 29 29 0a ing>? a b)))))).
e330: 09 20 20 20 20 20 0a 09 20 20 20 20 20 28 73 6f . .. (so
e340: 72 74 2d 66 6e 32 0a 09 20 20 20 20 20 20 28 6c rt-fn2.. (l
e350: 61 6d 62 64 61 20 28 61 20 62 29 0a 09 09 28 3e ambda (a b)...(>
e360: 20 28 6d 75 6e 67 65 70 72 69 6f 72 69 74 79 20 (mungepriority
e370: 28 74 65 73 74 73 3a 74 65 73 74 71 75 65 75 65 (tests:testqueue
e380: 2d 67 65 74 2d 70 72 69 6f 72 69 74 79 20 28 68 -get-priority (h
e390: 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 20 74 65 ash-table-ref te
e3a0: 73 74 2d 72 65 63 6f 72 64 73 20 61 29 29 29 0a st-records a))).
e3b0: 09 09 20 20 20 28 6d 75 6e 67 65 70 72 69 6f 72 .. (mungeprior
e3c0: 69 74 79 20 28 74 65 73 74 73 3a 74 65 73 74 71 ity (tests:testq
e3d0: 75 65 75 65 2d 67 65 74 2d 70 72 69 6f 72 69 74 ueue-get-priorit
e3e0: 79 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 y (hash-table-re
e3f0: 66 20 74 65 73 74 2d 72 65 63 6f 72 64 73 20 62 f test-records b
e400: 29 29 29 29 29 29 29 0a 09 3b 3b 20 28 6c 65 74 )))))))..;; (let
e410: 20 28 28 64 6f 74 2d 72 65 73 20 28 74 65 73 74 ((dot-res (test
e420: 73 3a 72 75 6e 2d 64 6f 74 20 28 74 65 73 74 73 s:run-dot (tests
e430: 3a 74 65 73 74 73 2d 3e 64 6f 74 20 74 65 73 74 :tests->dot test
e440: 2d 72 65 63 6f 72 64 73 29 20 22 70 6c 61 69 6e -records) "plain
e450: 22 29 29 29 0a 09 3b 3b 20 20 20 28 64 65 62 75 ")))..;; (debu
e460: 67 3a 70 72 69 6e 74 20 22 64 6f 74 2d 72 65 73 g:print "dot-res
e470: 3d 22 20 64 6f 74 2d 72 65 73 29 29 0a 09 3b 3b =" dot-res))..;;
e480: 20 28 6c 65 74 20 28 28 64 61 74 61 20 28 6d 61 (let ((data (ma
e490: 70 20 63 64 72 20 28 66 69 6c 74 65 72 0a 09 3b p cdr (filter..;
e4a0: 3b 20 20 20 20 20 09 09 20 20 28 6c 61 6d 62 64 ; .. (lambd
e4b0: 61 20 28 78 29 28 65 71 75 61 6c 3f 20 22 6e 6f a (x)(equal? "no
e4c0: 64 65 22 20 28 63 61 72 20 78 29 29 29 0a 09 3b de" (car x)))..;
e4d0: 3b 20 20 20 20 20 09 09 20 20 28 6d 61 70 20 73 ; .. (map s
e4e0: 74 72 69 6e 67 2d 73 70 6c 69 74 20 28 74 65 73 tring-split (tes
e4f0: 74 73 3a 65 61 73 79 2d 64 6f 74 20 74 65 73 74 ts:easy-dot test
e500: 2d 72 65 63 6f 72 64 73 20 22 70 6c 61 69 6e 22 -records "plain"
e510: 29 29 29 29 29 29 0a 09 3b 3b 20 20 20 28 6d 61 ))))))..;; (ma
e520: 70 20 63 61 72 20 28 73 6f 72 74 20 64 61 74 61 p car (sort data
e530: 20 28 6c 61 6d 62 64 61 20 28 61 20 62 29 0a 09 (lambda (a b)..
e540: 3b 3b 20 20 20 20 20 09 09 20 20 20 20 28 3e 20 ;; .. (>
e550: 28 73 74 72 69 6e 67 2d 3e 6e 75 6d 62 65 72 20 (string->number
e560: 28 63 61 64 64 72 20 61 29 29 28 73 74 72 69 6e (caddr a))(strin
e570: 67 2d 3e 6e 75 6d 62 65 72 20 28 63 61 64 64 72 g->number (caddr
e580: 20 62 29 29 29 29 29 29 29 0a 09 3b 3b 20 29 29 b)))))))..;; ))
e590: 0a 09 28 73 6f 72 74 20 61 6c 6c 2d 74 65 73 74 ..(sort all-test
e5a0: 73 20 73 6f 72 74 2d 66 6e 31 29 29 29 29 20 3b s sort-fn1)))) ;
e5b0: 3b 20 61 76 6f 69 64 20 64 65 61 6c 69 6e 67 20 ; avoid dealing
e5c0: 77 69 74 68 20 64 65 6c 65 74 65 64 20 74 65 73 with deleted tes
e5d0: 74 73 2c 20 6c 6f 6f 6b 20 61 74 20 74 68 65 20 ts, look at the
e5e0: 68 61 73 68 20 74 61 62 6c 65 0a 0a 28 64 65 66 hash table..(def
e5f0: 69 6e 65 20 28 74 65 73 74 73 3a 65 61 73 79 2d ine (tests:easy-
e600: 64 6f 74 20 74 65 73 74 2d 72 65 63 6f 72 64 73 dot test-records
e610: 20 6f 75 74 74 79 70 65 29 0a 20 20 28 6c 65 74 outtype). (let
e620: 2d 76 61 6c 75 65 73 20 28 28 28 66 64 20 74 65 -values (((fd te
e630: 6d 70 2d 70 61 74 68 29 20 28 66 69 6c 65 2d 6d mp-path) (file-m
e640: 6b 73 74 65 6d 70 20 28 63 6f 6e 63 20 22 2f 74 kstemp (conc "/t
e650: 6d 70 2f 22 20 28 63 75 72 72 65 6e 74 2d 75 73 mp/" (current-us
e660: 65 72 2d 6e 61 6d 65 29 20 22 2e 58 58 58 58 58 er-name) ".XXXXX
e670: 58 22 29 29 29 29 0a 20 20 20 20 28 6c 65 74 20 X")))). (let
e680: 28 28 61 6c 6c 2d 74 65 73 74 6e 61 6d 65 73 20 ((all-testnames
e690: 28 68 61 73 68 2d 74 61 62 6c 65 2d 6b 65 79 73 (hash-table-keys
e6a0: 20 74 65 73 74 2d 72 65 63 6f 72 64 73 29 29 0a test-records)).
e6b0: 09 20 20 28 74 65 6d 70 2d 70 6f 72 74 20 20 20 . (temp-port
e6c0: 20 20 28 6f 70 65 6e 2d 6f 75 74 70 75 74 2d 66 (open-output-f
e6d0: 69 6c 65 2a 20 66 64 29 29 29 0a 20 20 20 20 20 ile* fd))).
e6e0: 20 3b 3b 20 28 66 6f 72 6d 61 74 20 74 65 6d 70 ;; (format temp
e6f0: 2d 70 6f 72 74 20 22 54 68 69 73 20 66 69 6c 65 -port "This file
e700: 20 69 73 20 7e 41 2e 7e 25 22 20 74 65 6d 70 2d is ~A.~%" temp-
e710: 70 61 74 68 29 0a 20 20 20 20 20 20 28 66 6f 72 path). (for
e720: 6d 61 74 20 74 65 6d 70 2d 70 6f 72 74 20 22 64 mat temp-port "d
e730: 69 67 72 61 70 68 20 74 65 73 74 73 20 7b 5c 6e igraph tests {\n
e740: 22 29 0a 20 20 20 20 20 20 28 66 6f 72 6d 61 74 "). (format
e750: 20 74 65 6d 70 2d 70 6f 72 74 20 22 20 20 73 69 temp-port " si
e760: 7a 65 3d 34 2c 38 5c 6e 22 29 0a 20 20 20 20 20 ze=4,8\n").
e770: 20 3b 3b 20 28 66 6f 72 6d 61 74 20 74 65 6d 70 ;; (format temp
e780: 2d 70 6f 72 74 20 22 20 20 20 73 70 6c 69 6e 65 -port " spline
e790: 73 3d 6e 6f 6e 65 5c 6e 22 29 0a 20 20 20 20 20 s=none\n").
e7a0: 20 28 66 6f 72 2d 65 61 63 68 0a 20 20 20 20 20 (for-each.
e7b0: 20 20 28 6c 61 6d 62 64 61 20 28 74 65 73 74 6e (lambda (testn
e7c0: 61 6d 65 29 0a 09 20 28 6c 65 74 2a 20 28 28 74 ame).. (let* ((t
e7d0: 65 73 74 72 65 63 20 28 68 61 73 68 2d 74 61 62 estrec (hash-tab
e7e0: 6c 65 2d 72 65 66 20 74 65 73 74 2d 72 65 63 6f le-ref test-reco
e7f0: 72 64 73 20 74 65 73 74 6e 61 6d 65 29 29 0a 09 rds testname))..
e800: 09 28 77 61 69 74 6f 6e 73 20 28 6f 72 20 28 74 .(waitons (or (t
e810: 65 73 74 73 3a 74 65 73 74 71 75 65 75 65 2d 67 ests:testqueue-g
e820: 65 74 2d 77 61 69 74 6f 6e 73 20 74 65 73 74 72 et-waitons testr
e830: 65 63 29 20 27 28 29 29 29 29 0a 09 20 20 20 28 ec) '()))).. (
e840: 66 6f 72 2d 65 61 63 68 0a 09 20 20 20 20 28 6c for-each.. (l
e850: 61 6d 62 64 61 20 28 77 61 69 74 6f 6e 29 0a 09 ambda (waiton)..
e860: 20 20 20 20 20 20 28 66 6f 72 6d 61 74 20 74 65 (format te
e870: 6d 70 2d 70 6f 72 74 20 28 63 6f 6e 63 20 22 20 mp-port (conc "
e880: 20 20 22 20 77 61 69 74 6f 6e 20 22 20 2d 3e 20 " waiton " ->
e890: 22 20 74 65 73 74 6e 61 6d 65 20 22 20 5b 73 70 " testname " [sp
e8a0: 6c 69 6e 65 73 3d 6f 72 74 68 6f 5d 5c 6e 22 29 lines=ortho]\n")
e8b0: 29 29 0a 09 20 20 20 20 77 61 69 74 6f 6e 73 29 )).. waitons)
e8c0: 29 29 0a 20 20 20 20 20 20 20 61 6c 6c 2d 74 65 )). all-te
e8d0: 73 74 6e 61 6d 65 73 29 0a 20 20 20 20 20 20 28 stnames). (
e8e0: 66 6f 72 6d 61 74 20 74 65 6d 70 2d 70 6f 72 74 format temp-port
e8f0: 20 22 7d 5c 6e 22 29 0a 20 20 20 20 20 20 28 63 "}\n"). (c
e900: 6c 6f 73 65 2d 6f 75 74 70 75 74 2d 70 6f 72 74 lose-output-port
e910: 20 74 65 6d 70 2d 70 6f 72 74 29 0a 20 20 20 20 temp-port).
e920: 20 20 28 77 69 74 68 2d 69 6e 70 75 74 2d 66 72 (with-input-fr
e930: 6f 6d 2d 70 69 70 65 0a 20 20 20 20 20 20 20 28 om-pipe. (
e940: 63 6f 6e 63 20 22 65 6e 76 20 2d 69 20 50 41 54 conc "env -i PAT
e950: 48 3d 24 50 41 54 48 20 64 6f 74 20 2d 54 22 20 H=$PATH dot -T"
e960: 6f 75 74 74 79 70 65 20 22 20 3c 20 22 20 74 65 outtype " < " te
e970: 6d 70 2d 70 61 74 68 29 0a 20 20 20 20 20 20 20 mp-path).
e980: 28 6c 61 6d 62 64 61 20 28 29 0a 09 20 28 6c 65 (lambda ().. (le
e990: 74 20 28 28 72 65 73 20 28 72 65 61 64 2d 6c 69 t ((res (read-li
e9a0: 6e 65 73 29 29 29 0a 09 20 20 20 3b 3b 20 28 64 nes))).. ;; (d
e9b0: 65 6c 65 74 65 2d 66 69 6c 65 20 74 65 6d 70 2d elete-file temp-
e9c0: 70 61 74 68 29 0a 09 20 20 20 72 65 73 29 29 29 path).. res)))
e9d0: 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 74 65 )))..(define (te
e9e0: 73 74 73 3a 77 72 69 74 65 2d 64 6f 74 2d 66 69 sts:write-dot-fi
e9f0: 6c 65 20 74 65 73 74 2d 72 65 63 6f 72 64 73 20 le test-records
ea00: 66 6e 61 6d 65 20 73 69 7a 65 78 20 73 69 7a 65 fname sizex size
ea10: 79 29 0a 20 20 28 69 66 20 28 66 69 6c 65 2d 77 y). (if (file-w
ea20: 72 69 74 65 2d 61 63 63 65 73 73 3f 20 28 70 61 rite-access? (pa
ea30: 74 68 6e 61 6d 65 2d 64 69 72 65 63 74 6f 72 79 thname-directory
ea40: 20 66 6e 61 6d 65 29 29 0a 20 20 20 20 20 20 28 fname)). (
ea50: 77 69 74 68 2d 6f 75 74 70 75 74 2d 74 6f 2d 66 with-output-to-f
ea60: 69 6c 65 20 66 6e 61 6d 65 0a 09 28 6c 61 6d 62 ile fname..(lamb
ea70: 64 61 20 28 29 0a 09 20 20 28 6d 61 70 20 70 72 da ().. (map pr
ea80: 69 6e 74 20 28 74 65 73 74 73 3a 74 65 73 74 73 int (tests:tests
ea90: 2d 3e 64 6f 74 20 74 65 73 74 2d 72 65 63 6f 72 ->dot test-recor
eaa0: 64 73 20 73 69 7a 65 78 20 73 69 7a 65 79 29 29 ds sizex sizey))
eab0: 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 74 ))))..(define (t
eac0: 65 73 74 73 3a 74 65 73 74 73 2d 3e 64 6f 74 20 ests:tests->dot
ead0: 74 65 73 74 2d 72 65 63 6f 72 64 73 20 73 69 7a test-records siz
eae0: 65 78 20 73 69 7a 65 79 29 0a 20 20 28 6c 65 74 ex sizey). (let
eaf0: 20 28 28 61 6c 6c 2d 74 65 73 74 6e 61 6d 65 73 ((all-testnames
eb00: 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 6b 65 79 (hash-table-key
eb10: 73 20 74 65 73 74 2d 72 65 63 6f 72 64 73 29 29 s test-records))
eb20: 29 0a 20 20 20 20 28 69 66 20 28 6e 75 6c 6c 3f ). (if (null?
eb30: 20 61 6c 6c 2d 74 65 73 74 6e 61 6d 65 73 29 0a all-testnames).
eb40: 09 27 28 29 0a 09 28 6c 65 74 20 6c 6f 6f 70 20 .'()..(let loop
eb50: 28 28 68 65 64 20 28 63 61 72 20 61 6c 6c 2d 74 ((hed (car all-t
eb60: 65 73 74 6e 61 6d 65 73 29 29 0a 09 09 20 20 20 estnames))...
eb70: 28 74 61 6c 20 28 63 64 72 20 61 6c 6c 2d 74 65 (tal (cdr all-te
eb80: 73 74 6e 61 6d 65 73 29 29 0a 09 09 20 20 20 28 stnames))... (
eb90: 72 65 73 20 28 6c 69 73 74 20 22 64 69 67 72 61 res (list "digra
eba0: 70 68 20 74 65 73 74 73 20 7b 22 0a 09 09 09 20 ph tests {"....
ebb0: 20 20 20 20 20 28 63 6f 6e 63 20 22 20 73 69 7a (conc " siz
ebc0: 65 3d 5c 22 22 20 28 6f 72 20 73 69 7a 65 78 20 e=\"" (or sizex
ebd0: 31 31 29 20 22 2c 22 20 28 6f 72 20 73 69 7a 65 11) "," (or size
ebe0: 79 20 31 31 29 20 22 5c 22 3b 22 29 0a 09 09 09 y 11) "\";")....
ebf0: 20 20 20 20 20 20 22 20 72 61 74 69 6f 3d 30 2e " ratio=0.
ec00: 39 35 3b 22 0a 09 09 09 20 20 20 20 20 20 29 29 95;".... ))
ec10: 29 0a 09 20 20 28 6c 65 74 2a 20 28 28 74 65 73 ).. (let* ((tes
ec20: 74 72 65 63 20 28 68 61 73 68 2d 74 61 62 6c 65 trec (hash-table
ec30: 2d 72 65 66 20 74 65 73 74 2d 72 65 63 6f 72 64 -ref test-record
ec40: 73 20 68 65 64 29 29 0a 09 09 20 28 77 61 69 74 s hed))... (wait
ec50: 6f 6e 73 20 28 6f 72 20 28 74 65 73 74 73 3a 74 ons (or (tests:t
ec60: 65 73 74 71 75 65 75 65 2d 67 65 74 2d 77 61 69 estqueue-get-wai
ec70: 74 6f 6e 73 20 74 65 73 74 72 65 63 29 20 27 28 tons testrec) '(
ec80: 29 29 29 0a 09 09 20 28 6e 65 77 72 65 73 20 20 )))... (newres
ec90: 28 61 70 70 65 6e 64 20 72 65 73 0a 09 09 09 09 (append res.....
eca0: 20 20 28 69 66 20 28 6e 75 6c 6c 3f 20 77 61 69 (if (null? wai
ecb0: 74 6f 6e 73 29 0a 09 09 09 09 20 20 20 20 20 20 tons).....
ecc0: 28 6c 69 73 74 20 28 63 6f 6e 63 20 22 20 20 20 (list (conc "
ecd0: 5c 22 22 20 68 65 64 20 22 5c 22 20 5b 73 68 61 \"" hed "\" [sha
ece0: 70 65 3d 62 6f 78 5d 3b 22 29 29 0a 09 09 09 09 pe=box];")).....
ecf0: 20 20 20 20 20 20 28 6d 61 70 20 28 6c 61 6d 62 (map (lamb
ed00: 64 61 20 28 77 61 69 74 6f 6e 29 0a 09 09 09 09 da (waiton).....
ed10: 09 20 20 20 20 20 28 63 6f 6e 63 20 22 20 20 20 . (conc "
ed20: 5c 22 22 20 77 61 69 74 6f 6e 20 22 5c 22 20 2d \"" waiton "\" -
ed30: 3e 20 5c 22 22 20 68 65 64 20 22 5c 22 20 5b 73 > \"" hed "\" [s
ed40: 68 61 70 65 3d 62 6f 78 5d 3b 22 29 29 0a 09 09 hape=box];"))...
ed50: 09 09 09 20 20 20 77 61 69 74 6f 6e 73 29 0a 09 ... waitons)..
ed60: 09 09 09 20 20 20 20 20 20 29 29 29 29 0a 09 20 ... ))))..
ed70: 20 20 20 28 69 66 20 28 6e 75 6c 6c 3f 20 74 61 (if (null? ta
ed80: 6c 29 0a 09 09 28 61 70 70 65 6e 64 20 6e 65 77 l)...(append new
ed90: 72 65 73 20 28 6c 69 73 74 20 22 7d 22 29 29 0a res (list "}")).
eda0: 09 09 28 6c 6f 6f 70 20 28 63 61 72 20 74 61 6c ..(loop (car tal
edb0: 29 28 63 64 72 20 74 61 6c 29 20 6e 65 77 72 65 )(cdr tal) newre
edc0: 73 29 0a 09 09 29 29 29 29 29 29 0a 0a 3b 3b 20 s)...))))))..;;
edd0: 28 74 65 73 74 73 3a 72 75 6e 2d 64 6f 74 20 28 (tests:run-dot (
ede0: 6c 69 73 74 20 22 64 69 67 72 61 70 68 20 74 65 list "digraph te
edf0: 73 74 73 20 7b 22 20 22 61 20 2d 3e 20 62 22 20 sts {" "a -> b"
ee00: 22 7d 22 29 20 22 70 6c 61 69 6e 22 29 0a 0a 28 "}") "plain")..(
ee10: 64 65 66 69 6e 65 20 28 74 65 73 74 73 3a 72 75 define (tests:ru
ee20: 6e 2d 64 6f 74 20 69 6e 64 61 74 20 6f 75 74 74 n-dot indat outt
ee30: 79 70 65 29 20 3b 3b 20 6f 75 74 74 79 70 65 20 ype) ;; outtype
ee40: 69 73 20 70 6c 61 69 6e 2c 20 66 69 67 2c 20 64 is plain, fig, d
ee50: 6f 74 2c 20 65 74 63 2e 20 68 74 74 70 3a 2f 2f ot, etc. http://
ee60: 77 77 77 2e 67 72 61 70 68 76 69 7a 2e 6f 72 67 www.graphviz.org
ee70: 2f 63 6f 6e 74 65 6e 74 2f 6f 75 74 70 75 74 2d /content/output-
ee80: 66 6f 72 6d 61 74 73 0a 20 20 28 6c 65 74 2d 76 formats. (let-v
ee90: 61 6c 75 65 73 20 28 28 28 69 6e 70 20 6f 75 70 alues (((inp oup
eea0: 20 70 69 64 29 28 70 72 6f 63 65 73 73 20 22 65 pid)(process "e
eeb0: 6e 76 20 2d 69 20 50 41 54 48 3d 24 50 41 54 48 nv -i PATH=$PATH
eec0: 20 64 6f 74 22 20 28 6c 69 73 74 20 22 2d 54 22 dot" (list "-T"
eed0: 20 6f 75 74 74 79 70 65 29 29 29 29 0a 20 20 20 outtype)))).
eee0: 20 28 77 69 74 68 2d 6f 75 74 70 75 74 2d 74 6f (with-output-to
eef0: 2d 70 6f 72 74 20 6f 75 70 0a 20 20 20 20 20 20 -port oup.
ef00: 28 6c 61 6d 62 64 61 20 28 29 0a 09 28 6d 61 70 (lambda ()..(map
ef10: 20 70 72 69 6e 74 20 69 6e 64 61 74 29 29 29 0a print indat))).
ef20: 20 20 20 20 28 63 6c 6f 73 65 2d 6f 75 74 70 75 (close-outpu
ef30: 74 2d 70 6f 72 74 20 6f 75 70 29 0a 20 20 20 20 t-port oup).
ef40: 28 6c 65 74 20 28 28 72 65 73 20 28 77 69 74 68 (let ((res (with
ef50: 2d 69 6e 70 75 74 2d 66 72 6f 6d 2d 70 6f 72 74 -input-from-port
ef60: 20 69 6e 70 0a 09 09 20 28 6c 61 6d 62 64 61 20 inp... (lambda
ef70: 28 29 0a 09 09 20 20 20 28 72 65 61 64 2d 6c 69 ()... (read-li
ef80: 6e 65 73 29 29 29 29 29 0a 20 20 20 20 20 20 28 nes))))). (
ef90: 63 6c 6f 73 65 2d 69 6e 70 75 74 2d 70 6f 72 74 close-input-port
efa0: 20 69 6e 70 29 0a 20 20 20 20 20 20 72 65 73 29 inp). res)
efb0: 29 29 0a 0a 3b 3b 20 72 65 61 64 20 64 61 74 61 ))..;; read data
efc0: 20 66 72 6f 6d 20 74 6d 70 20 66 69 6c 65 20 6f from tmp file o
efd0: 72 20 63 72 65 61 74 65 20 69 66 20 6e 6f 74 20 r create if not
efe0: 65 78 69 73 74 73 0a 3b 3b 20 69 66 20 65 78 69 exists.;; if exi
eff0: 73 74 73 20 72 65 67 65 6e 20 69 6e 20 62 61 63 sts regen in bac
f000: 6b 67 72 6f 75 6e 64 0a 3b 3b 0a 28 64 65 66 69 kground.;;.(defi
f010: 6e 65 20 28 74 65 73 74 73 3a 6c 61 7a 79 2d 64 ne (tests:lazy-d
f020: 6f 74 20 74 65 73 74 72 65 63 6f 72 64 73 20 20 ot testrecords
f030: 6f 75 74 74 79 70 65 20 73 69 7a 65 78 20 73 69 outtype sizex si
f040: 7a 65 79 29 0a 20 20 28 6c 65 74 20 28 28 64 66 zey). (let ((df
f050: 69 6c 65 20 28 63 6f 6e 63 20 22 2f 74 6d 70 2f ile (conc "/tmp/
f060: 2e 22 20 28 63 75 72 72 65 6e 74 2d 75 73 65 72 ." (current-user
f070: 2d 6e 61 6d 65 29 20 22 2d 22 20 28 73 65 72 76 -name) "-" (serv
f080: 65 72 3a 6d 6b 2d 73 69 67 6e 61 74 75 72 65 29 er:mk-signature)
f090: 20 22 2e 64 6f 74 22 29 29 0a 09 28 66 6e 61 6d ".dot"))..(fnam
f0a0: 65 20 28 63 6f 6e 63 20 22 2f 74 6d 70 2f 2e 22 e (conc "/tmp/."
f0b0: 20 28 63 75 72 72 65 6e 74 2d 75 73 65 72 2d 6e (current-user-n
f0c0: 61 6d 65 29 20 22 2d 22 20 28 73 65 72 76 65 72 ame) "-" (server
f0d0: 3a 6d 6b 2d 73 69 67 6e 61 74 75 72 65 29 20 22 :mk-signature) "
f0e0: 2e 64 6f 74 64 61 74 22 29 29 29 0a 20 20 20 20 .dotdat"))).
f0f0: 28 74 65 73 74 73 3a 77 72 69 74 65 2d 64 6f 74 (tests:write-dot
f100: 2d 66 69 6c 65 20 74 65 73 74 72 65 63 6f 72 64 -file testrecord
f110: 73 20 64 66 69 6c 65 20 73 69 7a 65 78 20 73 69 s dfile sizex si
f120: 7a 65 79 29 0a 20 20 20 20 28 69 66 20 28 63 6f zey). (if (co
f130: 6d 6d 6f 6e 3a 66 69 6c 65 2d 65 78 69 73 74 73 mmon:file-exists
f140: 3f 20 66 6e 61 6d 65 29 0a 09 28 6c 65 74 20 28 ? fname)..(let (
f150: 28 72 65 73 20 28 77 69 74 68 2d 69 6e 70 75 74 (res (with-input
f160: 2d 66 72 6f 6d 2d 66 69 6c 65 20 66 6e 61 6d 65 -from-file fname
f170: 0a 09 09 20 20 20 20 20 28 6c 61 6d 62 64 61 20 ... (lambda
f180: 28 29 0a 09 09 20 20 20 20 20 20 20 28 72 65 61 ()... (rea
f190: 64 2d 6c 69 6e 65 73 29 29 29 29 29 0a 09 20 20 d-lines)))))..
f1a0: 28 73 79 73 74 65 6d 20 28 63 6f 6e 63 20 22 65 (system (conc "e
f1b0: 6e 76 20 2d 69 20 50 41 54 48 3d 24 50 41 54 48 nv -i PATH=$PATH
f1c0: 20 64 6f 74 20 2d 54 20 22 20 6f 75 74 74 79 70 dot -T " outtyp
f1d0: 65 20 22 20 3c 20 22 20 64 66 69 6c 65 20 22 20 e " < " dfile "
f1e0: 3e 20 22 20 66 6e 61 6d 65 20 22 26 22 29 29 0a > " fname "&")).
f1f0: 09 20 20 72 65 73 29 0a 09 28 62 65 67 69 6e 0a . res)..(begin.
f200: 09 20 20 28 73 79 73 74 65 6d 20 28 63 6f 6e 63 . (system (conc
f210: 20 22 65 6e 76 20 2d 69 20 50 41 54 48 3d 24 50 "env -i PATH=$P
f220: 41 54 48 20 64 6f 74 20 2d 54 20 22 20 6f 75 74 ATH dot -T " out
f230: 74 79 70 65 20 22 20 3c 20 22 20 64 66 69 6c 65 type " < " dfile
f240: 20 22 20 3e 20 22 20 66 6e 61 6d 65 29 29 0a 09 " > " fname))..
f250: 20 20 28 77 69 74 68 2d 69 6e 70 75 74 2d 66 72 (with-input-fr
f260: 6f 6d 2d 66 69 6c 65 20 66 6e 61 6d 65 0a 09 20 om-file fname..
f270: 20 20 20 28 6c 61 6d 62 64 61 20 28 29 0a 09 20 (lambda ()..
f280: 20 20 20 20 20 28 72 65 61 64 2d 6c 69 6e 65 73 (read-lines
f290: 29 29 29 29 29 29 29 0a 09 20 20 0a 0a 3b 3b 20 ))))))).. ..;;
f2a0: 66 6f 72 20 65 61 63 68 20 74 65 73 74 3a 0a 3b for each test:.;
f2b0: 3b 20 20 20 0a 28 64 65 66 69 6e 65 20 28 74 65 ; .(define (te
f2c0: 73 74 73 3a 66 69 6c 74 65 72 2d 6e 6f 6e 2d 72 sts:filter-non-r
f2d0: 75 6e 6e 61 62 6c 65 20 72 75 6e 2d 69 64 20 74 unnable run-id t
f2e0: 65 73 74 6b 65 79 6e 61 6d 65 73 20 74 65 73 74 estkeynames test
f2f0: 72 65 63 6f 72 64 73 68 61 73 68 29 0a 20 20 28 recordshash). (
f300: 6c 65 74 20 28 28 72 75 6e 6e 61 62 6c 65 73 20 let ((runnables
f310: 27 28 29 29 29 0a 20 20 20 20 28 66 6f 72 2d 65 '())). (for-e
f320: 61 63 68 0a 20 20 20 20 20 28 6c 61 6d 62 64 61 ach. (lambda
f330: 20 28 74 65 73 74 6b 65 79 6e 61 6d 65 29 0a 20 (testkeyname).
f340: 20 20 20 20 20 20 28 6c 65 74 2a 20 28 28 74 65 (let* ((te
f350: 73 74 2d 72 65 63 6f 72 64 20 28 68 61 73 68 2d st-record (hash-
f360: 74 61 62 6c 65 2d 72 65 66 20 74 65 73 74 72 65 table-ref testre
f370: 63 6f 72 64 73 68 61 73 68 20 74 65 73 74 6b 65 cordshash testke
f380: 79 6e 61 6d 65 29 29 0a 09 20 20 20 20 20 20 28 yname)).. (
f390: 74 65 73 74 2d 6e 61 6d 65 20 20 20 28 74 65 73 test-name (tes
f3a0: 74 73 3a 74 65 73 74 71 75 65 75 65 2d 67 65 74 ts:testqueue-get
f3b0: 2d 74 65 73 74 6e 61 6d 65 20 20 74 65 73 74 2d -testname test-
f3c0: 72 65 63 6f 72 64 29 29 0a 09 20 20 20 20 20 20 record))..
f3d0: 28 69 74 65 6d 64 61 74 20 20 20 20 20 28 74 65 (itemdat (te
f3e0: 73 74 73 3a 74 65 73 74 71 75 65 75 65 2d 67 65 sts:testqueue-ge
f3f0: 74 2d 69 74 65 6d 64 61 74 20 20 20 74 65 73 74 t-itemdat test
f400: 2d 72 65 63 6f 72 64 29 29 0a 09 20 20 20 20 20 -record))..
f410: 20 28 69 74 65 6d 2d 70 61 74 68 20 20 20 28 74 (item-path (t
f420: 65 73 74 73 3a 74 65 73 74 71 75 65 75 65 2d 67 ests:testqueue-g
f430: 65 74 2d 69 74 65 6d 5f 70 61 74 68 20 74 65 73 et-item_path tes
f440: 74 2d 72 65 63 6f 72 64 29 29 0a 09 20 20 20 20 t-record))..
f450: 20 20 28 77 61 69 74 6f 6e 73 20 20 20 20 20 28 (waitons (
f460: 74 65 73 74 73 3a 74 65 73 74 71 75 65 75 65 2d tests:testqueue-
f470: 67 65 74 2d 77 61 69 74 6f 6e 73 20 20 20 74 65 get-waitons te
f480: 73 74 2d 72 65 63 6f 72 64 29 29 0a 09 20 20 20 st-record))..
f490: 20 20 20 28 6b 65 65 70 2d 74 65 73 74 20 20 20 (keep-test
f4a0: 23 74 29 0a 09 20 20 20 20 20 20 28 74 65 73 74 #t).. (test
f4b0: 2d 69 64 20 20 20 20 20 28 72 6d 74 3a 67 65 74 -id (rmt:get
f4c0: 2d 74 65 73 74 2d 69 64 20 72 75 6e 2d 69 64 20 -test-id run-id
f4d0: 74 65 73 74 2d 6e 61 6d 65 20 69 74 65 6d 2d 70 test-name item-p
f4e0: 61 74 68 29 29 0a 09 20 20 20 20 20 20 28 74 64 ath)).. (td
f4f0: 61 74 20 20 20 20 20 20 20 20 28 72 6d 74 3a 67 at (rmt:g
f500: 65 74 2d 74 65 73 74 69 6e 66 6f 2d 73 74 61 74 et-testinfo-stat
f510: 65 2d 73 74 61 74 75 73 20 72 75 6e 2d 69 64 20 e-status run-id
f520: 74 65 73 74 2d 69 64 29 29 29 20 3b 3b 20 28 63 test-id))) ;; (c
f530: 64 62 3a 67 65 74 2d 74 65 73 74 2d 69 6e 66 6f db:get-test-info
f540: 2d 62 79 2d 69 64 20 2a 72 75 6e 72 65 6d 6f 74 -by-id *runremot
f550: 65 2a 20 74 65 73 74 2d 69 64 29 29 29 0a 09 20 e* test-id)))..
f560: 28 69 66 20 74 64 61 74 0a 09 20 20 20 20 20 28 (if tdat.. (
f570: 62 65 67 69 6e 0a 09 20 20 20 20 20 20 20 3b 3b begin.. ;;
f580: 20 4c 6f 6f 6b 20 61 74 20 74 68 65 20 74 65 73 Look at the tes
f590: 74 20 73 74 61 74 65 20 61 6e 64 20 73 74 61 74 t state and stat
f5a0: 75 73 0a 09 20 20 20 20 20 20 20 28 69 66 20 28 us.. (if (
f5b0: 6f 72 20 28 61 6e 64 20 28 6d 65 6d 62 65 72 20 or (and (member
f5c0: 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 73 74 61 (db:test-get-sta
f5d0: 74 75 73 20 74 64 61 74 29 20 0a 09 09 09 09 20 tus tdat) .....
f5e0: 20 20 20 27 28 22 50 41 53 53 22 20 22 57 41 52 '("PASS" "WAR
f5f0: 4e 22 20 22 57 41 49 56 45 44 22 20 22 43 48 45 N" "WAIVED" "CHE
f600: 43 4b 22 20 22 53 4b 49 50 22 29 29 0a 09 09 09 CK" "SKIP"))....
f610: 20 20 20 20 28 65 71 75 61 6c 3f 20 28 64 62 3a (equal? (db:
f620: 74 65 73 74 2d 67 65 74 2d 73 74 61 74 65 20 74 test-get-state t
f630: 64 61 74 29 20 22 43 4f 4d 50 4c 45 54 45 44 22 dat) "COMPLETED"
f640: 29 29 0a 09 09 20 20 20 20 20 20 20 28 6d 65 6d ))... (mem
f650: 62 65 72 20 28 64 62 3a 74 65 73 74 2d 67 65 74 ber (db:test-get
f660: 2d 73 74 61 74 65 20 74 64 61 74 29 0a 09 09 09 -state tdat)....
f670: 09 20 20 20 20 27 28 22 49 4e 43 4f 4d 50 4c 45 . '("INCOMPLE
f680: 54 45 22 20 22 4b 49 4c 4c 45 44 22 29 29 29 0a TE" "KILLED"))).
f690: 09 09 20 20 20 28 73 65 74 21 20 6b 65 65 70 2d .. (set! keep-
f6a0: 74 65 73 74 20 23 66 29 29 0a 0a 09 20 20 20 20 test #f))...
f6b0: 20 20 20 3b 3b 20 65 78 61 6d 69 6e 65 20 77 61 ;; examine wa
f6c0: 69 74 6f 6e 73 20 66 6f 72 20 61 6e 79 20 66 61 itons for any fa
f6d0: 69 6c 73 2e 20 49 66 20 69 74 20 69 73 20 46 41 ils. If it is FA
f6e0: 49 4c 20 6f 72 20 49 4e 43 4f 4d 50 4c 45 54 45 IL or INCOMPLETE
f6f0: 20 74 68 65 6e 20 65 6c 69 6d 69 6e 61 74 65 20 then eliminate
f700: 74 68 69 73 20 74 65 73 74 0a 09 20 20 20 20 20 this test..
f710: 20 20 3b 3b 20 66 72 6f 6d 20 74 68 65 20 72 75 ;; from the ru
f720: 6e 6e 61 62 6c 65 20 6c 69 73 74 0a 09 20 20 20 nnable list..
f730: 20 20 20 20 28 69 66 20 6b 65 65 70 2d 74 65 73 (if keep-tes
f740: 74 0a 09 09 20 20 20 28 66 6f 72 2d 65 61 63 68 t... (for-each
f750: 20 28 6c 61 6d 62 64 61 20 28 77 61 69 74 6f 6e (lambda (waiton
f760: 29 0a 09 09 09 20 20 20 20 20 20 20 3b 3b 20 66 ).... ;; f
f770: 6f 72 20 6e 6f 77 20 77 65 20 61 72 65 20 77 61 or now we are wa
f780: 69 74 69 6e 67 20 6f 6e 6c 79 20 6f 6e 20 74 68 iting only on th
f790: 65 20 70 61 72 65 6e 74 20 74 65 73 74 0a 09 09 e parent test...
f7a0: 09 20 20 20 20 20 20 20 28 6c 65 74 2a 20 28 28 . (let* ((
f7b0: 70 61 72 65 6e 74 2d 74 65 73 74 2d 69 64 20 28 parent-test-id (
f7c0: 72 6d 74 3a 67 65 74 2d 74 65 73 74 2d 69 64 20 rmt:get-test-id
f7d0: 72 75 6e 2d 69 64 20 77 61 69 74 6f 6e 20 22 22 run-id waiton ""
f7e0: 29 29 0a 09 09 09 09 20 20 20 20 20 20 28 77 74 ))..... (wt
f7f0: 64 61 74 20 20 20 20 20 20 20 20 20 20 28 72 6d dat (rm
f800: 74 3a 67 65 74 2d 74 65 73 74 69 6e 66 6f 2d 73 t:get-testinfo-s
f810: 74 61 74 65 2d 73 74 61 74 75 73 20 72 75 6e 2d tate-status run-
f820: 69 64 20 74 65 73 74 2d 69 64 29 29 29 20 3b 3b id test-id))) ;;
f830: 20 28 63 64 62 3a 67 65 74 2d 74 65 73 74 2d 69 (cdb:get-test-i
f840: 6e 66 6f 2d 62 79 2d 69 64 20 2a 72 75 6e 72 65 nfo-by-id *runre
f850: 6d 6f 74 65 2a 20 74 65 73 74 2d 69 64 29 29 29 mote* test-id)))
f860: 0a 09 09 09 09 20 28 69 66 20 28 6f 72 20 28 61 ..... (if (or (a
f870: 6e 64 20 28 65 71 75 61 6c 3f 20 28 64 62 3a 74 nd (equal? (db:t
f880: 65 73 74 2d 67 65 74 2d 73 74 61 74 65 20 77 74 est-get-state wt
f890: 64 61 74 29 20 22 43 4f 4d 50 4c 45 54 45 44 22 dat) "COMPLETED"
f8a0: 29 0a 09 09 09 09 09 20 20 20 20 20 20 28 6d 65 )...... (me
f8b0: 6d 62 65 72 20 28 64 62 3a 74 65 73 74 2d 67 65 mber (db:test-ge
f8c0: 74 2d 73 74 61 74 75 73 20 77 74 64 61 74 29 20 t-status wtdat)
f8d0: 27 28 22 46 41 49 4c 22 20 22 41 42 4f 52 54 22 '("FAIL" "ABORT"
f8e0: 29 29 29 0a 09 09 09 09 09 20 28 6d 65 6d 62 65 )))...... (membe
f8f0: 72 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 73 r (db:test-get-s
f900: 74 61 74 75 73 20 77 74 64 61 74 29 20 20 27 28 tatus wtdat) '(
f910: 22 4b 49 4c 4c 45 44 22 29 29 0a 09 09 09 09 09 "KILLED"))......
f920: 20 28 6d 65 6d 62 65 72 20 28 64 62 3a 74 65 73 (member (db:tes
f930: 74 2d 67 65 74 2d 73 74 61 74 65 20 77 74 64 61 t-get-state wtda
f940: 74 29 20 20 20 27 28 22 49 4e 43 4f 4d 50 45 54 t) '("INCOMPET
f950: 45 22 29 29 29 0a 09 09 09 09 20 3b 3b 20 28 69 E")))..... ;; (i
f960: 66 20 28 6f 72 20 28 6d 65 6d 62 65 72 20 28 64 f (or (member (d
f970: 62 3a 74 65 73 74 2d 67 65 74 2d 73 74 61 74 75 b:test-get-statu
f980: 73 20 77 74 64 61 74 29 0a 09 09 09 09 20 3b 3b s wtdat)..... ;;
f990: 20 20 20 20 20 20 20 20 09 20 27 28 22 46 41 49 . '("FAI
f9a0: 4c 22 20 22 4b 49 4c 4c 45 44 22 29 29 0a 09 09 L" "KILLED"))...
f9b0: 09 09 20 3b 3b 20 20 20 20 20 20 20 20 20 28 6d .. ;; (m
f9c0: 65 6d 62 65 72 20 28 64 62 3a 74 65 73 74 2d 67 ember (db:test-g
f9d0: 65 74 2d 73 74 61 74 65 20 77 74 64 61 74 29 0a et-state wtdat).
f9e0: 09 09 09 09 20 3b 3b 20 20 20 20 20 20 20 20 09 .... ;; .
f9f0: 20 27 28 22 49 4e 43 4f 4d 50 45 54 45 22 29 29 '("INCOMPETE"))
fa00: 29 0a 09 09 09 09 20 20 20 20 20 28 73 65 74 21 )..... (set!
fa10: 20 6b 65 65 70 2d 74 65 73 74 20 23 66 29 29 29 keep-test #f)))
fa20: 29 20 3b 3b 20 6e 6f 20 70 6f 69 6e 74 20 69 6e ) ;; no point in
fa30: 20 72 75 6e 6e 69 6e 67 20 74 68 69 73 20 6f 6e running this on
fa40: 65 20 61 67 61 69 6e 0a 09 09 09 20 20 20 20 20 e again....
fa50: 77 61 69 74 6f 6e 73 29 29 29 29 0a 09 20 28 69 waitons)))).. (i
fa60: 66 20 6b 65 65 70 2d 74 65 73 74 20 28 73 65 74 f keep-test (set
fa70: 21 20 72 75 6e 6e 61 62 6c 65 73 20 28 63 6f 6e ! runnables (con
fa80: 73 20 74 65 73 74 6b 65 79 6e 61 6d 65 20 72 75 s testkeyname ru
fa90: 6e 6e 61 62 6c 65 73 29 29 29 29 29 0a 20 20 20 nnables))))).
faa0: 20 20 74 65 73 74 6b 65 79 6e 61 6d 65 73 29 0a testkeynames).
fab0: 20 20 20 20 72 75 6e 6e 61 62 6c 65 73 29 29 0a runnables)).
fac0: 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d .;;=============
fad0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
fae0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
faf0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
fb00: 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 72 65 66 =========.;; ref
fb10: 61 63 74 6f 72 69 6e 67 20 74 68 69 73 20 62 6c actoring this bl
fb20: 6f 63 6b 20 69 6e 74 6f 20 74 65 73 74 73 3a 67 ock into tests:g
fb30: 65 74 2d 66 75 6c 6c 2d 64 61 74 61 20 66 72 6f et-full-data fro
fb40: 6d 20 6c 69 6e 65 20 32 36 33 20 6f 66 20 72 75 m line 263 of ru
fb50: 6e 73 2e 73 63 6d 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d ns.scm.;;=======
fb60: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
fb70: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
fb80: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
fb90: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a ===============.
fba0: 3b 3b 20 68 65 64 20 69 73 20 74 68 65 20 74 65 ;; hed is the te
fbb0: 73 74 20 6e 61 6d 65 0a 3b 3b 20 74 65 73 74 2d st name.;; test-
fbc0: 72 65 63 6f 72 64 73 20 69 73 20 61 20 68 61 73 records is a has
fbd0: 68 20 6f 66 20 74 65 73 74 2d 6e 61 6d 65 20 3d h of test-name =
fbe0: 3e 20 74 65 73 74 20 72 65 63 6f 72 64 0a 28 64 > test record.(d
fbf0: 65 66 69 6e 65 20 28 74 65 73 74 73 3a 67 65 74 efine (tests:get
fc00: 2d 66 75 6c 6c 2d 64 61 74 61 20 74 65 73 74 2d -full-data test-
fc10: 6e 61 6d 65 73 20 74 65 73 74 2d 72 65 63 6f 72 names test-recor
fc20: 64 73 20 72 65 71 75 69 72 65 64 2d 74 65 73 74 ds required-test
fc30: 73 20 61 6c 6c 2d 74 65 73 74 73 2d 72 65 67 69 s all-tests-regi
fc40: 73 74 72 79 29 0a 20 20 28 69 66 20 28 6e 6f 74 stry). (if (not
fc50: 20 28 6e 75 6c 6c 3f 20 74 65 73 74 2d 6e 61 6d (null? test-nam
fc60: 65 73 29 29 0a 20 20 20 20 20 20 28 6c 65 74 20 es)). (let
fc70: 6c 6f 6f 70 20 28 28 68 65 64 20 28 63 61 72 20 loop ((hed (car
fc80: 74 65 73 74 2d 6e 61 6d 65 73 29 29 0a 09 09 20 test-names))...
fc90: 28 74 61 6c 20 28 63 64 72 20 74 65 73 74 2d 6e (tal (cdr test-n
fca0: 61 6d 65 73 29 29 29 20 20 20 20 20 20 20 20 20 ames)))
fcb0: 3b 3b 20 27 72 65 74 75 72 6e 2d 70 72 6f 63 73 ;; 'return-procs
fcc0: 20 74 65 6c 6c 73 20 74 68 65 20 63 6f 6e 66 69 tells the confi
fcd0: 67 20 72 65 61 64 65 72 20 74 6f 20 70 72 65 70 g reader to prep
fce0: 20 72 75 6e 6e 69 6e 67 20 73 79 73 74 65 6d 20 running system
fcf0: 62 75 74 20 72 65 74 75 72 6e 20 61 20 70 72 6f but return a pro
fd00: 63 0a 09 28 64 65 62 75 67 3a 70 72 69 6e 74 2d c..(debug:print-
fd10: 69 6e 66 6f 20 34 20 2a 64 65 66 61 75 6c 74 2d info 4 *default-
fd20: 6c 6f 67 2d 70 6f 72 74 2a 20 22 68 65 64 3d 22 log-port* "hed="
fd30: 20 68 65 64 20 22 20 61 74 20 74 6f 70 20 6f 66 hed " at top of
fd40: 20 6c 6f 6f 70 22 29 0a 20 20 20 20 20 20 20 20 loop").
fd50: 3b 3b 20 64 6f 6e 27 74 20 6b 6e 6f 77 20 69 74 ;; don't know it
fd60: 65 6d 2d 70 61 74 68 20 61 74 20 74 68 69 73 20 em-path at this
fd70: 74 69 6d 65 2c 20 6c 65 74 20 74 68 65 20 74 65 time, let the te
fd80: 73 74 63 6f 6e 66 69 67 20 67 65 74 20 74 68 65 stconfig get the
fd90: 20 74 6f 70 20 6c 65 76 65 6c 20 74 65 73 74 63 top level testc
fda0: 6f 6e 66 69 67 0a 09 28 6c 65 74 2a 20 28 28 63 onfig..(let* ((c
fdb0: 6f 6e 66 69 67 20 20 28 74 65 73 74 73 3a 67 65 onfig (tests:ge
fdc0: 74 2d 74 65 73 74 63 6f 6e 66 69 67 20 68 65 64 t-testconfig hed
fdd0: 20 23 66 20 61 6c 6c 2d 74 65 73 74 73 2d 72 65 #f all-tests-re
fde0: 67 69 73 74 72 79 20 27 72 65 74 75 72 6e 2d 70 gistry 'return-p
fdf0: 72 6f 63 73 29 29 0a 09 20 20 20 20 20 20 20 28 rocs)).. (
fe00: 77 61 69 74 6f 6e 73 20 28 6c 65 74 20 28 28 69 waitons (let ((i
fe10: 6e 73 74 72 20 28 69 66 20 63 6f 6e 66 69 67 20 nstr (if config
fe20: 0a 09 09 09 09 09 20 28 63 6f 6e 66 69 67 2d 6c ...... (config-l
fe30: 6f 6f 6b 75 70 20 63 6f 6e 66 69 67 20 22 72 65 ookup config "re
fe40: 71 75 69 72 65 6d 65 6e 74 73 22 20 22 77 61 69 quirements" "wai
fe50: 74 6f 6e 22 29 0a 09 09 09 09 09 20 28 62 65 67 ton")...... (beg
fe60: 69 6e 20 3b 3b 20 4e 6f 20 63 6f 6e 66 69 67 20 in ;; No config
fe70: 6d 65 61 6e 73 20 74 68 69 73 20 69 73 20 61 20 means this is a
fe80: 6e 6f 6e 2d 65 78 69 73 74 61 6e 74 20 74 65 73 non-existant tes
fe90: 74 0a 09 09 09 09 09 20 20 20 28 64 65 62 75 67 t...... (debug
fea0: 3a 70 72 69 6e 74 2d 65 72 72 6f 72 20 30 20 2a :print-error 0 *
feb0: 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 default-log-port
fec0: 2a 20 22 6e 6f 6e 2d 65 78 69 73 74 65 6e 74 20 * "non-existent
fed0: 72 65 71 75 69 72 65 64 20 74 65 73 74 20 5c 22 required test \"
fee0: 22 20 68 65 64 20 22 5c 22 2c 20 67 72 65 70 20 " hed "\", grep
fef0: 74 68 72 6f 75 67 68 20 79 6f 75 72 20 74 65 73 through your tes
ff00: 74 63 6f 6e 66 69 67 73 20 74 6f 20 66 69 6e 64 tconfigs to find
ff10: 20 61 6e 64 20 72 65 6d 6f 76 65 20 6f 72 20 63 and remove or c
ff20: 72 65 61 74 65 20 74 68 65 20 74 65 73 74 2e 20 reate the test.
ff30: 44 69 73 63 61 72 64 69 6e 67 20 61 6e 64 20 63 Discarding and c
ff40: 6f 6e 74 69 6e 75 69 6e 67 2e 22 29 0a 09 09 09 ontinuing.")....
ff50: 09 09 20 20 20 20 20 22 22 29 29 29 29 0a 09 09 .. ""))))...
ff60: 09 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d . (debug:print-
ff70: 69 6e 66 6f 20 38 20 2a 64 65 66 61 75 6c 74 2d info 8 *default-
ff80: 6c 6f 67 2d 70 6f 72 74 2a 20 22 77 61 69 74 6f log-port* "waito
ff90: 6e 73 20 73 74 72 69 6e 67 20 69 73 20 22 20 69 ns string is " i
ffa0: 6e 73 74 72 29 0a 09 09 09 20 20 28 73 74 72 69 nstr).... (stri
ffb0: 6e 67 2d 73 70 6c 69 74 20 28 63 6f 6e 64 0a 09 ng-split (cond..
ffc0: 09 09 09 09 20 28 28 70 72 6f 63 65 64 75 72 65 .... ((procedure
ffd0: 3f 20 69 6e 73 74 72 29 0a 09 09 09 09 09 20 20 ? instr)......
ffe0: 28 6c 65 74 20 28 28 72 65 73 20 28 69 6e 73 74 (let ((res (inst
fff0: 72 29 29 29 0a 09 09 09 09 09 20 20 20 20 28 64 r)))...... (d
10000 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 ebug:print-info
10010 38 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 8 *default-log-p
10020 6f 72 74 2a 20 22 77 61 69 74 6f 6e 20 70 72 6f ort* "waiton pro
10030 63 65 64 75 72 65 20 72 65 73 75 6c 74 73 20 69 cedure results i
10040 6e 20 73 74 72 69 6e 67 20 22 20 72 65 73 20 22 n string " res "
10050 20 66 6f 72 20 74 65 73 74 20 22 20 68 65 64 29 for test " hed)
10060 0a 09 09 09 09 09 20 20 20 20 72 65 73 29 29 0a ...... res)).
10070 09 09 09 09 09 20 28 28 73 74 72 69 6e 67 3f 20 ..... ((string?
10080 69 6e 73 74 72 29 20 20 20 20 20 69 6e 73 74 72 instr) instr
10090 29 0a 09 09 09 09 09 20 28 65 6c 73 65 20 0a 09 )...... (else ..
100a0 09 09 09 09 20 20 3b 3b 20 4e 4f 54 45 3a 20 54 .... ;; NOTE: T
100b0 68 69 73 20 69 73 20 61 63 74 75 61 6c 6c 79 20 his is actually
100c0 74 68 65 20 63 61 73 65 20 6f 66 20 2a 6e 6f 2a the case of *no*
100d0 20 77 61 69 74 6f 6e 73 21 20 3b 3b 20 28 64 65 waitons! ;; (de
100e0 62 75 67 3a 70 72 69 6e 74 2d 65 72 72 6f 72 20 bug:print-error
100f0 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 0 *default-log-p
10100 6f 72 74 2a 20 22 73 6f 6d 65 74 68 69 6e 67 20 ort* "something
10110 77 65 6e 74 20 77 72 6f 6e 67 20 69 6e 20 70 72 went wrong in pr
10120 6f 63 65 73 73 69 6e 67 20 77 61 69 74 6f 6e 73 ocessing waitons
10130 20 66 6f 72 20 74 65 73 74 20 22 20 68 65 64 29 for test " hed)
10140 0a 09 09 09 09 09 20 20 22 22 29 29 29 29 29 29 ...... ""))))))
10150 0a 09 20 20 28 69 66 20 28 6e 6f 74 20 63 6f 6e .. (if (not con
10160 66 69 67 29 20 3b 3b 20 74 68 69 73 20 69 73 20 fig) ;; this is
10170 61 20 6e 6f 6e 2d 65 78 69 73 74 61 6e 74 20 74 a non-existant t
10180 65 73 74 20 63 61 6c 6c 65 64 20 69 6e 20 61 20 est called in a
10190 77 61 69 74 6f 6e 2e 20 0a 09 20 20 20 20 20 20 waiton. ..
101a0 28 69 66 20 28 6e 75 6c 6c 3f 20 74 61 6c 29 0a (if (null? tal).
101b0 09 09 20 20 74 65 73 74 2d 72 65 63 6f 72 64 73 .. test-records
101c0 0a 09 09 20 20 28 6c 6f 6f 70 20 28 63 61 72 20 ... (loop (car
101d0 74 61 6c 29 28 63 64 72 20 74 61 6c 29 29 29 0a tal)(cdr tal))).
101e0 09 20 20 20 20 20 20 28 62 65 67 69 6e 0a 09 09 . (begin...
101f0 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 (debug:print-inf
10200 6f 20 38 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 o 8 *default-log
10210 2d 70 6f 72 74 2a 20 22 77 61 69 74 6f 6e 73 3a -port* "waitons:
10220 20 22 20 77 61 69 74 6f 6e 73 29 0a 09 09 3b 3b " waitons)...;;
10230 20 63 68 65 63 6b 20 66 6f 72 20 68 65 64 20 69 check for hed i
10240 6e 20 77 61 69 74 6f 6e 73 20 3d 3e 20 74 68 69 n waitons => thi
10250 73 20 77 6f 75 6c 64 20 62 65 20 63 69 72 63 75 s would be circu
10260 6c 61 72 2c 20 72 65 6d 6f 76 65 20 69 74 20 61 lar, remove it a
10270 6e 64 20 69 73 73 75 65 20 61 6e 0a 09 09 3b 3b nd issue an...;;
10280 20 65 72 72 6f 72 0a 09 09 28 69 66 20 28 6d 65 error...(if (me
10290 6d 62 65 72 20 68 65 64 20 77 61 69 74 6f 6e 73 mber hed waitons
102a0 29 0a 09 09 20 20 20 20 28 62 65 67 69 6e 0a 09 )... (begin..
102b0 09 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 . (debug:pr
102c0 69 6e 74 2d 65 72 72 6f 72 20 30 20 2a 64 65 66 int-error 0 *def
102d0 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 ault-log-port* "
102e0 74 65 73 74 20 22 20 68 65 64 20 22 20 68 61 73 test " hed " has
102f0 20 6c 69 73 74 65 64 20 69 74 73 65 6c 66 20 61 listed itself a
10300 73 20 61 20 77 61 69 74 6f 6e 2c 20 70 6c 65 61 s a waiton, plea
10310 73 65 20 63 6f 72 72 65 63 74 20 74 68 69 73 21 se correct this!
10320 22 29 0a 09 09 20 20 20 20 20 20 28 73 65 74 21 ")... (set!
10330 20 77 61 69 74 6f 6e 73 20 28 66 69 6c 74 65 72 waitons (filter
10340 20 28 6c 61 6d 62 64 61 20 28 78 29 28 6e 6f 74 (lambda (x)(not
10350 20 28 65 71 75 61 6c 3f 20 78 20 68 65 64 29 29 (equal? x hed))
10360 29 20 77 61 69 74 6f 6e 73 29 29 29 29 0a 09 09 ) waitons))))...
10370 0a 09 09 3b 3b 20 28 69 74 65 6d 73 20 20 20 28 ...;; (items (
10380 69 74 65 6d 73 3a 67 65 74 2d 69 74 65 6d 73 2d items:get-items-
10390 66 72 6f 6d 2d 63 6f 6e 66 69 67 20 63 6f 6e 66 from-config conf
103a0 69 67 29 29 29 0a 09 09 28 69 66 20 28 6e 6f 74 ig)))...(if (not
103b0 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 (hash-table-ref
103c0 2f 64 65 66 61 75 6c 74 20 74 65 73 74 2d 72 65 /default test-re
103d0 63 6f 72 64 73 20 68 65 64 20 23 66 29 29 0a 09 cords hed #f))..
103e0 09 20 20 20 20 28 68 61 73 68 2d 74 61 62 6c 65 . (hash-table
103f0 2d 73 65 74 21 20 74 65 73 74 2d 72 65 63 6f 72 -set! test-recor
10400 64 73 0a 09 09 09 09 20 20 20 20 20 68 65 64 20 ds..... hed
10410 28 76 65 63 74 6f 72 20 68 65 64 20 20 20 20 20 (vector hed
10420 3b 3b 20 30 0a 09 09 09 09 09 09 20 63 6f 6e 66 ;; 0....... conf
10430 69 67 20 20 3b 3b 20 31 0a 09 09 09 09 09 09 20 ig ;; 1.......
10440 77 61 69 74 6f 6e 73 20 3b 3b 20 32 0a 09 09 09 waitons ;; 2....
10450 09 09 09 20 28 63 6f 6e 66 69 67 2d 6c 6f 6f 6b ... (config-look
10460 75 70 20 63 6f 6e 66 69 67 20 22 72 65 71 75 69 up config "requi
10470 72 65 6d 65 6e 74 73 22 20 22 70 72 69 6f 72 69 rements" "priori
10480 74 79 22 29 20 20 20 20 20 3b 3b 20 70 72 69 6f ty") ;; prio
10490 72 69 74 79 20 33 0a 09 09 09 09 09 09 20 28 6c rity 3....... (l
104a0 65 74 20 28 28 69 74 65 6d 73 20 20 20 20 20 20 et ((items
104b0 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f (hash-table-ref/
104c0 64 65 66 61 75 6c 74 20 63 6f 6e 66 69 67 20 22 default config "
104d0 69 74 65 6d 73 22 20 23 66 29 29 20 3b 3b 20 69 items" #f)) ;; i
104e0 74 65 6d 73 20 34 0a 09 09 09 09 09 09 20 20 20 tems 4.......
104f0 20 20 20 20 28 69 74 65 6d 73 74 61 62 6c 65 20 (itemstable
10500 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f (hash-table-ref/
10510 64 65 66 61 75 6c 74 20 63 6f 6e 66 69 67 20 22 default config "
10520 69 74 65 6d 73 74 61 62 6c 65 22 20 23 66 29 29 itemstable" #f))
10530 29 20 0a 09 09 09 09 09 09 20 20 20 3b 3b 20 69 ) ....... ;; i
10540 66 20 65 69 74 68 65 72 20 69 74 65 6d 73 20 6f f either items o
10550 72 20 69 74 65 6d 73 20 74 61 62 6c 65 20 69 73 r items table is
10560 20 61 20 70 72 6f 63 20 72 65 74 75 72 6e 20 69 a proc return i
10570 74 20 73 6f 20 74 65 73 74 20 72 75 6e 6e 69 6e t so test runnin
10580 67 0a 09 09 09 09 09 09 20 20 20 3b 3b 20 70 72 g....... ;; pr
10590 6f 63 65 73 73 20 63 61 6e 20 6b 6e 6f 77 20 74 ocess can know t
105a0 6f 20 63 61 6c 6c 20 69 74 65 6d 73 3a 67 65 74 o call items:get
105b0 2d 69 74 65 6d 73 2d 66 72 6f 6d 2d 63 6f 6e 66 -items-from-conf
105c0 69 67 0a 09 09 09 09 09 09 20 20 20 3b 3b 20 69 ig....... ;; i
105d0 66 20 65 69 74 68 65 72 20 69 73 20 61 20 6c 69 f either is a li
105e0 73 74 20 61 6e 64 20 6e 6f 6e 65 20 69 73 20 61 st and none is a
105f0 20 70 72 6f 63 20 67 6f 20 61 68 65 61 64 20 61 proc go ahead a
10600 6e 64 20 63 61 6c 6c 20 67 65 74 2d 69 74 65 6d nd call get-item
10610 73 0a 09 09 09 09 09 09 20 20 20 3b 3b 20 6f 74 s....... ;; ot
10620 68 65 72 77 69 73 65 20 72 65 74 75 72 6e 20 23 herwise return #
10630 66 20 2d 20 74 68 69 73 20 69 73 20 6e 6f 74 20 f - this is not
10640 61 6e 20 69 74 65 72 61 74 65 64 20 74 65 73 74 an iterated test
10650 0a 09 09 09 09 09 09 20 20 20 28 63 6f 6e 64 0a ....... (cond.
10660 09 09 09 09 09 09 20 20 20 20 28 28 70 72 6f 63 ...... ((proc
10670 65 64 75 72 65 3f 20 69 74 65 6d 73 29 20 20 20 edure? items)
10680 20 20 20 0a 09 09 09 09 09 09 20 20 20 20 20 28 ....... (
10690 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f debug:print-info
106a0 20 34 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 4 *default-log-
106b0 70 6f 72 74 2a 20 22 69 74 65 6d 73 20 69 73 20 port* "items is
106c0 61 20 70 72 6f 63 65 64 75 72 65 2c 20 77 69 6c a procedure, wil
106d0 6c 20 63 61 6c 63 20 6c 61 74 65 72 22 29 0a 09 l calc later")..
106e0 09 09 09 09 09 20 20 20 20 20 69 74 65 6d 73 29 ..... items)
106f0 20 20 20 20 20 20 20 20 20 20 20 20 3b 3b 20 63 ;; c
10700 61 6c 63 20 6c 61 74 65 72 0a 09 09 09 09 09 09 alc later.......
10710 20 20 20 20 28 28 70 72 6f 63 65 64 75 72 65 3f ((procedure?
10720 20 69 74 65 6d 73 74 61 62 6c 65 29 0a 09 09 09 itemstable)....
10730 09 09 09 20 20 20 20 20 28 64 65 62 75 67 3a 70 ... (debug:p
10740 72 69 6e 74 2d 69 6e 66 6f 20 34 20 2a 64 65 66 rint-info 4 *def
10750 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 ault-log-port* "
10760 69 74 65 6d 73 74 61 62 6c 65 20 69 73 20 61 20 itemstable is a
10770 70 72 6f 63 65 64 75 72 65 2c 20 77 69 6c 6c 20 procedure, will
10780 63 61 6c 63 20 6c 61 74 65 72 22 29 0a 09 09 09 calc later")....
10790 09 09 09 20 20 20 20 20 69 74 65 6d 73 74 61 62 ... itemstab
107a0 6c 65 29 20 20 20 20 20 20 20 3b 3b 20 63 61 6c le) ;; cal
107b0 63 20 6c 61 74 65 72 0a 09 09 09 09 09 09 20 20 c later.......
107c0 20 20 28 28 66 69 6c 74 65 72 20 28 6c 61 6d 62 ((filter (lamb
107d0 64 61 20 28 78 29 0a 09 09 09 09 09 09 09 20 20 da (x)........
107e0 20 20 20 20 20 28 6c 65 74 20 28 28 76 61 6c 20 (let ((val
107f0 28 63 61 72 20 78 29 29 29 0a 09 09 09 09 09 09 (car x))).......
10800 09 09 20 28 69 66 20 28 70 72 6f 63 65 64 75 72 .. (if (procedur
10810 65 3f 20 76 61 6c 29 20 76 61 6c 20 23 66 29 29 e? val) val #f))
10820 29 0a 09 09 09 09 09 09 09 20 20 20 20 20 28 61 )........ (a
10830 70 70 65 6e 64 20 28 69 66 20 28 6c 69 73 74 3f ppend (if (list?
10840 20 69 74 65 6d 73 29 20 69 74 65 6d 73 20 27 28 items) items '(
10850 29 29 0a 09 09 09 09 09 09 09 09 20 20 20 20 20 )).........
10860 28 69 66 20 28 6c 69 73 74 3f 20 69 74 65 6d 73 (if (list? items
10870 74 61 62 6c 65 29 20 69 74 65 6d 73 74 61 62 6c table) itemstabl
10880 65 20 27 28 29 29 29 29 0a 09 09 09 09 09 09 20 e '()))).......
10890 20 20 20 20 27 68 61 76 65 2d 70 72 6f 63 65 64 'have-proced
108a0 75 72 65 29 0a 09 09 09 09 09 09 20 20 20 20 28 ure)....... (
108b0 28 6f 72 20 28 6c 69 73 74 3f 20 69 74 65 6d 73 (or (list? items
108c0 29 28 6c 69 73 74 3f 20 69 74 65 6d 73 74 61 62 )(list? itemstab
108d0 6c 65 29 29 20 3b 3b 20 63 61 6c 63 20 6e 6f 77 le)) ;; calc now
108e0 0a 09 09 09 09 09 09 20 20 20 20 20 28 64 65 62 ....... (deb
108f0 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 34 20 ug:print-info 4
10900 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 *default-log-por
10910 74 2a 20 22 69 74 65 6d 73 20 61 6e 64 20 69 74 t* "items and it
10920 65 6d 73 74 61 62 6c 65 20 61 72 65 20 6c 69 73 emstable are lis
10930 74 73 2c 20 63 61 6c 63 20 6e 6f 77 5c 6e 22 0a ts, calc now\n".
10940 09 09 09 09 09 09 09 09 20 20 20 20 20 20 20 22 ........ "
10950 20 20 20 20 69 74 65 6d 73 3a 20 22 20 69 74 65 items: " ite
10960 6d 73 20 22 20 69 74 65 6d 73 74 61 62 6c 65 3a ms " itemstable:
10970 20 22 20 69 74 65 6d 73 74 61 62 6c 65 29 0a 09 " itemstable)..
10980 09 09 09 09 09 20 20 20 20 20 28 69 74 65 6d 73 ..... (items
10990 3a 67 65 74 2d 69 74 65 6d 73 2d 66 72 6f 6d 2d :get-items-from-
109a0 63 6f 6e 66 69 67 20 63 6f 6e 66 69 67 29 29 0a config config)).
109b0 09 09 09 09 09 09 20 20 20 20 28 65 6c 73 65 20 ...... (else
109c0 23 66 29 29 29 20 20 20 20 20 20 20 20 20 20 20 #f)))
109d0 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
109e0 3b 3b 20 6e 6f 74 20 69 74 65 72 61 74 65 64 0a ;; not iterated.
109f0 09 09 09 09 09 09 20 23 66 20 20 20 20 20 20 3b ...... #f ;
10a00 3b 20 69 74 65 6d 73 64 61 74 20 35 0a 09 09 09 ; itemsdat 5....
10a10 09 09 09 20 23 66 20 20 20 20 20 20 3b 3b 20 73 ... #f ;; s
10a20 70 61 72 65 20 2d 20 75 73 65 64 20 66 6f 72 20 pare - used for
10a30 69 74 65 6d 2d 70 61 74 68 0a 09 09 09 09 09 09 item-path.......
10a40 20 29 29 29 0a 09 09 28 66 6f 72 2d 65 61 63 68 )))...(for-each
10a50 20 0a 09 09 20 28 6c 61 6d 62 64 61 20 28 77 61 ... (lambda (wa
10a60 69 74 6f 6e 29 0a 09 09 20 20 20 28 69 66 20 28 iton)... (if (
10a70 61 6e 64 20 77 61 69 74 6f 6e 20 28 6e 6f 74 20 and waiton (not
10a80 28 6d 65 6d 62 65 72 20 77 61 69 74 6f 6e 20 74 (member waiton t
10a90 65 73 74 2d 6e 61 6d 65 73 29 29 29 0a 09 09 20 est-names)))...
10aa0 20 20 20 20 20 20 28 62 65 67 69 6e 0a 09 09 09 (begin....
10ab0 20 28 73 65 74 21 20 72 65 71 75 69 72 65 64 2d (set! required-
10ac0 74 65 73 74 73 20 28 63 6f 6e 73 20 77 61 69 74 tests (cons wait
10ad0 6f 6e 20 72 65 71 75 69 72 65 64 2d 74 65 73 74 on required-test
10ae0 73 29 29 0a 09 09 09 20 28 73 65 74 21 20 74 65 s)).... (set! te
10af0 73 74 2d 6e 61 6d 65 73 20 28 63 6f 6e 73 20 77 st-names (cons w
10b00 61 69 74 6f 6e 20 74 65 73 74 2d 6e 61 6d 65 73 aiton test-names
10b10 29 29 29 29 29 20 3b 3b 20 77 61 73 20 61 6e 20 ))))) ;; was an
10b20 61 70 70 65 6e 64 2c 20 6e 6f 77 20 61 20 63 6f append, now a co
10b30 6e 73 0a 09 09 20 77 61 69 74 6f 6e 73 29 0a 09 ns... waitons)..
10b40 09 28 6c 65 74 20 28 28 72 65 6d 74 65 73 74 73 .(let ((remtests
10b50 20 28 64 65 6c 65 74 65 2d 64 75 70 6c 69 63 61 (delete-duplica
10b60 74 65 73 20 28 61 70 70 65 6e 64 20 77 61 69 74 tes (append wait
10b70 6f 6e 73 20 74 61 6c 29 29 29 29 0a 09 09 20 20 ons tal))))...
10b80 28 69 66 20 28 6e 6f 74 20 28 6e 75 6c 6c 3f 20 (if (not (null?
10b90 72 65 6d 74 65 73 74 73 29 29 0a 09 09 20 20 20 remtests))...
10ba0 20 20 20 28 6c 6f 6f 70 20 28 63 61 72 20 72 65 (loop (car re
10bb0 6d 74 65 73 74 73 29 28 63 64 72 20 72 65 6d 74 mtests)(cdr remt
10bc0 65 73 74 73 29 29 0a 09 09 20 20 20 20 20 20 74 ests))... t
10bd0 65 73 74 2d 72 65 63 6f 72 64 73 29 29 29 29 29 est-records)))))
10be0 29 29 29 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d )))..;;=========
10bf0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
10c00 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
10c10 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
10c20 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b =============.;;
10c30 20 74 65 73 74 20 73 74 65 70 73 0a 3b 3b 3d 3d test steps.;;==
10c40 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
10c50 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
10c60 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
10c70 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
10c80 3d 3d 3d 3d 0a 0a 3b 3b 20 74 65 73 74 73 74 65 ====..;; testste
10c90 70 2d 73 65 74 2d 73 74 61 74 75 73 21 20 75 73 p-set-status! us
10ca0 65 64 20 74 6f 20 62 65 20 68 65 72 65 0a 0a 28 ed to be here..(
10cb0 64 65 66 69 6e 65 20 28 74 65 73 74 2d 67 65 74 define (test-get
10cc0 2d 6b 69 6c 6c 2d 72 65 71 75 65 73 74 20 72 75 -kill-request ru
10cd0 6e 2d 69 64 20 74 65 73 74 2d 69 64 29 20 3b 3b n-id test-id) ;;
10ce0 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 6e 61 6d run-id test-nam
10cf0 65 20 69 74 65 6d 64 61 74 29 0a 20 20 28 6c 65 e itemdat). (le
10d00 74 2a 20 28 28 74 65 73 74 64 61 74 20 20 20 28 t* ((testdat (
10d10 72 6d 74 3a 67 65 74 2d 74 65 73 74 2d 69 6e 66 rmt:get-test-inf
10d20 6f 2d 62 79 2d 69 64 20 72 75 6e 2d 69 64 20 74 o-by-id run-id t
10d30 65 73 74 2d 69 64 29 29 29 0a 20 20 20 20 28 61 est-id))). (a
10d40 6e 64 20 74 65 73 74 64 61 74 0a 09 20 28 65 71 nd testdat.. (eq
10d50 75 61 6c 3f 20 28 74 65 73 74 3a 67 65 74 2d 73 ual? (test:get-s
10d60 74 61 74 65 20 74 65 73 74 64 61 74 29 20 22 4b tate testdat) "K
10d70 49 4c 4c 52 45 51 22 29 29 29 29 0a 0a 28 64 65 ILLREQ"))))..(de
10d80 66 69 6e 65 20 28 74 65 73 74 3a 74 64 62 2d 67 fine (test:tdb-g
10d90 65 74 2d 72 75 6e 64 61 74 2d 63 6f 75 6e 74 20 et-rundat-count
10da0 74 64 62 29 0a 20 20 28 69 66 20 74 64 62 0a 20 tdb). (if tdb.
10db0 20 20 20 20 20 28 6c 65 74 20 28 28 72 65 73 20 (let ((res
10dc0 30 29 29 0a 09 28 73 71 6c 69 74 65 33 3a 66 6f 0))..(sqlite3:fo
10dd0 72 2d 65 61 63 68 2d 72 6f 77 0a 09 20 28 6c 61 r-each-row.. (la
10de0 6d 62 64 61 20 28 63 6f 75 6e 74 29 0a 09 20 20 mbda (count)..
10df0 20 28 73 65 74 21 20 72 65 73 20 63 6f 75 6e 74 (set! res count
10e00 29 29 0a 09 20 74 64 62 0a 09 20 22 53 45 4c 45 )).. tdb.. "SELE
10e10 43 54 20 63 6f 75 6e 74 28 69 64 29 20 46 52 4f CT count(id) FRO
10e20 4d 20 74 65 73 74 5f 72 75 6e 64 61 74 3b 22 29 M test_rundat;")
10e30 0a 09 72 65 73 29 29 0a 20 20 30 29 0a 0a 28 64 ..res)). 0)..(d
10e40 65 66 69 6e 65 20 28 74 65 73 74 73 3a 75 70 64 efine (tests:upd
10e50 61 74 65 2d 63 65 6e 74 72 61 6c 2d 6d 65 74 61 ate-central-meta
10e60 2d 69 6e 66 6f 20 72 75 6e 2d 69 64 20 74 65 73 -info run-id tes
10e70 74 2d 69 64 20 63 70 75 6c 6f 61 64 20 64 69 73 t-id cpuload dis
10e80 6b 66 72 65 65 20 6d 69 6e 75 74 65 73 20 75 6e kfree minutes un
10e90 61 6d 65 20 68 6f 73 74 6e 61 6d 65 29 0a 20 20 ame hostname).
10ea0 28 72 6d 74 3a 67 65 6e 65 72 61 6c 2d 63 61 6c (rmt:general-cal
10eb0 6c 20 27 75 70 64 61 74 65 2d 74 65 73 74 2d 72 l 'update-test-r
10ec0 75 6e 64 61 74 20 72 75 6e 2d 69 64 20 74 65 73 undat run-id tes
10ed0 74 2d 69 64 20 28 63 75 72 72 65 6e 74 2d 73 65 t-id (current-se
10ee0 63 6f 6e 64 73 29 20 28 6f 72 20 63 70 75 6c 6f conds) (or cpulo
10ef0 61 64 20 2d 31 29 28 6f 72 20 64 69 73 6b 66 72 ad -1)(or diskfr
10f00 65 65 20 2d 31 29 20 2d 31 20 28 6f 72 20 6d 69 ee -1) -1 (or mi
10f10 6e 75 74 65 73 20 2d 31 29 29 0a 20 20 28 69 66 nutes -1)). (if
10f20 20 28 61 6e 64 20 63 70 75 6c 6f 61 64 20 64 69 (and cpuload di
10f30 73 6b 66 72 65 65 29 0a 20 20 20 20 20 20 28 72 skfree). (r
10f40 6d 74 3a 67 65 6e 65 72 61 6c 2d 63 61 6c 6c 20 mt:general-call
10f50 27 75 70 64 61 74 65 2d 63 70 75 6c 6f 61 64 2d 'update-cpuload-
10f60 64 69 73 6b 66 72 65 65 20 72 75 6e 2d 69 64 20 diskfree run-id
10f70 63 70 75 6c 6f 61 64 20 64 69 73 6b 66 72 65 65 cpuload diskfree
10f80 20 74 65 73 74 2d 69 64 29 29 0a 20 20 28 69 66 test-id)). (if
10f90 20 6d 69 6e 75 74 65 73 20 0a 20 20 20 20 20 20 minutes .
10fa0 28 72 6d 74 3a 67 65 6e 65 72 61 6c 2d 63 61 6c (rmt:general-cal
10fb0 6c 20 27 75 70 64 61 74 65 2d 72 75 6e 2d 64 75 l 'update-run-du
10fc0 72 61 74 69 6f 6e 20 72 75 6e 2d 69 64 20 6d 69 ration run-id mi
10fd0 6e 75 74 65 73 20 74 65 73 74 2d 69 64 29 29 0a nutes test-id)).
10fe0 20 20 28 69 66 20 28 61 6e 64 20 75 6e 61 6d 65 (if (and uname
10ff0 20 68 6f 73 74 6e 61 6d 65 29 0a 20 20 20 20 20 hostname).
11000 20 28 72 6d 74 3a 67 65 6e 65 72 61 6c 2d 63 61 (rmt:general-ca
11010 6c 6c 20 27 75 70 64 61 74 65 2d 75 6e 61 6d 65 ll 'update-uname
11020 2d 68 6f 73 74 20 72 75 6e 2d 69 64 20 75 6e 61 -host run-id una
11030 6d 65 20 68 6f 73 74 6e 61 6d 65 20 74 65 73 74 me hostname test
11040 2d 69 64 29 29 29 0a 20 20 0a 3b 3b 20 54 68 69 -id))). .;; Thi
11050 73 20 6f 6e 65 20 69 73 20 66 6f 72 20 72 75 6e s one is for run
11060 6e 69 6e 67 20 77 69 74 68 20 6e 6f 20 64 62 20 ning with no db
11070 61 63 63 65 73 73 20 28 69 2e 65 2e 20 76 69 61 access (i.e. via
11080 20 72 6d 74 3a 20 69 6e 74 65 72 6e 61 6c 6c 79 rmt: internally
11090 29 0a 28 64 65 66 69 6e 65 20 28 74 65 73 74 73 ).(define (tests
110a0 3a 73 65 74 2d 66 75 6c 6c 2d 6d 65 74 61 2d 69 :set-full-meta-i
110b0 6e 66 6f 20 64 62 20 74 65 73 74 2d 69 64 20 72 nfo db test-id r
110c0 75 6e 2d 69 64 20 6d 69 6e 75 74 65 73 20 77 6f un-id minutes wo
110d0 72 6b 2d 61 72 65 61 20 72 65 6d 74 72 69 65 73 rk-area remtries
110e0 29 0a 3b 3b 20 28 64 65 66 69 6e 65 20 28 74 65 ).;; (define (te
110f0 73 74 73 3a 73 65 74 2d 66 75 6c 6c 2d 6d 65 74 sts:set-full-met
11100 61 2d 69 6e 66 6f 20 74 65 73 74 2d 69 64 20 72 a-info test-id r
11110 75 6e 2d 69 64 20 6d 69 6e 75 74 65 73 20 77 6f un-id minutes wo
11120 72 6b 2d 61 72 65 61 29 0a 3b 3b 20 20 28 6c 65 rk-area).;; (le
11130 74 20 28 28 72 65 6d 74 72 69 65 73 20 31 30 29 t ((remtries 10)
11140 29 0a 20 20 28 6c 65 74 2a 20 28 28 63 70 75 6c ). (let* ((cpul
11150 6f 61 64 20 20 28 67 65 74 2d 63 70 75 2d 6c 6f oad (get-cpu-lo
11160 61 64 29 29 0a 09 20 28 64 69 73 6b 66 72 65 65 ad)).. (diskfree
11170 20 28 67 65 74 2d 64 66 20 28 63 75 72 72 65 6e (get-df (curren
11180 74 2d 64 69 72 65 63 74 6f 72 79 29 29 29 0a 09 t-directory)))..
11190 20 28 75 6e 61 6d 65 20 20 20 20 28 67 65 74 2d (uname (get-
111a0 75 6e 61 6d 65 20 22 2d 73 72 76 70 69 6f 22 29 uname "-srvpio")
111b0 29 0a 09 20 28 68 6f 73 74 6e 61 6d 65 20 28 67 ).. (hostname (g
111c0 65 74 2d 68 6f 73 74 2d 6e 61 6d 65 29 29 29 0a et-host-name))).
111d0 20 20 20 20 28 74 65 73 74 73 3a 75 70 64 61 74 (tests:updat
111e0 65 2d 63 65 6e 74 72 61 6c 2d 6d 65 74 61 2d 69 e-central-meta-i
111f0 6e 66 6f 20 72 75 6e 2d 69 64 20 74 65 73 74 2d nfo run-id test-
11200 69 64 20 63 70 75 6c 6f 61 64 20 64 69 73 6b 66 id cpuload diskf
11210 72 65 65 20 6d 69 6e 75 74 65 73 20 75 6e 61 6d ree minutes unam
11220 65 20 68 6f 73 74 6e 61 6d 65 29 29 29 0a 20 20 e hostname))).
11230 20 20 0a 3b 3b 20 28 64 65 66 69 6e 65 20 28 74 .;; (define (t
11240 65 73 74 73 3a 73 65 74 2d 70 61 72 74 69 61 6c ests:set-partial
11250 2d 6d 65 74 61 2d 69 6e 66 6f 20 74 65 73 74 2d -meta-info test-
11260 69 64 20 72 75 6e 2d 69 64 20 6d 69 6e 75 74 65 id run-id minute
11270 73 20 77 6f 72 6b 2d 61 72 65 61 29 0a 28 64 65 s work-area).(de
11280 66 69 6e 65 20 28 74 65 73 74 73 3a 73 65 74 2d fine (tests:set-
11290 70 61 72 74 69 61 6c 2d 6d 65 74 61 2d 69 6e 66 partial-meta-inf
112a0 6f 20 74 65 73 74 2d 69 64 20 72 75 6e 2d 69 64 o test-id run-id
112b0 20 6d 69 6e 75 74 65 73 20 77 6f 72 6b 2d 61 72 minutes work-ar
112c0 65 61 20 72 65 6d 74 72 69 65 73 29 0a 20 20 28 ea remtries). (
112d0 6c 65 74 2a 20 28 28 63 70 75 6c 6f 61 64 20 20 let* ((cpuload
112e0 28 67 65 74 2d 63 70 75 2d 6c 6f 61 64 29 29 0a (get-cpu-load)).
112f0 09 20 28 64 69 73 6b 66 72 65 65 20 28 67 65 74 . (diskfree (get
11300 2d 64 66 20 28 63 75 72 72 65 6e 74 2d 64 69 72 -df (current-dir
11310 65 63 74 6f 72 79 29 29 29 0a 09 20 28 72 65 6d ectory))).. (rem
11320 74 72 69 65 73 20 31 30 29 29 0a 20 20 20 20 28 tries 10)). (
11330 68 61 6e 64 6c 65 2d 65 78 63 65 70 74 69 6f 6e handle-exception
11340 73 0a 20 20 20 20 20 65 78 6e 0a 20 20 20 20 20 s. exn.
11350 28 69 66 20 28 3e 20 72 65 6d 74 72 69 65 73 20 (if (> remtries
11360 30 29 0a 09 20 28 62 65 67 69 6e 0a 09 20 20 20 0).. (begin..
11370 28 70 72 69 6e 74 2d 63 61 6c 6c 2d 63 68 61 69 (print-call-chai
11380 6e 20 28 63 75 72 72 65 6e 74 2d 65 72 72 6f 72 n (current-error
11390 2d 70 6f 72 74 29 29 0a 09 20 20 20 28 64 65 62 -port)).. (deb
113a0 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 30 20 ug:print-info 0
113b0 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 *default-log-por
113c0 74 2a 20 22 57 41 52 4e 49 4e 47 3a 20 66 61 69 t* "WARNING: fai
113d0 6c 65 64 20 74 6f 20 73 65 74 20 6d 65 74 61 20 led to set meta
113e0 69 6e 66 6f 2e 20 57 69 6c 6c 20 74 72 79 20 22 info. Will try "
113f0 20 72 65 6d 74 72 69 65 73 20 22 20 6d 6f 72 65 remtries " more
11400 20 74 69 6d 65 73 22 29 0a 09 20 20 20 28 73 65 times").. (se
11410 74 21 20 72 65 6d 74 72 69 65 73 20 28 2d 20 72 t! remtries (- r
11420 65 6d 74 72 69 65 73 20 31 29 29 0a 09 20 20 20 emtries 1))..
11430 28 74 68 72 65 61 64 2d 73 6c 65 65 70 21 20 31 (thread-sleep! 1
11440 30 29 0a 09 20 20 20 28 74 65 73 74 73 3a 73 65 0).. (tests:se
11450 74 2d 66 75 6c 6c 2d 6d 65 74 61 2d 69 6e 66 6f t-full-meta-info
11460 20 64 62 20 74 65 73 74 2d 69 64 20 72 75 6e 2d db test-id run-
11470 69 64 20 6d 69 6e 75 74 65 73 20 77 6f 72 6b 2d id minutes work-
11480 61 72 65 61 20 28 2d 20 72 65 6d 74 72 69 65 73 area (- remtries
11490 20 31 29 29 29 0a 09 20 28 6c 65 74 20 28 28 65 1))).. (let ((e
114a0 72 72 2d 73 74 61 74 75 73 20 28 28 63 6f 6e 64 rr-status ((cond
114b0 69 74 69 6f 6e 2d 70 72 6f 70 65 72 74 79 2d 61 ition-property-a
114c0 63 63 65 73 73 6f 72 20 27 73 71 6c 69 74 65 33 ccessor 'sqlite3
114d0 20 27 73 74 61 74 75 73 20 23 66 29 20 65 78 6e 'status #f) exn
114e0 29 29 29 0a 09 20 20 20 28 64 65 62 75 67 3a 70 ))).. (debug:p
114f0 72 69 6e 74 2d 65 72 72 6f 72 20 30 20 2a 64 65 rint-error 0 *de
11500 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 fault-log-port*
11510 22 74 72 69 65 64 20 66 6f 72 20 6f 76 65 72 20 "tried for over
11520 61 20 6d 69 6e 75 74 65 20 74 6f 20 75 70 64 61 a minute to upda
11530 74 65 20 6d 65 74 61 20 69 6e 66 6f 20 61 6e 64 te meta info and
11540 20 66 61 69 6c 65 64 2e 20 47 69 76 69 6e 67 20 failed. Giving
11550 75 70 22 29 0a 09 20 20 20 28 64 65 62 75 67 3a up").. (debug:
11560 70 72 69 6e 74 20 30 20 2a 64 65 66 61 75 6c 74 print 0 *default
11570 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 45 58 43 45 -log-port* "EXCE
11580 50 54 49 4f 4e 3a 20 64 61 74 61 62 61 73 65 20 PTION: database
11590 70 72 6f 62 61 62 6c 79 20 6f 76 65 72 6c 6f 61 probably overloa
115a0 64 65 64 20 6f 72 20 75 6e 72 65 61 64 61 62 6c ded or unreadabl
115b0 65 2e 22 29 0a 09 20 20 20 28 64 65 62 75 67 3a e.").. (debug:
115c0 70 72 69 6e 74 20 30 20 2a 64 65 66 61 75 6c 74 print 0 *default
115d0 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 20 6d 65 73 -log-port* " mes
115e0 73 61 67 65 3a 20 22 20 28 28 63 6f 6e 64 69 74 sage: " ((condit
115f0 69 6f 6e 2d 70 72 6f 70 65 72 74 79 2d 61 63 63 ion-property-acc
11600 65 73 73 6f 72 20 27 65 78 6e 20 27 6d 65 73 73 essor 'exn 'mess
11610 61 67 65 29 20 65 78 6e 29 29 0a 09 20 20 20 28 age) exn)).. (
11620 64 65 62 75 67 3a 70 72 69 6e 74 20 35 20 2a 64 debug:print 5 *d
11630 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a efault-log-port*
11640 20 22 65 78 6e 3d 22 20 28 63 6f 6e 64 69 74 69 "exn=" (conditi
11650 6f 6e 2d 3e 6c 69 73 74 20 65 78 6e 29 29 0a 09 on->list exn))..
11660 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 (debug:print
11670 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 0 *default-log-p
11680 6f 72 74 2a 20 22 20 73 74 61 74 75 73 3a 20 20 ort* " status:
11690 22 20 28 28 63 6f 6e 64 69 74 69 6f 6e 2d 70 72 " ((condition-pr
116a0 6f 70 65 72 74 79 2d 61 63 63 65 73 73 6f 72 20 operty-accessor
116b0 27 73 71 6c 69 74 65 33 20 27 73 74 61 74 75 73 'sqlite3 'status
116c0 29 20 65 78 6e 29 29 0a 09 20 20 20 28 70 72 69 ) exn)).. (pri
116d0 6e 74 2d 63 61 6c 6c 2d 63 68 61 69 6e 20 28 63 nt-call-chain (c
116e0 75 72 72 65 6e 74 2d 65 72 72 6f 72 2d 70 6f 72 urrent-error-por
116f0 74 29 29 29 29 0a 20 20 20 20 20 28 74 65 73 74 t)))). (test
11700 73 3a 75 70 64 61 74 65 2d 74 65 73 74 64 61 74 s:update-testdat
11710 2d 6d 65 74 61 2d 69 6e 66 6f 20 64 62 20 74 65 -meta-info db te
11720 73 74 2d 69 64 20 77 6f 72 6b 2d 61 72 65 61 20 st-id work-area
11730 63 70 75 6c 6f 61 64 20 64 69 73 6b 66 72 65 65 cpuload diskfree
11740 20 6d 69 6e 75 74 65 73 29 0a 20 20 29 29 29 0a minutes). ))).
11750 09 20 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d . .;;===========
11760 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
11770 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
11780 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
11790 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 41 ===========.;; A
117a0 20 52 20 43 20 48 20 49 20 56 20 49 20 4e 20 47 R C H I V I N G
117b0 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d .;;=============
117c0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
117d0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
117e0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
117f0 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 28 64 65 66 69 =========..(defi
11800 6e 65 20 28 74 65 73 74 3a 61 72 63 68 69 76 65 ne (test:archive
11810 20 64 62 20 74 65 73 74 2d 69 64 29 0a 20 20 23 db test-id). #
11820 66 29 0a 0a 28 64 65 66 69 6e 65 20 28 74 65 73 f)..(define (tes
11830 74 3a 61 72 63 68 69 76 65 2d 74 65 73 74 73 20 t:archive-tests
11840 64 62 20 6b 65 79 6e 61 6d 65 73 20 74 61 72 67 db keynames targ
11850 65 74 29 0a 20 20 23 66 29 0a 0a et). #f)..