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 66 69 6c 65 2d s)))..(if (file-
08c0: 65 78 69 73 74 73 3f 20 68 65 64 29 0a 09 20 20 exists? hed)..
08d0: 20 20 28 66 6f 72 2d 65 61 63 68 20 28 6c 61 6d (for-each (lam
08e0: 62 64 61 20 28 74 65 73 74 2d 70 61 74 68 29 0a bda (test-path).
08f0: 09 09 09 28 6c 65 74 2a 20 28 28 74 6e 61 6d 65 ...(let* ((tname
0900: 20 20 20 28 6c 61 73 74 20 28 73 74 72 69 6e 67 (last (string
0910: 2d 73 70 6c 69 74 20 74 65 73 74 2d 70 61 74 68 -split test-path
0920: 20 22 2f 22 29 29 29 0a 09 09 09 20 20 20 20 20 "/")))....
0930: 20 20 28 74 63 6f 6e 66 69 67 20 28 63 6f 6e 63 (tconfig (conc
0940: 20 74 65 73 74 2d 70 61 74 68 20 22 2f 74 65 73 test-path "/tes
0950: 74 63 6f 6e 66 69 67 22 29 29 29 0a 09 09 09 20 tconfig")))....
0960: 20 28 69 66 20 28 61 6e 64 20 28 6e 6f 74 20 28 (if (and (not (
0970: 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 hash-table-ref/d
0980: 65 66 61 75 6c 74 20 74 65 73 74 2d 72 65 67 69 efault test-regi
0990: 73 74 72 79 20 74 6e 61 6d 65 20 23 66 29 29 0a stry tname #f)).
09a0: 09 09 09 09 20 20 20 28 66 69 6c 65 2d 65 78 69 .... (file-exi
09b0: 73 74 73 3f 20 74 63 6f 6e 66 69 67 29 29 0a 09 sts? tconfig))..
09c0: 09 09 20 20 20 20 20 20 28 68 61 73 68 2d 74 61 .. (hash-ta
09d0: 62 6c 65 2d 73 65 74 21 20 74 65 73 74 2d 72 65 ble-set! test-re
09e0: 67 69 73 74 72 79 20 74 6e 61 6d 65 20 74 65 73 gistry tname tes
09f0: 74 2d 70 61 74 68 29 29 29 29 0a 09 09 20 20 20 t-path))))...
0a00: 20 20 20 28 67 6c 6f 62 20 28 63 6f 6e 63 20 68 (glob (conc h
0a10: 65 64 20 22 2f 2a 22 29 29 29 29 0a 09 28 69 66 ed "/*"))))..(if
0a20: 20 28 6e 75 6c 6c 3f 20 74 61 6c 29 0a 09 20 20 (null? tal)..
0a30: 20 20 74 65 73 74 2d 72 65 67 69 73 74 72 79 0a test-registry.
0a40: 09 20 20 20 20 28 6c 6f 6f 70 20 28 63 61 72 20 . (loop (car
0a50: 74 61 6c 29 28 63 64 72 20 74 61 6c 29 29 29 29 tal)(cdr tal))))
0a60: 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 74 65 73 ))..(define (tes
0a70: 74 73 3a 66 69 6c 74 65 72 2d 74 65 73 74 2d 6e ts:filter-test-n
0a80: 61 6d 65 73 20 74 65 73 74 2d 6e 61 6d 65 73 20 ames test-names
0a90: 74 65 73 74 2d 70 61 74 74 73 29 0a 20 20 28 64 test-patts). (d
0aa0: 65 6c 65 74 65 2d 64 75 70 6c 69 63 61 74 65 73 elete-duplicates
0ab0: 0a 20 20 20 28 66 69 6c 74 65 72 20 28 6c 61 6d . (filter (lam
0ac0: 62 64 61 20 28 74 65 73 74 6e 61 6d 65 29 0a 09 bda (testname)..
0ad0: 20 20 20 20 20 28 74 65 73 74 73 3a 6d 61 74 63 (tests:matc
0ae0: 68 20 74 65 73 74 2d 70 61 74 74 73 20 74 65 73 h test-patts tes
0af0: 74 6e 61 6d 65 20 23 66 29 29 0a 09 20 20 20 74 tname #f)).. t
0b00: 65 73 74 2d 6e 61 6d 65 73 29 29 29 0a 0a 3b 3b est-names)))..;;
0b10: 20 69 74 65 6d 6d 61 70 20 69 73 20 61 20 6c 69 itemmap is a li
0b20: 73 74 20 6f 66 20 74 65 73 74 6e 61 6d 65 20 70 st of testname p
0b30: 61 74 74 65 72 6e 73 20 74 6f 20 6d 61 70 73 0a atterns to maps.
0b40: 3b 3b 20 20 20 20 20 74 65 73 74 31 20 2e 2a 2f ;; test1 .*/
0b50: 62 61 72 2f 28 5c 64 2b 29 20 66 6f 6f 2f 5c 31 bar/(\d+) foo/\1
0b60: 0a 3b 3b 20 20 20 20 20 25 20 20 20 20 20 66 6f .;; % fo
0b70: 6f 2f 28 5b 5e 2f 5d 2b 29 20 20 5c 31 2f 62 61 o/([^/]+) \1/ba
0b80: 72 0a 3b 3b 0a 3b 3b 20 23 20 4e 4f 54 45 3a 20 r.;;.;; # NOTE:
0b90: 74 68 65 20 6c 69 6e 65 20 77 69 74 68 20 74 68 the line with th
0ba0: 65 20 73 69 6e 67 6c 65 20 25 20 63 6f 75 6c 64 e single % could
0bb0: 20 62 65 20 74 68 65 20 72 65 73 75 6c 74 20 6f be the result o
0bc0: 66 0a 3b 3b 20 23 20 20 20 20 20 20 20 69 74 65 f.;; # ite
0bd0: 6d 6d 61 70 20 65 6e 74 72 79 20 69 6e 20 72 65 mmap entry in re
0be0: 71 75 69 72 65 6d 65 6e 74 73 20 28 6c 65 67 61 quirements (lega
0bf0: 63 79 29 2e 20 54 68 65 20 69 74 65 6d 6d 61 70 cy). The itemmap
0c00: 0a 3b 3b 20 23 20 20 20 20 20 20 20 72 65 71 75 .;; # requ
0c10: 69 72 65 6d 65 6e 74 73 20 65 6e 74 72 79 20 69 irements entry i
0c20: 73 20 64 65 70 72 65 63 61 74 65 64 0a 3b 3b 0a s deprecated.;;.
0c30: 28 64 65 66 69 6e 65 20 28 74 65 73 74 73 3a 67 (define (tests:g
0c40: 65 74 2d 69 74 65 6d 6d 61 70 73 20 74 63 6f 6e et-itemmaps tcon
0c50: 66 69 67 29 0a 20 20 28 6c 65 74 20 28 28 62 61 fig). (let ((ba
0c60: 73 65 2d 69 74 65 6d 6d 61 70 20 20 28 63 6f 6e se-itemmap (con
0c70: 66 69 67 66 3a 6c 6f 6f 6b 75 70 20 74 63 6f 6e figf:lookup tcon
0c80: 66 69 67 20 22 72 65 71 75 69 72 65 6d 65 6e 74 fig "requirement
0c90: 73 22 20 22 69 74 65 6d 6d 61 70 22 29 29 0a 09 s" "itemmap"))..
0ca0: 28 69 74 65 6d 6d 61 70 2d 74 61 62 6c 65 20 28 (itemmap-table (
0cb0: 63 6f 6e 66 69 67 66 3a 67 65 74 2d 73 65 63 74 configf:get-sect
0cc0: 69 6f 6e 20 74 63 6f 6e 66 69 67 20 22 69 74 65 ion tconfig "ite
0cd0: 6d 6d 61 70 22 29 29 29 0a 20 20 20 20 28 61 70 mmap"))). (ap
0ce0: 70 65 6e 64 20 28 69 66 20 62 61 73 65 2d 69 74 pend (if base-it
0cf0: 65 6d 6d 61 70 0a 09 09 28 6c 69 73 74 20 28 6c emmap...(list (l
0d00: 69 73 74 20 22 25 22 20 62 61 73 65 2d 69 74 65 ist "%" base-ite
0d10: 6d 6d 61 70 29 29 0a 09 09 27 28 29 29 0a 09 20 mmap))...'())..
0d20: 20 20 20 28 69 66 20 69 74 65 6d 6d 61 70 2d 74 (if itemmap-t
0d30: 61 62 6c 65 0a 09 09 69 74 65 6d 6d 61 70 2d 74 able...itemmap-t
0d40: 61 62 6c 65 0a 09 09 27 28 29 29 29 29 29 0a 0a able...'()))))..
0d50: 3b 3b 20 67 69 76 65 6e 20 61 20 6c 69 73 74 20 ;; given a list
0d60: 6f 66 20 69 74 65 6d 6d 61 70 73 20 28 74 65 73 of itemmaps (tes
0d70: 74 6e 61 6d 65 20 2e 20 6d 61 70 29 2c 20 72 65 tname . map), re
0d80: 74 75 72 6e 20 74 68 65 20 66 69 72 73 74 20 6d turn the first m
0d90: 61 74 63 68 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 atch.;;.(define
0da0: 28 74 65 73 74 73 3a 6c 6f 6f 6b 75 70 2d 69 74 (tests:lookup-it
0db0: 65 6d 6d 61 70 20 69 74 65 6d 6d 61 70 73 20 74 emmap itemmaps t
0dc0: 65 73 74 6e 61 6d 65 29 0a 20 20 28 6c 65 74 20 estname). (let
0dd0: 28 28 62 65 73 74 2d 6d 61 74 63 68 65 73 20 28 ((best-matches (
0de0: 66 69 6c 74 65 72 20 28 6c 61 6d 62 64 61 20 28 filter (lambda (
0df0: 69 74 65 6d 6d 61 70 29 0a 09 09 09 09 28 74 65 itemmap).....(te
0e00: 73 74 73 3a 6d 61 74 63 68 20 28 63 61 72 20 69 sts:match (car i
0e10: 74 65 6d 6d 61 70 29 20 74 65 73 74 6e 61 6d 65 temmap) testname
0e20: 20 23 66 29 29 0a 09 09 09 20 20 20 20 20 20 69 #f)).... i
0e30: 74 65 6d 6d 61 70 73 29 29 29 0a 20 20 20 20 28 temmaps))). (
0e40: 69 66 20 28 6e 75 6c 6c 3f 20 62 65 73 74 2d 6d if (null? best-m
0e50: 61 74 63 68 65 73 29 0a 09 23 66 0a 09 28 6c 65 atches)..#f..(le
0e60: 74 20 28 28 72 65 73 20 28 63 61 72 20 62 65 73 t ((res (car bes
0e70: 74 2d 6d 61 74 63 68 65 73 29 29 29 0a 09 20 20 t-matches)))..
0e80: 3b 3b 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 ;; (debug:print
0e90: 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 0 *default-log-p
0ea0: 6f 72 74 2a 20 22 72 65 73 3d 22 20 72 65 73 29 ort* "res=" res)
0eb0: 0a 09 20 20 28 63 6f 6e 64 0a 09 20 20 20 28 28 .. (cond.. ((
0ec0: 73 74 72 69 6e 67 3f 20 72 65 73 29 20 72 65 73 string? res) res
0ed0: 29 20 3b 3b 3b 20 46 49 58 20 54 48 45 20 52 4f ) ;;; FIX THE RO
0ee0: 4f 54 20 43 41 55 53 45 20 48 45 52 45 20 2e 2e OT CAUSE HERE ..
0ef0: 2e 2e 0a 09 20 20 20 28 28 6e 75 6c 6c 3f 20 72 .... ((null? r
0f00: 65 73 29 20 20 20 23 66 29 0a 09 20 20 20 28 28 es) #f).. ((
0f10: 73 74 72 69 6e 67 3f 20 28 63 64 72 20 72 65 73 string? (cdr res
0f20: 29 29 20 28 63 64 72 20 72 65 73 29 29 20 20 3b )) (cdr res)) ;
0f30: 3b 20 69 74 20 69 73 20 61 20 70 61 69 72 0a 09 ; it is a pair..
0f40: 20 20 20 28 28 73 74 72 69 6e 67 3f 20 28 63 61 ((string? (ca
0f50: 64 72 20 72 65 73 29 29 28 63 61 64 72 20 72 65 dr res))(cadr re
0f60: 73 29 29 20 3b 3b 20 69 74 20 69 73 20 61 20 6c s)) ;; it is a l
0f70: 69 73 74 0a 09 20 20 20 28 65 6c 73 65 20 63 61 ist.. (else ca
0f80: 64 72 20 72 65 73 29 29 29 29 29 29 0a 0a 3b 3b dr res))))))..;;
0f90: 20 72 65 74 75 72 6e 20 69 74 65 6d 73 20 67 69 return items gi
0fa0: 76 65 6e 20 63 6f 6e 66 69 67 0a 3b 3b 0a 28 64 ven config.;;.(d
0fb0: 65 66 69 6e 65 20 28 74 65 73 74 73 3a 67 65 74 efine (tests:get
0fc0: 2d 69 74 65 6d 73 20 74 63 6f 6e 66 69 67 29 0a -items tconfig).
0fd0: 20 20 28 6c 65 74 20 28 28 69 74 65 6d 73 20 20 (let ((items
0fe0: 20 20 20 20 28 68 61 73 68 2d 74 61 62 6c 65 2d (hash-table-
0ff0: 72 65 66 2f 64 65 66 61 75 6c 74 20 74 63 6f 6e ref/default tcon
1000: 66 69 67 20 22 69 74 65 6d 73 22 20 23 66 29 29 fig "items" #f))
1010: 20 3b 3b 20 69 74 65 6d 73 20 34 0a 09 28 69 74 ;; items 4..(it
1020: 65 6d 73 74 61 62 6c 65 20 28 68 61 73 68 2d 74 emstable (hash-t
1030: 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 able-ref/default
1040: 20 74 63 6f 6e 66 69 67 20 22 69 74 65 6d 73 74 tconfig "itemst
1050: 61 62 6c 65 22 20 23 66 29 29 29 20 0a 20 20 20 able" #f))) .
1060: 20 3b 3b 20 69 66 20 65 69 74 68 65 72 20 69 74 ;; if either it
1070: 65 6d 73 20 6f 72 20 69 74 65 6d 73 20 74 61 62 ems or items tab
1080: 6c 65 20 69 73 20 61 20 70 72 6f 63 20 72 65 74 le is a proc ret
1090: 75 72 6e 20 69 74 20 73 6f 20 74 65 73 74 20 72 urn it so test r
10a0: 75 6e 6e 69 6e 67 0a 20 20 20 20 3b 3b 20 70 72 unning. ;; pr
10b0: 6f 63 65 73 73 20 63 61 6e 20 6b 6e 6f 77 20 74 ocess can know t
10c0: 6f 20 63 61 6c 6c 20 69 74 65 6d 73 3a 67 65 74 o call items:get
10d0: 2d 69 74 65 6d 73 2d 66 72 6f 6d 2d 63 6f 6e 66 -items-from-conf
10e0: 69 67 0a 20 20 20 20 3b 3b 20 69 66 20 65 69 74 ig. ;; if eit
10f0: 68 65 72 20 69 73 20 61 20 6c 69 73 74 20 61 6e her is a list an
1100: 64 20 6e 6f 6e 65 20 69 73 20 61 20 70 72 6f 63 d none is a proc
1110: 20 67 6f 20 61 68 65 61 64 20 61 6e 64 20 63 61 go ahead and ca
1120: 6c 6c 20 67 65 74 2d 69 74 65 6d 73 0a 20 20 20 ll get-items.
1130: 20 3b 3b 20 6f 74 68 65 72 77 69 73 65 20 72 65 ;; otherwise re
1140: 74 75 72 6e 20 23 66 20 2d 20 74 68 69 73 20 69 turn #f - this i
1150: 73 20 6e 6f 74 20 61 6e 20 69 74 65 72 61 74 65 s not an iterate
1160: 64 20 74 65 73 74 0a 20 20 20 20 28 63 6f 6e 64 d test. (cond
1170: 0a 20 20 20 20 20 28 28 70 72 6f 63 65 64 75 72 . ((procedur
1180: 65 3f 20 69 74 65 6d 73 29 20 20 20 20 20 20 0a e? items) .
1190: 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 (debug:pri
11a0: 6e 74 2d 69 6e 66 6f 20 34 20 2a 64 65 66 61 75 nt-info 4 *defau
11b0: 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 69 74 lt-log-port* "it
11c0: 65 6d 73 20 69 73 20 61 20 70 72 6f 63 65 64 75 ems is a procedu
11d0: 72 65 2c 20 77 69 6c 6c 20 63 61 6c 63 20 6c 61 re, will calc la
11e0: 74 65 72 22 29 0a 20 20 20 20 20 20 69 74 65 6d ter"). item
11f0: 73 29 20 20 20 20 20 20 20 20 20 20 20 20 3b 3b s) ;;
1200: 20 63 61 6c 63 20 6c 61 74 65 72 0a 20 20 20 20 calc later.
1210: 20 28 28 70 72 6f 63 65 64 75 72 65 3f 20 69 74 ((procedure? it
1220: 65 6d 73 74 61 62 6c 65 29 0a 20 20 20 20 20 20 emstable).
1230: 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 (debug:print-inf
1240: 6f 20 34 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 o 4 *default-log
1250: 2d 70 6f 72 74 2a 20 22 69 74 65 6d 73 74 61 62 -port* "itemstab
1260: 6c 65 20 69 73 20 61 20 70 72 6f 63 65 64 75 72 le is a procedur
1270: 65 2c 20 77 69 6c 6c 20 63 61 6c 63 20 6c 61 74 e, will calc lat
1280: 65 72 22 29 0a 20 20 20 20 20 20 69 74 65 6d 73 er"). items
1290: 74 61 62 6c 65 29 20 20 20 20 20 20 20 3b 3b 20 table) ;;
12a0: 63 61 6c 63 20 6c 61 74 65 72 0a 20 20 20 20 20 calc later.
12b0: 28 28 66 69 6c 74 65 72 20 28 6c 61 6d 62 64 61 ((filter (lambda
12c0: 20 28 78 29 0a 09 09 28 6c 65 74 20 28 28 76 61 (x)...(let ((va
12d0: 6c 20 28 63 61 72 20 78 29 29 29 0a 09 09 20 20 l (car x)))...
12e0: 28 69 66 20 28 70 72 6f 63 65 64 75 72 65 3f 20 (if (procedure?
12f0: 76 61 6c 29 20 76 61 6c 20 23 66 29 29 29 0a 09 val) val #f)))..
1300: 20 20 20 20 20 20 28 61 70 70 65 6e 64 20 28 69 (append (i
1310: 66 20 28 6c 69 73 74 3f 20 69 74 65 6d 73 29 20 f (list? items)
1320: 69 74 65 6d 73 20 27 28 29 29 0a 09 09 20 20 20 items '())...
1330: 20 20 20 28 69 66 20 28 6c 69 73 74 3f 20 69 74 (if (list? it
1340: 65 6d 73 74 61 62 6c 65 29 20 69 74 65 6d 73 74 emstable) itemst
1350: 61 62 6c 65 20 27 28 29 29 29 29 0a 20 20 20 20 able '()))).
1360: 20 20 27 68 61 76 65 2d 70 72 6f 63 65 64 75 72 'have-procedur
1370: 65 29 0a 20 20 20 20 20 28 28 6f 72 20 28 6c 69 e). ((or (li
1380: 73 74 3f 20 69 74 65 6d 73 29 28 6c 69 73 74 3f st? items)(list?
1390: 20 69 74 65 6d 73 74 61 62 6c 65 29 29 20 3b 3b itemstable)) ;;
13a0: 20 63 61 6c 63 20 6e 6f 77 0a 20 20 20 20 20 20 calc now.
13b0: 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 (debug:print-inf
13c0: 6f 20 34 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 o 4 *default-log
13d0: 2d 70 6f 72 74 2a 20 22 69 74 65 6d 73 20 61 6e -port* "items an
13e0: 64 20 69 74 65 6d 73 74 61 62 6c 65 20 61 72 65 d itemstable are
13f0: 20 6c 69 73 74 73 2c 20 63 61 6c 63 20 6e 6f 77 lists, calc now
1400: 5c 6e 22 0a 09 09 09 22 20 20 20 20 69 74 65 6d \n"...." item
1410: 73 3a 20 22 20 69 74 65 6d 73 20 22 20 69 74 65 s: " items " ite
1420: 6d 73 74 61 62 6c 65 3a 20 22 20 69 74 65 6d 73 mstable: " items
1430: 74 61 62 6c 65 29 0a 20 20 20 20 20 20 28 69 74 table). (it
1440: 65 6d 73 3a 67 65 74 2d 69 74 65 6d 73 2d 66 72 ems:get-items-fr
1450: 6f 6d 2d 63 6f 6e 66 69 67 20 74 63 6f 6e 66 69 om-config tconfi
1460: 67 29 29 0a 20 20 20 20 20 28 65 6c 73 65 20 23 g)). (else #
1470: 66 29 29 29 29 20 20 20 20 20 20 20 20 20 20 20 f))))
1480: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1490: 3b 3b 20 6e 6f 74 20 69 74 65 72 61 74 65 64 0a ;; not iterated.
14a0: 0a 0a 3b 3b 20 72 65 74 75 72 6e 73 20 77 61 69 ..;; returns wai
14b0: 74 6f 6e 73 20 77 61 69 74 6f 72 73 20 74 63 6f tons waitors tco
14c0: 6e 66 69 67 64 61 74 0a 3b 3b 0a 28 64 65 66 69 nfigdat.;;.(defi
14d0: 6e 65 20 28 74 65 73 74 73 3a 67 65 74 2d 77 61 ne (tests:get-wa
14e0: 69 74 6f 6e 73 20 74 65 73 74 2d 6e 61 6d 65 20 itons test-name
14f0: 61 6c 6c 2d 74 65 73 74 73 2d 72 65 67 69 73 74 all-tests-regist
1500: 72 79 29 0a 20 20 20 28 6c 65 74 2a 20 28 28 63 ry). (let* ((c
1510: 6f 6e 66 69 67 20 20 28 74 65 73 74 73 3a 67 65 onfig (tests:ge
1520: 74 2d 74 65 73 74 63 6f 6e 66 69 67 20 74 65 73 t-testconfig tes
1530: 74 2d 6e 61 6d 65 20 23 66 20 61 6c 6c 2d 74 65 t-name #f all-te
1540: 73 74 73 2d 72 65 67 69 73 74 72 79 20 27 72 65 sts-registry 're
1550: 74 75 72 6e 2d 70 72 6f 63 73 29 29 29 0a 20 20 turn-procs))).
1560: 20 20 20 28 6c 65 74 20 28 28 69 6e 73 74 72 20 (let ((instr
1570: 28 69 66 20 63 6f 6e 66 69 67 20 0a 09 09 20 20 (if config ...
1580: 20 20 20 20 28 63 6f 6e 66 69 67 2d 6c 6f 6f 6b (config-look
1590: 75 70 20 63 6f 6e 66 69 67 20 22 72 65 71 75 69 up config "requi
15a0: 72 65 6d 65 6e 74 73 22 20 22 77 61 69 74 6f 6e rements" "waiton
15b0: 22 29 0a 09 09 20 20 20 20 20 20 28 62 65 67 69 ")... (begi
15c0: 6e 20 3b 3b 20 4e 6f 20 63 6f 6e 66 69 67 20 6d n ;; No config m
15d0: 65 61 6e 73 20 74 68 69 73 20 69 73 20 61 20 6e eans this is a n
15e0: 6f 6e 2d 65 78 69 73 74 61 6e 74 20 74 65 73 74 on-existant test
15f0: 0a 09 09 09 28 64 65 62 75 67 3a 70 72 69 6e 74 ....(debug:print
1600: 2d 65 72 72 6f 72 20 30 20 2a 64 65 66 61 75 6c -error 0 *defaul
1610: 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 6e 6f 6e t-log-port* "non
1620: 2d 65 78 69 73 74 65 6e 74 20 72 65 71 75 69 72 -existent requir
1630: 65 64 20 74 65 73 74 20 5c 22 22 20 74 65 73 74 ed test \"" test
1640: 2d 6e 61 6d 65 20 22 5c 22 22 29 0a 09 09 09 28 -name "\"")....(
1650: 65 78 69 74 20 31 29 29 29 29 0a 09 20 20 20 28 exit 1)))).. (
1660: 69 6e 73 74 72 32 20 28 69 66 20 63 6f 6e 66 69 instr2 (if confi
1670: 67 0a 09 09 20 20 20 20 20 20 20 28 63 6f 6e 66 g... (conf
1680: 69 67 2d 6c 6f 6f 6b 75 70 20 63 6f 6e 66 69 67 ig-lookup config
1690: 20 22 72 65 71 75 69 72 65 6d 65 6e 74 73 22 20 "requirements"
16a0: 22 77 61 69 74 6f 72 22 29 0a 09 09 20 20 20 20 "waitor")...
16b0: 20 20 20 22 22 29 29 29 0a 20 20 20 20 20 20 20 ""))).
16c0: 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 (debug:print-inf
16d0: 6f 20 38 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 o 8 *default-log
16e0: 2d 70 6f 72 74 2a 20 22 77 61 69 74 6f 6e 73 20 -port* "waitons
16f0: 73 74 72 69 6e 67 20 69 73 20 22 20 69 6e 73 74 string is " inst
1700: 72 20 22 2c 20 77 61 69 74 6f 72 73 20 73 74 72 r ", waitors str
1710: 69 6e 67 20 69 73 20 22 20 69 6e 73 74 72 32 29 ing is " instr2)
1720: 0a 20 20 20 20 20 20 20 28 6c 65 74 20 28 28 6e . (let ((n
1730: 65 77 77 61 69 74 6f 6e 73 0a 09 20 20 20 20 20 ewwaitons..
1740: 20 28 73 74 72 69 6e 67 2d 73 70 6c 69 74 20 28 (string-split (
1750: 63 6f 6e 64 0a 09 09 09 20 20 20 20 20 28 28 70 cond.... ((p
1760: 72 6f 63 65 64 75 72 65 3f 20 69 6e 73 74 72 29 rocedure? instr)
1770: 20 3b 3b 20 68 65 72 65 20 0a 09 09 09 20 20 20 ;; here ....
1780: 20 20 20 28 6c 65 74 20 28 28 72 65 73 20 28 69 (let ((res (i
1790: 6e 73 74 72 29 29 29 0a 09 09 09 09 28 64 65 62 nstr))).....(deb
17a0: 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 38 20 ug:print-info 8
17b0: 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 *default-log-por
17c0: 74 2a 20 22 77 61 69 74 6f 6e 20 70 72 6f 63 65 t* "waiton proce
17d0: 64 75 72 65 20 72 65 73 75 6c 74 73 20 69 6e 20 dure results in
17e0: 73 74 72 69 6e 67 20 22 20 72 65 73 20 22 20 66 string " res " f
17f0: 6f 72 20 74 65 73 74 20 22 20 74 65 73 74 2d 6e or test " test-n
1800: 61 6d 65 29 0a 09 09 09 09 72 65 73 29 29 0a 09 ame).....res))..
1810: 09 09 20 20 20 20 20 28 28 73 74 72 69 6e 67 3f .. ((string?
1820: 20 69 6e 73 74 72 29 20 20 20 20 20 69 6e 73 74 instr) inst
1830: 72 29 0a 09 09 09 20 20 20 20 20 28 65 6c 73 65 r).... (else
1840: 20 0a 09 09 09 20 20 20 20 20 20 3b 3b 20 4e 4f .... ;; NO
1850: 54 45 3a 20 54 68 69 73 20 69 73 20 61 63 74 75 TE: This is actu
1860: 61 6c 6c 79 20 74 68 65 20 63 61 73 65 20 6f 66 ally the case of
1870: 20 2a 6e 6f 2a 20 77 61 69 74 6f 6e 73 21 20 3b *no* waitons! ;
1880: 3b 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 65 ; (debug:print-e
1890: 72 72 6f 72 20 30 20 2a 64 65 66 61 75 6c 74 2d rror 0 *default-
18a0: 6c 6f 67 2d 70 6f 72 74 2a 20 22 73 6f 6d 65 74 log-port* "somet
18b0: 68 69 6e 67 20 77 65 6e 74 20 77 72 6f 6e 67 20 hing went wrong
18c0: 69 6e 20 70 72 6f 63 65 73 73 69 6e 67 20 77 61 in processing wa
18d0: 69 74 6f 6e 73 20 66 6f 72 20 74 65 73 74 20 22 itons for test "
18e0: 20 74 65 73 74 2d 6e 61 6d 65 29 0a 09 09 09 20 test-name)....
18f0: 20 20 20 20 20 22 22 29 29 29 29 0a 09 20 20 20 ""))))..
1900: 20 20 28 6e 65 77 77 61 69 74 6f 72 73 0a 09 20 (newwaitors..
1910: 20 20 20 20 20 28 73 74 72 69 6e 67 2d 73 70 6c (string-spl
1920: 69 74 20 28 63 6f 6e 64 0a 09 09 09 20 20 20 20 it (cond....
1930: 20 28 28 70 72 6f 63 65 64 75 72 65 3f 20 69 6e ((procedure? in
1940: 73 74 72 32 29 0a 09 09 09 20 20 20 20 20 20 28 str2).... (
1950: 6c 65 74 20 28 28 72 65 73 20 28 69 6e 73 74 72 let ((res (instr
1960: 32 29 29 29 0a 09 09 09 09 28 64 65 62 75 67 3a 2))).....(debug:
1970: 70 72 69 6e 74 2d 69 6e 66 6f 20 38 20 2a 64 65 print-info 8 *de
1980: 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 fault-log-port*
1990: 22 77 61 69 74 6f 72 20 70 72 6f 63 65 64 75 72 "waitor procedur
19a0: 65 20 72 65 73 75 6c 74 73 20 69 6e 20 73 74 72 e results in str
19b0: 69 6e 67 20 22 20 72 65 73 20 22 20 66 6f 72 20 ing " res " for
19c0: 74 65 73 74 20 22 20 74 65 73 74 2d 6e 61 6d 65 test " test-name
19d0: 29 0a 09 09 09 09 72 65 73 29 29 0a 09 09 09 20 ).....res))....
19e0: 20 20 20 20 28 28 73 74 72 69 6e 67 3f 20 69 6e ((string? in
19f0: 73 74 72 32 29 20 20 20 20 20 69 6e 73 74 72 32 str2) instr2
1a00: 29 0a 09 09 09 20 20 20 20 20 28 65 6c 73 65 20 ).... (else
1a10: 0a 09 09 09 20 20 20 20 20 20 3b 3b 20 4e 4f 54 .... ;; NOT
1a20: 45 3a 20 54 68 69 73 20 69 73 20 61 63 74 75 61 E: This is actua
1a30: 6c 6c 79 20 74 68 65 20 63 61 73 65 20 6f 66 20 lly the case of
1a40: 2a 6e 6f 2a 20 77 61 69 74 6f 6e 73 21 20 3b 3b *no* waitons! ;;
1a50: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 65 72 (debug:print-er
1a60: 72 6f 72 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c ror 0 *default-l
1a70: 6f 67 2d 70 6f 72 74 2a 20 22 73 6f 6d 65 74 68 og-port* "someth
1a80: 69 6e 67 20 77 65 6e 74 20 77 72 6f 6e 67 20 69 ing went wrong i
1a90: 6e 20 70 72 6f 63 65 73 73 69 6e 67 20 77 61 69 n processing wai
1aa0: 74 6f 6e 73 20 66 6f 72 20 74 65 73 74 20 22 20 tons for test "
1ab0: 74 65 73 74 2d 6e 61 6d 65 29 0a 09 09 09 20 20 test-name)....
1ac0: 20 20 20 20 22 22 29 29 29 29 29 0a 09 20 28 76 ""))))).. (v
1ad0: 61 6c 75 65 73 0a 09 20 20 3b 3b 20 74 68 65 20 alues.. ;; the
1ae0: 77 61 69 74 6f 6e 73 0a 09 20 20 28 66 69 6c 74 waitons.. (filt
1af0: 65 72 20 28 6c 61 6d 62 64 61 20 28 78 29 0a 09 er (lambda (x)..
1b00: 09 20 20 20 20 28 69 66 20 28 68 61 73 68 2d 74 . (if (hash-t
1b10: 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 able-ref/default
1b20: 20 61 6c 6c 2d 74 65 73 74 73 2d 72 65 67 69 73 all-tests-regis
1b30: 74 72 79 20 78 20 23 66 29 0a 09 09 09 23 74 0a try x #f)....#t.
1b40: 09 09 09 28 62 65 67 69 6e 0a 09 09 09 20 20 28 ...(begin.... (
1b50: 64 65 62 75 67 3a 70 72 69 6e 74 2d 65 72 72 6f debug:print-erro
1b60: 72 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 r 0 *default-log
1b70: 2d 70 6f 72 74 2a 20 22 74 65 73 74 20 22 20 74 -port* "test " t
1b80: 65 73 74 2d 6e 61 6d 65 20 22 20 68 61 73 20 75 est-name " has u
1b90: 6e 72 65 63 6f 67 6e 69 73 65 64 20 77 61 69 74 nrecognised wait
1ba0: 6f 6e 20 74 65 73 74 6e 61 6d 65 20 22 20 78 29 on testname " x)
1bb0: 0a 09 09 09 20 20 23 66 29 29 29 0a 09 09 20 20 .... #f)))...
1bc0: 6e 65 77 77 61 69 74 6f 6e 73 29 0a 09 20 20 28 newwaitons).. (
1bd0: 66 69 6c 74 65 72 20 28 6c 61 6d 62 64 61 20 28 filter (lambda (
1be0: 78 29 0a 09 09 20 20 20 20 28 69 66 20 28 68 61 x)... (if (ha
1bf0: 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 sh-table-ref/def
1c00: 61 75 6c 74 20 61 6c 6c 2d 74 65 73 74 73 2d 72 ault all-tests-r
1c10: 65 67 69 73 74 72 79 20 78 20 23 66 29 0a 09 09 egistry x #f)...
1c20: 09 23 74 0a 09 09 09 28 62 65 67 69 6e 0a 09 09 .#t....(begin...
1c30: 09 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d . (debug:print-
1c40: 65 72 72 6f 72 20 30 20 2a 64 65 66 61 75 6c 74 error 0 *default
1c50: 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 74 65 73 74 -log-port* "test
1c60: 20 22 20 74 65 73 74 2d 6e 61 6d 65 20 22 20 68 " test-name " h
1c70: 61 73 20 75 6e 72 65 63 6f 67 6e 69 73 65 64 20 as unrecognised
1c80: 77 61 69 74 6f 6e 20 74 65 73 74 6e 61 6d 65 20 waiton testname
1c90: 22 20 78 29 0a 09 09 09 20 20 23 66 29 29 29 0a " x).... #f))).
1ca0: 09 09 20 20 6e 65 77 77 61 69 74 6f 72 73 29 0a .. newwaitors).
1cb0: 09 20 20 63 6f 6e 66 69 67 29 29 29 29 29 0a 09 . config)))))..
1cc0: 09 09 09 09 20 20 20 20 20 0a 3b 3b 20 67 69 76 .... .;; giv
1cd0: 65 6e 20 77 61 69 74 69 6e 67 2d 74 65 73 74 20 en waiting-test
1ce0: 74 68 61 74 20 69 73 20 77 61 69 74 69 6e 67 20 that is waiting
1cf0: 6f 6e 20 77 61 69 74 6f 6e 2d 74 65 73 74 20 65 on waiton-test e
1d00: 78 74 65 6e 64 20 74 65 73 74 2d 70 61 74 74 20 xtend test-patt
1d10: 61 70 70 72 6f 70 72 69 61 74 65 6c 79 0a 3b 3b appropriately.;;
1d20: 0a 3b 3b 20 20 67 65 6e 6c 69 62 2f 74 65 73 74 .;; genlib/test
1d30: 63 6f 6e 66 69 67 20 20 20 20 20 20 20 20 20 20 config
1d40: 20 20 20 20 20 73 69 6d 2f 74 65 73 74 63 6f 6e sim/testcon
1d50: 66 69 67 0a 3b 3b 20 20 67 65 6e 6c 69 62 2f 73 fig.;; genlib/s
1d60: 63 68 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ch
1d70: 20 20 20 20 20 20 20 20 73 69 6d 2f 73 63 68 2f sim/sch/
1d80: 63 65 6c 6c 31 0a 3b 3b 0a 3b 3b 20 20 5b 72 65 cell1.;;.;; [re
1d90: 71 75 69 72 65 6d 65 6e 74 73 5d 20 20 20 20 20 quirements]
1da0: 20 20 20 20 20 20 20 20 20 20 20 20 20 5b 72 65 [re
1db0: 71 75 69 72 65 6d 65 6e 74 73 5d 0a 3b 3b 20 20 quirements].;;
1dc0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1dd0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1de0: 6d 6f 64 65 20 69 74 65 6d 77 61 69 74 0a 3b 3b mode itemwait.;;
1df0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1e00: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1e10: 20 20 23 20 74 72 69 6d 20 6f 66 66 20 74 68 65 # trim off the
1e20: 20 63 65 6c 6c 20 74 6f 20 64 65 74 65 72 6d 69 cell to determi
1e30: 6e 65 20 77 68 61 74 20 74 6f 20 72 75 6e 20 66 ne what to run f
1e40: 6f 72 20 67 65 6e 6c 69 62 0a 3b 3b 20 20 20 20 or genlib.;;
1e50: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1e60: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 69 74 it
1e70: 65 6d 6d 61 70 20 2f 2e 2a 0a 3b 3b 0a 3b 3b 20 emmap /.*.;;.;;
1e80: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1e90: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1ea0: 20 77 61 69 74 69 6e 67 2d 74 65 73 74 20 69 73 waiting-test is
1eb0: 20 77 61 69 74 69 6e 67 20 6f 6e 20 77 61 69 74 waiting on wait
1ec0: 6f 6e 2d 74 65 73 74 20 73 6f 20 77 65 20 6e 65 on-test so we ne
1ed0: 65 64 20 74 6f 20 63 72 65 61 74 65 20 61 20 70 ed to create a p
1ee0: 61 74 74 65 72 6e 20 66 6f 72 20 77 61 69 74 6f attern for waito
1ef0: 6e 2d 74 65 73 74 20 67 69 76 65 6e 20 77 61 69 n-test given wai
1f00: 74 69 6e 67 2d 74 65 73 74 20 61 6e 64 20 69 74 ting-test and it
1f10: 65 6d 6d 61 70 0a 28 64 65 66 69 6e 65 20 28 74 emmap.(define (t
1f20: 65 73 74 73 3a 65 78 74 65 6e 64 2d 74 65 73 74 ests:extend-test
1f30: 2d 70 61 74 74 73 20 74 65 73 74 2d 70 61 74 74 -patts test-patt
1f40: 20 77 61 69 74 69 6e 67 2d 74 65 73 74 20 77 61 waiting-test wa
1f50: 69 74 6f 6e 2d 74 65 73 74 20 69 74 65 6d 6d 61 iton-test itemma
1f60: 70 73 29 0a 20 20 28 6c 65 74 2a 20 28 28 69 74 ps). (let* ((it
1f70: 65 6d 6d 61 70 20 20 20 20 20 20 20 20 20 20 28 emmap (
1f80: 74 65 73 74 73 3a 6c 6f 6f 6b 75 70 2d 69 74 65 tests:lookup-ite
1f90: 6d 6d 61 70 20 69 74 65 6d 6d 61 70 73 20 77 61 mmap itemmaps wa
1fa0: 69 74 6f 6e 2d 74 65 73 74 29 29 0a 09 20 28 70 iton-test)).. (p
1fb0: 61 74 74 73 20 20 20 20 20 20 20 20 20 20 20 20 atts
1fc0: 28 73 74 72 69 6e 67 2d 73 70 6c 69 74 20 74 65 (string-split te
1fd0: 73 74 2d 70 61 74 74 20 22 2c 22 29 29 0a 09 20 st-patt ","))..
1fe0: 28 77 61 69 74 69 6e 67 2d 74 65 73 74 2d 6c 65 (waiting-test-le
1ff0: 6e 20 28 2b 20 28 73 74 72 69 6e 67 2d 6c 65 6e n (+ (string-len
2000: 67 74 68 20 77 61 69 74 69 6e 67 2d 74 65 73 74 gth waiting-test
2010: 29 20 31 29 29 0a 09 20 28 70 61 74 74 73 2d 77 ) 1)).. (patts-w
2020: 61 69 74 6f 6e 20 20 20 20 20 28 6d 61 70 20 28 aiton (map (
2030: 6c 61 6d 62 64 61 20 28 78 29 20 20 3b 3b 20 66 lambda (x) ;; f
2040: 6f 72 20 65 61 63 68 20 69 6e 63 6f 6d 69 6e 67 or each incoming
2050: 20 70 61 74 74 20 74 68 61 74 20 6d 61 74 63 68 patt that match
2060: 65 73 20 74 68 65 20 77 61 69 74 69 6e 67 20 74 es the waiting t
2070: 65 73 74 0a 09 09 09 09 20 20 28 6c 65 74 2a 20 est..... (let*
2080: 28 28 6d 6f 64 70 61 74 74 20 28 69 66 20 69 74 ((modpatt (if it
2090: 65 6d 6d 61 70 20 28 64 62 3a 63 6f 6e 76 65 72 emmap (db:conver
20a0: 74 2d 74 65 73 74 2d 69 74 65 6d 70 61 74 68 20 t-test-itempath
20b0: 78 20 69 74 65 6d 6d 61 70 29 20 78 29 29 20 0a x itemmap) x)) .
20c0: 09 09 09 09 09 20 28 6e 65 77 70 61 74 74 20 28 ..... (newpatt (
20d0: 63 6f 6e 63 20 77 61 69 74 6f 6e 2d 74 65 73 74 conc waiton-test
20e0: 20 22 2f 22 20 28 73 75 62 73 74 72 69 6e 67 20 "/" (substring
20f0: 6d 6f 64 70 61 74 74 20 77 61 69 74 69 6e 67 2d modpatt waiting-
2100: 74 65 73 74 2d 6c 65 6e 20 28 73 74 72 69 6e 67 test-len (string
2110: 2d 6c 65 6e 67 74 68 20 6d 6f 64 70 61 74 74 29 -length modpatt)
2120: 29 29 29 29 0a 09 09 09 09 20 20 20 20 3b 3b 20 ))))..... ;;
2130: 28 63 6f 6e 63 20 77 61 69 74 69 6e 67 2d 74 65 (conc waiting-te
2140: 73 74 20 22 2f 2c 22 20 77 61 69 74 69 6e 67 2d st "/," waiting-
2150: 74 65 73 74 20 22 2f 22 20 28 73 75 62 73 74 72 test "/" (substr
2160: 69 6e 67 20 6d 6f 64 70 61 74 74 20 77 61 69 74 ing modpatt wait
2170: 6f 6e 2d 74 65 73 74 2d 6c 65 6e 20 28 73 74 72 on-test-len (str
2180: 69 6e 67 2d 6c 65 6e 67 74 68 20 6d 6f 64 70 61 ing-length modpa
2190: 74 74 29 29 29 29 29 0a 09 09 09 09 20 20 20 20 tt))))).....
21a0: 3b 3b 20 28 70 72 69 6e 74 20 22 69 6e 20 6d 61 ;; (print "in ma
21b0: 70 2c 20 78 3d 22 20 78 20 22 2c 20 6e 65 77 70 p, x=" x ", newp
21c0: 61 74 74 3d 22 20 6e 65 77 70 61 74 74 29 0a 09 att=" newpatt)..
21d0: 09 09 09 20 20 20 20 6e 65 77 70 61 74 74 29 29 ... newpatt))
21e0: 0a 09 09 09 09 28 66 69 6c 74 65 72 20 28 6c 61 .....(filter (la
21f0: 6d 62 64 61 20 28 78 29 0a 09 09 09 09 09 20 20 mbda (x)......
2200: 28 65 71 3f 20 28 73 75 62 73 74 72 69 6e 67 2d (eq? (substring-
2210: 69 6e 64 65 78 20 28 63 6f 6e 63 20 77 61 69 74 index (conc wait
2220: 69 6e 67 2d 74 65 73 74 20 22 2f 22 29 20 78 29 ing-test "/") x)
2230: 20 30 29 29 20 3b 3b 20 69 73 20 74 68 69 73 20 0)) ;; is this
2240: 70 61 74 74 20 70 65 72 74 69 6e 65 6e 74 20 74 patt pertinent t
2250: 6f 20 74 68 65 20 77 61 69 74 69 6e 67 20 74 65 o the waiting te
2260: 73 74 0a 09 09 09 09 09 70 61 74 74 73 29 29 29 st......patts)))
2270: 29 0a 20 20 20 20 28 73 74 72 69 6e 67 2d 69 6e ). (string-in
2280: 74 65 72 73 70 65 72 73 65 20 28 64 65 6c 65 74 tersperse (delet
2290: 65 2d 64 75 70 6c 69 63 61 74 65 73 20 28 61 70 e-duplicates (ap
22a0: 70 65 6e 64 20 70 61 74 74 73 20 28 69 66 20 28 pend patts (if (
22b0: 6e 75 6c 6c 3f 20 70 61 74 74 73 2d 77 61 69 74 null? patts-wait
22c0: 6f 6e 29 0a 09 09 09 09 09 09 09 20 20 20 20 20 on)........
22d0: 28 6c 69 73 74 20 28 63 6f 6e 63 20 77 61 69 74 (list (conc wait
22e0: 6f 6e 2d 74 65 73 74 20 22 2f 25 22 29 29 20 3b on-test "/%")) ;
22f0: 3b 20 72 65 61 6c 6c 79 20 73 68 6f 75 6c 64 6e ; really shouldn
2300: 27 74 20 61 64 64 20 74 68 65 20 77 61 69 74 6f 't add the waito
2310: 6e 20 66 6f 72 63 65 66 75 6c 6c 79 20 6c 69 6b n forcefully lik
2320: 65 20 74 68 69 73 0a 09 09 09 09 09 09 09 20 20 e this........
2330: 20 20 20 70 61 74 74 73 2d 77 61 69 74 6f 6e 29 patts-waiton)
2340: 29 29 0a 09 09 09 22 2c 22 29 29 29 0a 0a 0a 20 ))....",")))...
2350: 20 0a 3b 3b 20 74 65 73 74 73 3a 67 6c 6f 62 2d .;; tests:glob-
2360: 6c 69 6b 65 2d 6d 61 74 63 68 20 0a 28 64 65 66 like-match .(def
2370: 69 6e 65 20 28 74 65 73 74 73 3a 67 6c 6f 62 2d ine (tests:glob-
2380: 6c 69 6b 65 2d 6d 61 74 63 68 20 70 61 74 74 20 like-match patt
2390: 73 74 72 29 20 0a 20 20 28 6c 65 74 20 28 28 6c str) . (let ((l
23a0: 69 6b 65 20 28 73 75 62 73 74 72 69 6e 67 2d 69 ike (substring-i
23b0: 6e 64 65 78 20 22 25 22 20 70 61 74 74 29 29 29 ndex "%" patt)))
23c0: 0a 20 20 20 20 28 6c 65 74 2a 20 28 28 6e 6f 74 . (let* ((not
23d0: 70 61 74 74 20 20 28 65 71 75 61 6c 3f 20 28 73 patt (equal? (s
23e0: 75 62 73 74 72 69 6e 67 2d 69 6e 64 65 78 20 22 ubstring-index "
23f0: 7e 22 20 70 61 74 74 29 20 30 29 29 0a 09 20 20 ~" patt) 0))..
2400: 20 28 6e 65 77 70 61 74 74 20 20 28 69 66 20 6e (newpatt (if n
2410: 6f 74 70 61 74 74 20 28 73 75 62 73 74 72 69 6e otpatt (substrin
2420: 67 20 70 61 74 74 20 31 29 20 70 61 74 74 29 29 g patt 1) patt))
2430: 0a 09 20 20 20 28 66 69 6e 70 61 74 74 20 20 28 .. (finpatt (
2440: 69 66 20 6c 69 6b 65 0a 09 09 09 28 73 74 72 69 if like....(stri
2450: 6e 67 2d 73 75 62 73 74 69 74 75 74 65 20 28 72 ng-substitute (r
2460: 65 67 65 78 70 20 22 25 22 29 20 22 2e 2a 22 20 egexp "%") ".*"
2470: 6e 65 77 70 61 74 74 20 23 66 29 0a 09 09 09 28 newpatt #f)....(
2480: 73 74 72 69 6e 67 2d 73 75 62 73 74 69 74 75 74 string-substitut
2490: 65 20 28 72 65 67 65 78 70 20 22 5c 5c 2a 22 29 e (regexp "\\*")
24a0: 20 22 2e 2a 22 20 6e 65 77 70 61 74 74 20 23 66 ".*" newpatt #f
24b0: 29 29 29 0a 09 20 20 20 28 72 65 73 20 20 20 20 ))).. (res
24c0: 20 20 23 66 29 29 0a 20 20 20 20 20 20 3b 3b 20 #f)). ;;
24d0: 28 70 72 69 6e 74 20 22 74 65 73 74 73 3a 67 6c (print "tests:gl
24e0: 6f 62 2d 6c 69 6b 65 2d 6d 61 74 63 68 20 3d 3e ob-like-match =>
24f0: 20 6e 6f 74 70 61 74 74 3a 20 22 20 6e 6f 74 70 notpatt: " notp
2500: 61 74 74 20 22 2c 20 6e 65 77 70 61 74 74 3a 20 att ", newpatt:
2510: 22 20 6e 65 77 70 61 74 74 20 22 2c 20 66 69 6e " newpatt ", fin
2520: 70 61 74 74 3a 20 22 20 66 69 6e 70 61 74 74 29 patt: " finpatt)
2530: 0a 20 20 20 20 20 20 28 73 65 74 21 20 72 65 73 . (set! res
2540: 20 28 73 74 72 69 6e 67 2d 6d 61 74 63 68 20 28 (string-match (
2550: 72 65 67 65 78 70 20 66 69 6e 70 61 74 74 20 28 regexp finpatt (
2560: 69 66 20 6c 69 6b 65 20 23 74 20 23 66 29 29 20 if like #t #f))
2570: 73 74 72 29 29 0a 20 20 20 20 20 20 28 69 66 20 str)). (if
2580: 6e 6f 74 70 61 74 74 20 28 6e 6f 74 20 72 65 73 notpatt (not res
2590: 29 20 72 65 73 29 29 29 29 0a 0a 3b 3b 20 69 66 ) res))))..;; if
25a0: 20 69 74 65 6d 70 61 74 68 20 69 73 20 23 66 20 itempath is #f
25b0: 74 68 65 6e 20 6c 6f 6f 6b 20 6f 6e 6c 79 20 61 then look only a
25c0: 74 20 74 68 65 20 74 65 73 74 6e 61 6d 65 20 70 t the testname p
25d0: 61 72 74 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 art.;;.(define (
25e0: 74 65 73 74 73 3a 6d 61 74 63 68 20 70 61 74 74 tests:match patt
25f0: 65 72 6e 73 20 74 65 73 74 6e 61 6d 65 20 69 74 erns testname it
2600: 65 6d 70 61 74 68 20 23 21 6b 65 79 20 28 72 65 empath #!key (re
2610: 71 75 69 72 65 64 20 27 28 29 29 29 0a 20 20 28 quired '())). (
2620: 69 66 20 28 73 74 72 69 6e 67 3f 20 70 61 74 74 if (string? patt
2630: 65 72 6e 73 29 0a 20 20 20 20 20 20 28 6c 65 74 erns). (let
2640: 20 28 28 70 61 74 74 73 20 28 61 70 70 65 6e 64 ((patts (append
2650: 20 28 73 74 72 69 6e 67 2d 73 70 6c 69 74 20 70 (string-split p
2660: 61 74 74 65 72 6e 73 20 22 2c 22 29 20 72 65 71 atterns ",") req
2670: 75 69 72 65 64 29 29 29 0a 09 28 69 66 20 28 6e uired)))..(if (n
2680: 75 6c 6c 3f 20 70 61 74 74 73 29 20 3b 3b 3b 20 ull? patts) ;;;
2690: 6e 6f 20 70 61 74 74 65 72 6e 28 73 29 20 6d 65 no pattern(s) me
26a0: 61 6e 73 20 6e 6f 20 6d 61 74 63 68 0a 09 20 20 ans no match..
26b0: 20 20 23 66 0a 09 20 20 20 20 28 6c 65 74 20 6c #f.. (let l
26c0: 6f 6f 70 20 28 28 70 61 74 74 20 28 63 61 72 20 oop ((patt (car
26d0: 70 61 74 74 73 29 29 0a 09 09 20 20 20 20 20 20 patts))...
26e0: 20 28 74 61 6c 20 20 28 63 64 72 20 70 61 74 74 (tal (cdr patt
26f0: 73 29 29 29 0a 09 20 20 20 20 20 20 3b 3b 20 28 s))).. ;; (
2700: 70 72 69 6e 74 20 22 6c 6f 6f 70 3a 20 70 61 74 print "loop: pat
2710: 74 3a 20 22 20 70 61 74 74 20 22 2c 20 74 61 6c t: " patt ", tal
2720: 20 22 20 74 61 6c 29 0a 09 20 20 20 20 20 20 28 " tal).. (
2730: 69 66 20 28 73 74 72 69 6e 67 3d 3f 20 70 61 74 if (string=? pat
2740: 74 20 22 22 29 0a 09 09 20 20 23 66 20 3b 3b 20 t "")... #f ;;
2750: 6e 6f 74 68 69 6e 67 20 65 76 65 72 20 6d 61 74 nothing ever mat
2760: 63 68 65 73 20 65 6d 70 74 79 20 73 74 72 69 6e ches empty strin
2770: 67 20 2d 20 70 6f 6c 69 63 79 0a 09 09 20 20 28 g - policy... (
2780: 6c 65 74 2a 20 28 28 70 61 74 74 2d 70 61 72 74 let* ((patt-part
2790: 73 20 28 73 74 72 69 6e 67 2d 6d 61 74 63 68 20 s (string-match
27a0: 28 72 65 67 65 78 70 20 22 5e 28 5b 5e 5c 5c 2f (regexp "^([^\\/
27b0: 5d 2a 29 28 5c 5c 2f 28 2e 2a 29 7c 29 24 22 29 ]*)(\\/(.*)|)$")
27c0: 20 70 61 74 74 29 29 0a 09 09 09 20 28 74 65 73 patt)).... (tes
27d0: 74 2d 70 61 74 74 20 20 28 63 61 64 72 20 70 61 t-patt (cadr pa
27e0: 74 74 2d 70 61 72 74 73 29 29 0a 09 09 09 20 28 tt-parts)).... (
27f0: 69 74 65 6d 2d 70 61 74 74 20 20 28 63 61 64 64 item-patt (cadd
2800: 64 72 20 70 61 74 74 2d 70 61 72 74 73 29 29 29 dr patt-parts)))
2810: 0a 09 09 20 20 20 20 3b 3b 20 73 70 65 63 69 61 ... ;; specia
2820: 6c 20 63 61 73 65 3a 20 74 65 73 74 20 76 73 2e l case: test vs.
2830: 20 74 65 73 74 2f 0a 09 09 20 20 20 20 3b 3b 20 test/... ;;
2840: 20 20 74 65 73 74 20 20 3d 3e 20 22 74 65 73 74 test => "test
2850: 22 20 22 25 22 0a 09 09 20 20 20 20 3b 3b 20 20 " "%"... ;;
2860: 20 74 65 73 74 2f 20 3d 3e 20 22 74 65 73 74 22 test/ => "test"
2870: 20 22 22 0a 09 09 20 20 20 20 28 69 66 20 28 61 ""... (if (a
2880: 6e 64 20 28 6e 6f 74 20 28 73 75 62 73 74 72 69 nd (not (substri
2890: 6e 67 2d 69 6e 64 65 78 20 22 2f 22 20 70 61 74 ng-index "/" pat
28a0: 74 29 29 20 3b 3b 20 6e 6f 20 73 6c 61 73 68 20 t)) ;; no slash
28b0: 69 6e 20 74 68 65 20 6f 72 69 67 69 6e 61 6c 0a in the original.
28c0: 09 09 09 20 20 20 20 20 28 6f 72 20 28 6e 6f 74 ... (or (not
28d0: 20 69 74 65 6d 2d 70 61 74 74 29 0a 09 09 09 09 item-patt).....
28e0: 20 28 65 71 75 61 6c 3f 20 69 74 65 6d 2d 70 61 (equal? item-pa
28f0: 74 74 20 22 22 29 29 29 20 20 20 20 20 20 3b 3b tt ""))) ;;
2900: 20 73 68 6f 75 6c 64 20 61 6c 77 61 79 73 20 62 should always b
2910: 65 20 74 72 75 65 20 74 68 61 74 20 69 74 65 6d e true that item
2920: 2d 70 61 74 74 20 69 73 20 22 22 0a 09 09 09 28 -patt is ""....(
2930: 73 65 74 21 20 69 74 65 6d 2d 70 61 74 74 20 22 set! item-patt "
2940: 25 22 29 29 0a 09 09 20 20 20 20 3b 3b 20 28 70 %"))... ;; (p
2950: 72 69 6e 74 20 22 74 65 73 74 73 3a 6d 61 74 63 rint "tests:matc
2960: 68 20 3d 3e 20 70 61 74 74 2d 70 61 72 74 73 3a h => patt-parts:
2970: 20 22 20 70 61 74 74 2d 70 61 72 74 73 20 22 2c " patt-parts ",
2980: 20 74 65 73 74 2d 70 61 74 74 3a 20 22 20 74 65 test-patt: " te
2990: 73 74 2d 70 61 74 74 20 22 2c 20 69 74 65 6d 2d st-patt ", item-
29a0: 70 61 74 74 3a 20 22 20 69 74 65 6d 2d 70 61 74 patt: " item-pat
29b0: 74 29 0a 09 09 20 20 20 20 28 69 66 20 28 61 6e t)... (if (an
29c0: 64 20 28 74 65 73 74 73 3a 67 6c 6f 62 2d 6c 69 d (tests:glob-li
29d0: 6b 65 2d 6d 61 74 63 68 20 74 65 73 74 2d 70 61 ke-match test-pa
29e0: 74 74 20 74 65 73 74 6e 61 6d 65 29 0a 09 09 09 tt testname)....
29f0: 20 20 20 20 20 28 6f 72 20 28 6e 6f 74 20 69 74 (or (not it
2a00: 65 6d 70 61 74 68 29 0a 09 09 09 09 20 28 74 65 empath)..... (te
2a10: 73 74 73 3a 67 6c 6f 62 2d 6c 69 6b 65 2d 6d 61 sts:glob-like-ma
2a20: 74 63 68 20 28 69 66 20 69 74 65 6d 2d 70 61 74 tch (if item-pat
2a30: 74 20 69 74 65 6d 2d 70 61 74 74 20 22 22 29 20 t item-patt "")
2a40: 69 74 65 6d 70 61 74 68 29 29 29 0a 09 09 09 23 itempath)))....#
2a50: 74 0a 09 09 09 28 69 66 20 28 6e 75 6c 6c 3f 20 t....(if (null?
2a60: 74 61 6c 29 0a 09 09 09 20 20 20 20 23 66 0a 09 tal).... #f..
2a70: 09 09 20 20 20 20 28 6c 6f 6f 70 20 28 63 61 72 .. (loop (car
2a80: 20 74 61 6c 29 28 63 64 72 20 74 61 6c 29 29 29 tal)(cdr tal)))
2a90: 29 29 29 29 29 29 29 29 0a 0a 3b 3b 20 69 66 20 ))))))))..;; if
2aa0: 69 74 65 6d 70 61 74 68 20 69 73 20 23 66 20 74 itempath is #f t
2ab0: 68 65 6e 20 6c 6f 6f 6b 20 6f 6e 6c 79 20 61 74 hen look only at
2ac0: 20 74 68 65 20 74 65 73 74 6e 61 6d 65 20 70 61 the testname pa
2ad0: 72 74 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 74 rt.;;.(define (t
2ae0: 65 73 74 73 3a 6d 61 74 63 68 2d 3e 73 71 6c 71 ests:match->sqlq
2af0: 72 79 20 70 61 74 74 65 72 6e 73 29 0a 20 20 28 ry patterns). (
2b00: 69 66 20 28 73 74 72 69 6e 67 3f 20 70 61 74 74 if (string? patt
2b10: 65 72 6e 73 29 0a 20 20 20 20 20 20 28 6c 65 74 erns). (let
2b20: 20 28 28 70 61 74 74 73 20 28 73 74 72 69 6e 67 ((patts (string
2b30: 2d 73 70 6c 69 74 20 70 61 74 74 65 72 6e 73 20 -split patterns
2b40: 22 2c 22 29 29 29 0a 09 28 69 66 20 28 6e 75 6c ",")))..(if (nul
2b50: 6c 3f 20 70 61 74 74 73 29 20 3b 3b 3b 20 6e 6f l? patts) ;;; no
2b60: 20 70 61 74 74 65 72 6e 28 73 29 20 6d 65 61 6e pattern(s) mean
2b70: 73 20 6e 6f 20 6d 61 74 63 68 2c 20 77 65 20 77 s no match, we w
2b80: 69 6c 6c 20 64 6f 20 6e 6f 20 71 75 65 72 79 0a ill do no query.
2b90: 09 20 20 20 20 23 66 0a 09 20 20 20 20 28 6c 65 . #f.. (le
2ba0: 74 20 6c 6f 6f 70 20 28 28 70 61 74 74 20 28 63 t loop ((patt (c
2bb0: 61 72 20 70 61 74 74 73 29 29 0a 09 09 20 20 20 ar patts))...
2bc0: 20 20 20 20 28 74 61 6c 20 20 28 63 64 72 20 70 (tal (cdr p
2bd0: 61 74 74 73 29 29 0a 09 09 20 20 20 20 20 20 20 atts))...
2be0: 28 72 65 73 20 20 27 28 29 29 29 0a 09 20 20 20 (res '()))..
2bf0: 20 20 20 3b 3b 20 28 70 72 69 6e 74 20 22 6c 6f ;; (print "lo
2c00: 6f 70 3a 20 70 61 74 74 3a 20 22 20 70 61 74 74 op: patt: " patt
2c10: 20 22 2c 20 74 61 6c 20 22 20 74 61 6c 29 0a 09 ", tal " tal)..
2c20: 20 20 20 20 20 20 28 6c 65 74 2a 20 28 28 70 61 (let* ((pa
2c30: 74 74 2d 70 61 72 74 73 20 28 73 74 72 69 6e 67 tt-parts (string
2c40: 2d 6d 61 74 63 68 20 28 72 65 67 65 78 70 20 22 -match (regexp "
2c50: 5e 28 5b 5e 5c 5c 2f 5d 2a 29 28 5c 5c 2f 28 2e ^([^\\/]*)(\\/(.
2c60: 2a 29 7c 29 24 22 29 20 70 61 74 74 29 29 0a 09 *)|)$") patt))..
2c70: 09 20 20 20 20 20 28 74 65 73 74 2d 70 61 74 74 . (test-patt
2c80: 20 20 28 63 61 64 72 20 70 61 74 74 2d 70 61 72 (cadr patt-par
2c90: 74 73 29 29 0a 09 09 20 20 20 20 20 28 69 74 65 ts))... (ite
2ca0: 6d 2d 70 61 74 74 20 20 28 63 61 64 64 64 72 20 m-patt (cadddr
2cb0: 70 61 74 74 2d 70 61 72 74 73 29 29 0a 09 09 20 patt-parts))...
2cc0: 20 20 20 20 28 74 65 73 74 2d 71 72 79 20 20 20 (test-qry
2cd0: 28 64 62 3a 70 61 74 74 2d 3e 6c 69 6b 65 20 22 (db:patt->like "
2ce0: 74 65 73 74 6e 61 6d 65 22 20 74 65 73 74 2d 70 testname" test-p
2cf0: 61 74 74 29 29 0a 09 09 20 20 20 20 20 28 69 74 att))... (it
2d00: 65 6d 2d 71 72 79 20 20 20 28 64 62 3a 70 61 74 em-qry (db:pat
2d10: 74 2d 3e 6c 69 6b 65 20 22 69 74 65 6d 5f 70 61 t->like "item_pa
2d20: 74 68 22 20 69 74 65 6d 2d 70 61 74 74 29 29 0a th" item-patt)).
2d30: 09 09 20 20 20 20 20 28 71 72 79 20 20 20 20 20 .. (qry
2d40: 20 20 20 28 63 6f 6e 63 20 22 28 22 20 74 65 73 (conc "(" tes
2d50: 74 2d 71 72 79 20 22 20 41 4e 44 20 22 20 69 74 t-qry " AND " it
2d60: 65 6d 2d 71 72 79 20 22 29 22 29 29 29 0a 09 09 em-qry ")")))...
2d70: 3b 3b 20 28 70 72 69 6e 74 20 22 74 65 73 74 73 ;; (print "tests
2d80: 3a 6d 61 74 63 68 20 3d 3e 20 70 61 74 74 2d 70 :match => patt-p
2d90: 61 72 74 73 3a 20 22 20 70 61 74 74 2d 70 61 72 arts: " patt-par
2da0: 74 73 20 22 2c 20 74 65 73 74 2d 70 61 74 74 3a ts ", test-patt:
2db0: 20 22 20 74 65 73 74 2d 70 61 74 74 20 22 2c 20 " test-patt ",
2dc0: 69 74 65 6d 2d 70 61 74 74 3a 20 22 20 69 74 65 item-patt: " ite
2dd0: 6d 2d 70 61 74 74 29 0a 09 09 28 69 66 20 28 6e m-patt)...(if (n
2de0: 75 6c 6c 3f 20 74 61 6c 29 0a 09 09 20 20 20 20 ull? tal)...
2df0: 28 73 74 72 69 6e 67 2d 69 6e 74 65 72 73 70 65 (string-interspe
2e00: 72 73 65 20 28 61 70 70 65 6e 64 20 28 72 65 76 rse (append (rev
2e10: 65 72 73 65 20 72 65 73 29 28 6c 69 73 74 20 71 erse res)(list q
2e20: 72 79 29 29 20 22 20 4f 52 20 22 29 0a 09 09 20 ry)) " OR ")...
2e30: 20 20 20 28 6c 6f 6f 70 20 28 63 61 72 20 74 61 (loop (car ta
2e40: 6c 29 28 63 64 72 20 74 61 6c 29 28 63 6f 6e 73 l)(cdr tal)(cons
2e50: 20 71 72 79 20 72 65 73 29 29 29 29 29 29 29 0a qry res))))))).
2e60: 20 20 20 20 20 20 23 66 29 29 0a 0a 3b 3b 20 43 #f))..;; C
2e70: 68 65 63 6b 20 66 6f 72 20 77 61 69 76 65 72 20 heck for waiver
2e80: 65 6c 69 67 69 62 69 6c 69 74 79 0a 3b 3b 0a 28 eligibility.;;.(
2e90: 64 65 66 69 6e 65 20 28 74 65 73 74 73 3a 63 68 define (tests:ch
2ea0: 65 63 6b 2d 77 61 69 76 65 72 2d 65 6c 69 67 69 eck-waiver-eligi
2eb0: 62 69 6c 69 74 79 20 74 65 73 74 64 61 74 20 70 bility testdat p
2ec0: 72 65 76 2d 74 65 73 74 64 61 74 29 0a 20 20 28 rev-testdat). (
2ed0: 6c 65 74 2a 20 28 28 74 65 73 74 2d 72 65 67 69 let* ((test-regi
2ee0: 73 74 72 79 20 28 6d 61 6b 65 2d 68 61 73 68 2d stry (make-hash-
2ef0: 74 61 62 6c 65 29 29 0a 09 20 28 74 65 73 74 63 table)).. (testc
2f00: 6f 6e 66 69 67 20 20 28 74 65 73 74 73 3a 67 65 onfig (tests:ge
2f10: 74 2d 74 65 73 74 63 6f 6e 66 69 67 20 28 64 62 t-testconfig (db
2f20: 3a 74 65 73 74 2d 67 65 74 2d 74 65 73 74 6e 61 :test-get-testna
2f30: 6d 65 20 74 65 73 74 64 61 74 29 20 28 64 62 3a me testdat) (db:
2f40: 74 65 73 74 2d 67 65 74 2d 69 74 65 6d 2d 70 61 test-get-item-pa
2f50: 74 68 20 74 65 73 74 64 61 74 29 20 74 65 73 74 th testdat) test
2f60: 2d 72 65 67 69 73 74 72 79 20 23 66 29 29 0a 09 -registry #f))..
2f70: 20 28 74 65 73 74 2d 72 75 6e 64 69 72 20 3b 3b (test-rundir ;;
2f80: 20 28 73 64 62 3a 71 72 79 20 27 70 61 73 73 73 (sdb:qry 'passs
2f90: 74 72 20 0a 09 20 20 28 64 62 3a 74 65 73 74 2d tr .. (db:test-
2fa0: 67 65 74 2d 72 75 6e 64 69 72 20 74 65 73 74 64 get-rundir testd
2fb0: 61 74 29 29 20 3b 3b 20 29 0a 09 20 28 70 72 65 at)) ;; ).. (pre
2fc0: 76 2d 72 75 6e 64 69 72 20 3b 3b 20 28 73 64 62 v-rundir ;; (sdb
2fd0: 3a 71 72 79 20 27 70 61 73 73 73 74 72 20 0a 09 :qry 'passstr ..
2fe0: 20 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 72 (db:test-get-r
2ff0: 75 6e 64 69 72 20 70 72 65 76 2d 74 65 73 74 64 undir prev-testd
3000: 61 74 29 29 20 3b 3b 20 29 0a 09 20 28 77 61 69 at)) ;; ).. (wai
3010: 76 65 72 73 20 20 20 20 20 28 69 66 20 74 65 73 vers (if tes
3020: 74 63 6f 6e 66 69 67 20 28 63 6f 6e 66 69 67 66 tconfig (configf
3030: 3a 73 65 63 74 69 6f 6e 2d 76 61 72 73 20 74 65 :section-vars te
3040: 73 74 63 6f 6e 66 69 67 20 22 77 61 69 76 65 72 stconfig "waiver
3050: 73 22 29 20 27 28 29 29 29 0a 09 20 28 77 61 69 s") '())).. (wai
3060: 76 65 72 2d 72 78 20 20 20 28 72 65 67 65 78 70 ver-rx (regexp
3070: 20 22 5e 28 5c 5c 53 2b 29 5c 5c 73 2b 28 2e 2a "^(\\S+)\\s+(.*
3080: 29 24 22 29 29 0a 09 20 28 64 69 66 66 2d 72 75 )$")).. (diff-ru
3090: 6c 65 20 20 20 22 64 69 66 66 20 25 66 69 6c 65 le "diff %file
30a0: 31 25 20 25 66 69 6c 65 32 25 22 29 0a 09 20 28 1% %file2%").. (
30b0: 6c 6f 67 70 72 6f 2d 72 75 6c 65 20 22 64 69 66 logpro-rule "dif
30c0: 66 20 25 66 69 6c 65 31 25 20 25 66 69 6c 65 32 f %file1% %file2
30d0: 25 20 7c 20 6c 6f 67 70 72 6f 20 25 77 61 69 76 % | logpro %waiv
30e0: 65 72 6e 61 6d 65 25 2e 6c 6f 67 70 72 6f 20 25 ername%.logpro %
30f0: 77 61 69 76 65 72 6e 61 6d 65 25 2e 68 74 6d 6c waivername%.html
3100: 22 29 29 0a 20 20 20 20 28 69 66 20 28 6e 6f 74 ")). (if (not
3110: 20 28 66 69 6c 65 2d 65 78 69 73 74 73 3f 20 74 (file-exists? t
3120: 65 73 74 2d 72 75 6e 64 69 72 29 29 0a 09 28 62 est-rundir))..(b
3130: 65 67 69 6e 0a 09 20 20 28 64 65 62 75 67 3a 70 egin.. (debug:p
3140: 72 69 6e 74 2d 65 72 72 6f 72 20 30 20 2a 64 65 rint-error 0 *de
3150: 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 fault-log-port*
3160: 22 74 65 73 74 20 72 75 6e 20 64 69 72 65 63 74 "test run direct
3170: 6f 72 79 20 69 73 20 67 6f 6e 65 2c 20 63 61 6e ory is gone, can
3180: 6e 6f 74 20 70 72 6f 70 61 67 61 74 65 20 77 61 not propagate wa
3190: 69 76 65 72 22 29 0a 09 20 20 23 66 29 0a 09 28 iver").. #f)..(
31a0: 62 65 67 69 6e 0a 09 20 20 28 70 75 73 68 2d 64 begin.. (push-d
31b0: 69 72 65 63 74 6f 72 79 20 74 65 73 74 2d 72 75 irectory test-ru
31c0: 6e 64 69 72 29 0a 09 20 20 28 6c 65 74 20 28 28 ndir).. (let ((
31d0: 72 65 73 75 6c 74 20 28 69 66 20 28 6e 75 6c 6c result (if (null
31e0: 3f 20 77 61 69 76 65 72 73 29 0a 09 09 09 20 20 ? waivers)....
31f0: 20 20 23 66 0a 09 09 09 20 20 20 20 28 6c 65 74 #f.... (let
3200: 20 6c 6f 6f 70 20 28 28 68 65 64 20 28 63 61 72 loop ((hed (car
3210: 20 77 61 69 76 65 72 73 29 29 0a 09 09 09 09 20 waivers)).....
3220: 20 20 20 20 20 20 28 74 61 6c 20 28 63 64 72 20 (tal (cdr
3230: 77 61 69 76 65 72 73 29 29 29 0a 09 09 09 20 20 waivers)))....
3240: 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 (debug:print
3250: 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 0 *default-log-
3260: 70 6f 72 74 2a 20 22 49 4e 46 4f 3a 20 41 70 70 port* "INFO: App
3270: 6c 79 69 6e 67 20 77 61 69 76 65 72 20 72 75 6c lying waiver rul
3280: 65 20 5c 22 22 20 68 65 64 20 22 5c 22 22 29 0a e \"" hed "\"").
3290: 09 09 09 20 20 20 20 20 20 28 6c 65 74 2a 20 28 ... (let* (
32a0: 28 77 61 69 76 65 72 20 20 20 20 20 20 28 63 6f (waiver (co
32b0: 6e 66 69 67 66 3a 6c 6f 6f 6b 75 70 20 74 65 73 nfigf:lookup tes
32c0: 74 63 6f 6e 66 69 67 20 22 77 61 69 76 65 72 73 tconfig "waivers
32d0: 22 20 68 65 64 29 29 0a 09 09 09 09 20 20 20 20 " hed)).....
32e0: 20 28 77 70 61 72 74 73 20 20 20 20 20 20 28 69 (wparts (i
32f0: 66 20 77 61 69 76 65 72 20 28 73 74 72 69 6e 67 f waiver (string
3300: 2d 6d 61 74 63 68 20 77 61 69 76 65 72 2d 72 78 -match waiver-rx
3310: 20 77 61 69 76 65 72 29 20 23 66 29 29 0a 09 09 waiver) #f))...
3320: 09 09 20 20 20 20 20 28 77 61 69 76 65 72 2d 72 .. (waiver-r
3330: 75 6c 65 20 28 69 66 20 77 70 61 72 74 73 20 28 ule (if wparts (
3340: 63 61 64 72 20 77 70 61 72 74 73 29 20 20 23 66 cadr wparts) #f
3350: 29 29 0a 09 09 09 09 20 20 20 20 20 28 77 61 69 ))..... (wai
3360: 76 65 72 2d 67 6c 6f 62 20 28 69 66 20 77 70 61 ver-glob (if wpa
3370: 72 74 73 20 28 63 61 64 64 72 20 77 70 61 72 74 rts (caddr wpart
3380: 73 29 20 23 66 29 29 0a 09 09 09 09 20 20 20 20 s) #f)).....
3390: 20 28 6c 6f 67 70 72 6f 2d 66 69 6c 65 20 28 69 (logpro-file (i
33a0: 66 20 77 61 69 76 65 72 0a 09 09 09 09 09 09 20 f waiver.......
33b0: 20 20 20 20 20 28 6c 65 74 20 28 28 66 6e 61 6d (let ((fnam
33c0: 65 20 28 63 6f 6e 63 20 68 65 64 20 22 2e 6c 6f e (conc hed ".lo
33d0: 67 70 72 6f 22 29 29 29 0a 09 09 09 09 09 09 09 gpro")))........
33e0: 28 69 66 20 28 66 69 6c 65 2d 65 78 69 73 74 73 (if (file-exists
33f0: 3f 20 66 6e 61 6d 65 29 0a 09 09 09 09 09 09 09 ? fname)........
3400: 20 20 20 20 66 6e 61 6d 65 20 0a 09 09 09 09 09 fname ......
3410: 09 09 20 20 20 20 28 62 65 67 69 6e 0a 09 09 09 .. (begin....
3420: 09 09 09 09 20 20 20 20 20 20 28 64 65 62 75 67 .... (debug
3430: 3a 70 72 69 6e 74 20 30 20 2a 64 65 66 61 75 6c :print 0 *defaul
3440: 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 49 4e 46 t-log-port* "INF
3450: 4f 3a 20 4e 6f 20 6c 6f 67 70 72 6f 20 66 69 6c O: No logpro fil
3460: 65 20 22 20 66 6e 61 6d 65 20 22 20 66 61 6c 6c e " fname " fall
3470: 69 6e 67 20 62 61 63 6b 20 74 6f 20 64 69 66 66 ing back to diff
3480: 22 29 0a 09 09 09 09 09 09 09 20 20 20 20 20 20 ")........
3490: 23 66 29 29 29 0a 09 09 09 09 09 09 20 20 20 20 #f))).......
34a0: 20 20 23 66 29 29 0a 09 09 09 09 20 20 20 20 20 #f)).....
34b0: 3b 3b 20 69 66 20 72 75 6c 65 20 62 79 20 6e 61 ;; if rule by na
34c0: 6d 65 20 6f 66 20 77 61 69 76 65 72 2d 72 75 6c me of waiver-rul
34d0: 65 20 69 73 20 66 6f 75 6e 64 20 69 6e 20 74 65 e is found in te
34e0: 73 74 63 6f 6e 66 69 67 20 2d 20 75 73 65 20 69 stconfig - use i
34f0: 74 0a 09 09 09 09 20 20 20 20 20 3b 3b 20 65 6c t..... ;; el
3500: 73 65 20 69 66 20 77 61 69 76 65 72 6e 61 6d 65 se if waivername
3510: 2e 6c 6f 67 70 72 6f 20 65 78 69 73 74 73 20 75 .logpro exists u
3520: 73 65 20 6c 6f 67 70 72 6f 2d 72 75 6c 65 0a 09 se logpro-rule..
3530: 09 09 09 20 20 20 20 20 3b 3b 20 65 6c 73 65 20 ... ;; else
3540: 64 65 66 61 75 6c 74 20 74 6f 20 64 69 66 66 2d default to diff-
3550: 72 75 6c 65 0a 09 09 09 09 20 20 20 20 20 28 72 rule..... (r
3560: 75 6c 65 2d 73 74 72 69 6e 67 20 28 6c 65 74 20 ule-string (let
3570: 28 28 72 75 6c 65 20 28 63 6f 6e 66 69 67 66 3a ((rule (configf:
3580: 6c 6f 6f 6b 75 70 20 74 65 73 74 63 6f 6e 66 69 lookup testconfi
3590: 67 20 22 77 61 69 76 65 72 5f 72 75 6c 65 73 22 g "waiver_rules"
35a0: 20 77 61 69 76 65 72 2d 72 75 6c 65 29 29 29 0a waiver-rule))).
35b0: 09 09 09 09 09 09 20 20 20 20 28 69 66 20 72 75 ...... (if ru
35c0: 6c 65 0a 09 09 09 09 09 09 09 72 75 6c 65 0a 09 le........rule..
35d0: 09 09 09 09 09 09 28 69 66 20 6c 6f 67 70 72 6f ......(if logpro
35e0: 2d 66 69 6c 65 0a 09 09 09 09 09 09 09 20 20 20 -file........
35f0: 20 6c 6f 67 70 72 6f 2d 72 75 6c 65 0a 09 09 09 logpro-rule....
3600: 09 09 09 09 20 20 20 20 28 62 65 67 69 6e 0a 09 .... (begin..
3610: 09 09 09 09 09 09 20 20 20 20 20 20 28 64 65 62 ...... (deb
3620: 75 67 3a 70 72 69 6e 74 20 30 20 2a 64 65 66 61 ug:print 0 *defa
3630: 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 49 ult-log-port* "I
3640: 4e 46 4f 3a 20 4e 6f 20 6c 6f 67 70 72 6f 20 66 NFO: No logpro f
3650: 69 6c 65 20 22 20 6c 6f 67 70 72 6f 2d 66 69 6c ile " logpro-fil
3660: 65 20 22 20 66 6f 75 6e 64 2c 20 75 73 69 6e 67 e " found, using
3670: 20 64 69 66 66 20 72 75 6c 65 22 29 0a 09 09 09 diff rule")....
3680: 09 09 09 09 20 20 20 20 20 20 64 69 66 66 2d 72 .... diff-r
3690: 75 6c 65 29 29 29 29 29 0a 09 09 09 09 20 20 20 ule))))).....
36a0: 20 20 3b 3b 20 28 73 74 72 69 6e 67 2d 73 75 62 ;; (string-sub
36b0: 73 74 69 74 75 74 65 20 22 25 66 69 6c 65 31 25 stitute "%file1%
36c0: 22 20 22 66 6f 6f 66 6f 6f 2e 74 78 74 22 20 22 " "foofoo.txt" "
36d0: 54 68 69 73 20 69 73 20 25 66 69 6c 65 31 25 20 This is %file1%
36e0: 61 6e 64 20 73 6f 20 69 73 20 74 68 69 73 20 25 and so is this %
36f0: 66 69 6c 65 31 25 2e 22 20 23 74 29 0a 09 09 09 file1%." #t)....
3700: 09 20 20 20 20 20 28 70 72 6f 63 65 73 73 65 64 . (processed
3710: 2d 63 6d 64 20 28 73 74 72 69 6e 67 2d 73 75 62 -cmd (string-sub
3720: 73 74 69 74 75 74 65 20 0a 09 09 09 09 09 09 20 stitute .......
3730: 20 20 20 20 22 25 66 69 6c 65 31 25 22 20 28 63 "%file1%" (c
3740: 6f 6e 63 20 74 65 73 74 2d 72 75 6e 64 69 72 20 onc test-rundir
3750: 22 2f 22 20 77 61 69 76 65 72 2d 67 6c 6f 62 29 "/" waiver-glob)
3760: 0a 09 09 09 09 09 09 20 20 20 20 20 28 73 74 72 ....... (str
3770: 69 6e 67 2d 73 75 62 73 74 69 74 75 74 65 0a 09 ing-substitute..
3780: 09 09 09 09 09 20 20 20 20 20 20 22 25 66 69 6c ..... "%fil
3790: 65 32 25 22 20 28 63 6f 6e 63 20 70 72 65 76 2d e2%" (conc prev-
37a0: 72 75 6e 64 69 72 20 22 2f 22 20 77 61 69 76 65 rundir "/" waive
37b0: 72 2d 67 6c 6f 62 29 0a 09 09 09 09 09 09 20 20 r-glob).......
37c0: 20 20 20 20 28 73 74 72 69 6e 67 2d 73 75 62 73 (string-subs
37d0: 74 69 74 75 74 65 0a 09 09 09 09 09 09 20 20 20 titute.......
37e0: 20 20 20 20 22 25 77 61 69 76 65 72 6e 61 6d 65 "%waivername
37f0: 25 22 20 68 65 64 20 72 75 6c 65 2d 73 74 72 69 %" hed rule-stri
3800: 6e 67 20 23 74 29 20 23 74 29 20 23 74 29 29 0a ng #t) #t) #t)).
3810: 09 09 09 09 20 20 20 20 20 28 72 65 73 20 20 20 .... (res
3820: 20 20 20 20 20 20 20 20 20 23 66 29 29 0a 09 09 #f))...
3830: 09 09 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 ..(debug:print 0
3840: 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f *default-log-po
3850: 72 74 2a 20 22 49 4e 46 4f 3a 20 77 61 69 76 65 rt* "INFO: waive
3860: 72 20 63 6f 6d 6d 61 6e 64 20 69 73 20 5c 22 22 r command is \""
3870: 20 70 72 6f 63 65 73 73 65 64 2d 63 6d 64 20 22 processed-cmd "
3880: 5c 22 22 29 0a 09 09 09 09 28 69 66 20 28 65 71 \"").....(if (eq
3890: 3f 20 28 73 79 73 74 65 6d 20 70 72 6f 63 65 73 ? (system proces
38a0: 73 65 64 2d 63 6d 64 29 20 30 29 0a 09 09 09 09 sed-cmd) 0).....
38b0: 20 20 20 20 28 69 66 20 28 6e 75 6c 6c 3f 20 74 (if (null? t
38c0: 61 6c 29 0a 09 09 09 09 09 23 74 0a 09 09 09 09 al)......#t.....
38d0: 09 28 6c 6f 6f 70 20 28 63 61 72 20 74 61 6c 29 .(loop (car tal)
38e0: 28 63 64 72 20 74 61 6c 29 29 29 0a 09 09 09 09 (cdr tal))).....
38f0: 20 20 20 20 23 66 29 29 29 29 29 29 0a 09 20 20 #f))))))..
3900: 20 20 28 70 6f 70 2d 64 69 72 65 63 74 6f 72 79 (pop-directory
3910: 29 0a 09 20 20 20 20 72 65 73 75 6c 74 29 29 29 ).. result)))
3920: 29 29 0a 0a 3b 3b 20 44 6f 20 6e 6f 74 20 72 70 ))..;; Do not rp
3930: 63 20 74 68 69 73 20 6f 6e 65 2c 20 64 6f 20 74 c this one, do t
3940: 68 65 20 75 6e 64 65 72 6c 79 69 6e 67 20 63 61 he underlying ca
3950: 6c 6c 73 21 21 21 0a 28 64 65 66 69 6e 65 20 28 lls!!!.(define (
3960: 74 65 73 74 73 3a 74 65 73 74 2d 73 65 74 2d 73 tests:test-set-s
3970: 74 61 74 75 73 21 20 72 75 6e 2d 69 64 20 74 65 tatus! run-id te
3980: 73 74 2d 69 64 20 73 74 61 74 65 20 73 74 61 74 st-id state stat
3990: 75 73 20 63 6f 6d 6d 65 6e 74 20 64 61 74 20 23 us comment dat #
39a0: 21 6b 65 79 20 28 77 6f 72 6b 2d 61 72 65 61 20 !key (work-area
39b0: 23 66 29 29 0a 20 20 28 6c 65 74 2a 20 28 28 72 #f)). (let* ((r
39c0: 65 61 6c 2d 73 74 61 74 75 73 20 73 74 61 74 75 eal-status statu
39d0: 73 29 0a 09 20 28 6f 74 68 65 72 64 61 74 20 20 s).. (otherdat
39e0: 20 20 28 69 66 20 64 61 74 20 64 61 74 20 28 6d (if dat dat (m
39f0: 61 6b 65 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 ake-hash-table))
3a00: 29 0a 09 20 28 74 65 73 74 64 61 74 20 20 20 20 ).. (testdat
3a10: 20 28 72 6d 74 3a 67 65 74 2d 74 65 73 74 2d 69 (rmt:get-test-i
3a20: 6e 66 6f 2d 62 79 2d 69 64 20 72 75 6e 2d 69 64 nfo-by-id run-id
3a30: 20 74 65 73 74 2d 69 64 29 29 0a 09 20 28 74 65 test-id)).. (te
3a40: 73 74 2d 6e 61 6d 65 20 20 20 28 64 62 3a 74 65 st-name (db:te
3a50: 73 74 2d 67 65 74 2d 74 65 73 74 6e 61 6d 65 20 st-get-testname
3a60: 20 74 65 73 74 64 61 74 29 29 0a 09 20 28 69 74 testdat)).. (it
3a70: 65 6d 2d 70 61 74 68 20 20 20 28 64 62 3a 74 65 em-path (db:te
3a80: 73 74 2d 67 65 74 2d 69 74 65 6d 2d 70 61 74 68 st-get-item-path
3a90: 20 74 65 73 74 64 61 74 29 29 0a 09 20 3b 3b 20 testdat)).. ;;
3aa0: 62 65 66 6f 72 65 20 70 72 6f 63 65 65 64 69 6e before proceedin
3ab0: 67 20 77 65 20 6d 75 73 74 20 66 69 6e 64 20 6f g we must find o
3ac0: 75 74 20 69 66 20 74 68 65 20 70 72 65 76 69 6f ut if the previo
3ad0: 75 73 20 74 65 73 74 20 28 77 68 65 72 65 20 61 us test (where a
3ae0: 6c 6c 20 6b 65 79 73 20 6d 61 74 63 68 65 64 20 ll keys matched
3af0: 65 78 63 65 70 74 20 72 75 6e 6e 61 6d 65 29 0a except runname).
3b00: 09 20 3b 3b 20 77 61 73 20 57 41 49 56 45 44 20 . ;; was WAIVED
3b10: 69 66 20 74 68 69 73 20 74 65 73 74 20 69 73 20 if this test is
3b20: 46 41 49 4c 0a 0a 09 20 3b 3b 20 4e 4f 54 45 53 FAIL... ;; NOTES
3b30: 3a 0a 09 20 3b 3b 20 20 31 2e 20 49 73 20 74 68 :.. ;; 1. Is th
3b40: 65 20 63 61 6c 6c 20 74 6f 20 74 65 73 74 3a 67 e call to test:g
3b50: 65 74 2d 70 72 65 76 69 6f 75 73 2d 72 75 6e 2d et-previous-run-
3b60: 72 65 63 6f 72 64 20 72 65 6d 6f 74 69 66 69 65 record remotifie
3b70: 64 3f 0a 09 20 3b 3b 20 20 32 2e 20 41 64 64 20 d?.. ;; 2. Add
3b80: 74 65 73 74 20 66 6f 72 20 74 65 73 74 63 6f 6e test for testcon
3b90: 66 69 67 20 77 61 69 76 65 72 20 70 72 6f 70 61 fig waiver propa
3ba0: 67 61 74 69 6f 6e 20 63 6f 6e 74 72 6f 6c 20 68 gation control h
3bb0: 65 72 65 0a 09 20 3b 3b 0a 09 20 28 70 72 65 76 ere.. ;;.. (prev
3bc0: 2d 74 65 73 74 20 20 20 28 69 66 20 28 65 71 75 -test (if (equ
3bd0: 61 6c 3f 20 73 74 61 74 75 73 20 22 46 41 49 4c al? status "FAIL
3be0: 22 29 0a 09 09 09 20 20 28 72 6d 74 3a 67 65 74 ").... (rmt:get
3bf0: 2d 70 72 65 76 69 6f 75 73 2d 74 65 73 74 2d 72 -previous-test-r
3c00: 75 6e 2d 72 65 63 6f 72 64 20 72 75 6e 2d 69 64 un-record run-id
3c10: 20 74 65 73 74 2d 6e 61 6d 65 20 69 74 65 6d 2d test-name item-
3c20: 70 61 74 68 29 0a 09 09 09 20 20 23 66 29 29 0a path).... #f)).
3c30: 09 20 28 77 61 69 76 65 64 20 20 20 28 69 66 20 . (waived (if
3c40: 70 72 65 76 2d 74 65 73 74 0a 09 09 20 20 20 20 prev-test...
3c50: 20 20 20 28 69 66 20 70 72 65 76 2d 74 65 73 74 (if prev-test
3c60: 20 3b 3b 20 74 72 75 65 20 69 66 20 77 65 20 66 ;; true if we f
3c70: 6f 75 6e 64 20 61 20 70 72 65 76 69 6f 75 73 20 ound a previous
3c80: 74 65 73 74 20 69 6e 20 74 68 69 73 20 72 75 6e test in this run
3c90: 20 73 65 72 69 65 73 0a 09 09 09 20 20 20 28 6c series.... (l
3ca0: 65 74 20 28 28 70 72 65 76 2d 73 74 61 74 75 73 et ((prev-status
3cb0: 20 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 73 (db:test-get-s
3cc0: 74 61 74 75 73 20 20 70 72 65 76 2d 74 65 73 74 tatus prev-test
3cd0: 29 29 0a 09 09 09 09 20 28 70 72 65 76 2d 73 74 ))..... (prev-st
3ce0: 61 74 65 20 20 20 28 64 62 3a 74 65 73 74 2d 67 ate (db:test-g
3cf0: 65 74 2d 73 74 61 74 65 20 20 20 70 72 65 76 2d et-state prev-
3d00: 74 65 73 74 29 29 0a 09 09 09 09 20 28 70 72 65 test))..... (pre
3d10: 76 2d 63 6f 6d 6d 65 6e 74 20 28 64 62 3a 74 65 v-comment (db:te
3d20: 73 74 2d 67 65 74 2d 63 6f 6d 6d 65 6e 74 20 70 st-get-comment p
3d30: 72 65 76 2d 74 65 73 74 29 29 29 0a 09 09 09 20 rev-test)))....
3d40: 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 (debug:print
3d50: 20 34 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 4 *default-log-
3d60: 70 6f 72 74 2a 20 22 70 72 65 76 2d 73 74 61 74 port* "prev-stat
3d70: 75 73 20 22 20 70 72 65 76 2d 73 74 61 74 75 73 us " prev-status
3d80: 20 22 2c 20 70 72 65 76 2d 73 74 61 74 65 20 22 ", prev-state "
3d90: 20 70 72 65 76 2d 73 74 61 74 65 20 22 2c 20 70 prev-state ", p
3da0: 72 65 76 2d 63 6f 6d 6d 65 6e 74 20 22 20 70 72 rev-comment " pr
3db0: 65 76 2d 63 6f 6d 6d 65 6e 74 29 0a 09 09 09 20 ev-comment)....
3dc0: 20 20 20 20 28 69 66 20 28 61 6e 64 20 28 65 71 (if (and (eq
3dd0: 75 61 6c 3f 20 70 72 65 76 2d 73 74 61 74 65 20 ual? prev-state
3de0: 20 22 43 4f 4d 50 4c 45 54 45 44 22 29 0a 09 09 "COMPLETED")...
3df0: 09 09 20 20 20 20 20 20 28 65 71 75 61 6c 3f 20 .. (equal?
3e00: 70 72 65 76 2d 73 74 61 74 75 73 20 22 57 41 49 prev-status "WAI
3e10: 56 45 44 22 29 29 0a 09 09 09 09 20 28 69 66 20 VED"))..... (if
3e20: 63 6f 6d 6d 65 6e 74 0a 09 09 09 09 20 20 20 20 comment.....
3e30: 20 63 6f 6d 6d 65 6e 74 0a 09 09 09 09 20 20 20 comment.....
3e40: 20 20 70 72 65 76 2d 63 6f 6d 6d 65 6e 74 29 20 prev-comment)
3e50: 3b 3b 20 77 61 69 76 65 64 20 69 73 20 65 69 74 ;; waived is eit
3e60: 68 65 72 20 74 68 65 20 63 6f 6d 6d 65 6e 74 20 her the comment
3e70: 6f 72 20 23 66 0a 09 09 09 09 20 23 66 29 29 0a or #f..... #f)).
3e80: 09 09 09 20 20 20 23 66 29 0a 09 09 20 20 20 20 ... #f)...
3e90: 20 20 20 23 66 29 29 29 0a 20 20 20 20 28 69 66 #f))). (if
3ea0: 20 28 61 6e 64 20 77 61 69 76 65 64 20 0a 09 20 (and waived ..
3eb0: 20 20 20 20 28 74 65 73 74 73 3a 63 68 65 63 6b (tests:check
3ec0: 2d 77 61 69 76 65 72 2d 65 6c 69 67 69 62 69 6c -waiver-eligibil
3ed0: 69 74 79 20 74 65 73 74 64 61 74 20 70 72 65 76 ity testdat prev
3ee0: 2d 74 65 73 74 29 29 0a 09 28 73 65 74 21 20 72 -test))..(set! r
3ef0: 65 61 6c 2d 73 74 61 74 75 73 20 22 57 41 49 56 eal-status "WAIV
3f00: 45 44 22 29 29 0a 0a 20 20 20 20 28 64 65 62 75 ED")).. (debu
3f10: 67 3a 70 72 69 6e 74 20 34 20 2a 64 65 66 61 75 g:print 4 *defau
3f20: 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 72 65 lt-log-port* "re
3f30: 61 6c 2d 73 74 61 74 75 73 20 22 20 72 65 61 6c al-status " real
3f40: 2d 73 74 61 74 75 73 20 22 2c 20 77 61 69 76 65 -status ", waive
3f50: 64 20 22 20 77 61 69 76 65 64 20 22 2c 20 73 74 d " waived ", st
3f60: 61 74 75 73 20 22 20 73 74 61 74 75 73 29 0a 0a atus " status)..
3f70: 20 20 20 20 3b 3b 20 75 70 64 61 74 65 20 74 68 ;; update th
3f80: 65 20 70 72 69 6d 61 72 79 20 72 65 63 6f 72 64 e primary record
3f90: 20 49 46 20 73 74 61 74 65 20 41 4e 44 20 73 74 IF state AND st
3fa0: 61 74 75 73 20 61 72 65 20 64 65 66 69 6e 65 64 atus are defined
3fb0: 0a 20 20 20 20 28 69 66 20 28 61 6e 64 20 73 74 . (if (and st
3fc0: 61 74 65 20 73 74 61 74 75 73 29 0a 09 28 62 65 ate status)..(be
3fd0: 67 69 6e 0a 09 20 20 28 72 6d 74 3a 73 65 74 2d gin.. (rmt:set-
3fe0: 73 74 61 74 65 2d 73 74 61 74 75 73 2d 61 6e 64 state-status-and
3ff0: 2d 72 6f 6c 6c 2d 75 70 2d 69 74 65 6d 73 20 72 -roll-up-items r
4000: 75 6e 2d 69 64 20 74 65 73 74 2d 69 64 20 69 74 un-id test-id it
4010: 65 6d 2d 70 61 74 68 20 73 74 61 74 65 20 72 65 em-path state re
4020: 61 6c 2d 73 74 61 74 75 73 20 28 69 66 20 77 61 al-status (if wa
4030: 69 76 65 64 20 77 61 69 76 65 64 20 63 6f 6d 6d ived waived comm
4040: 65 6e 74 29 29 0a 09 20 20 3b 3b 20 28 6d 74 3a ent)).. ;; (mt:
4050: 70 72 6f 63 65 73 73 2d 74 72 69 67 67 65 72 73 process-triggers
4060: 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 69 64 20 run-id test-id
4070: 73 74 61 74 65 20 72 65 61 6c 2d 73 74 61 74 75 state real-statu
4080: 73 29 20 3b 3b 20 74 72 69 67 67 65 72 73 20 61 s) ;; triggers a
4090: 72 65 20 63 61 6c 6c 65 64 20 69 6e 20 74 65 73 re called in tes
40a0: 74 2d 73 65 74 2d 73 74 61 74 65 2d 73 74 61 74 t-set-state-stat
40b0: 75 73 0a 09 20 20 29 29 0a 20 20 20 20 0a 20 20 us.. )). .
40c0: 20 20 3b 3b 20 69 66 20 73 74 61 74 75 73 20 69 ;; if status i
40d0: 73 20 22 41 55 54 4f 22 20 74 68 65 6e 20 63 61 s "AUTO" then ca
40e0: 6c 6c 20 72 6f 6c 6c 75 70 20 28 6e 6f 74 65 2c ll rollup (note,
40f0: 20 74 68 69 73 20 6f 6e 65 20 6d 6f 64 69 66 69 this one modifi
4100: 65 73 20 64 61 74 61 20 69 6e 20 74 65 73 74 0a es data in test.
4110: 20 20 20 20 3b 3b 20 72 75 6e 20 61 72 65 61 2c ;; run area,
4120: 20 69 74 20 64 6f 65 73 20 72 65 6d 6f 74 65 20 it does remote
4130: 63 61 6c 6c 73 20 75 6e 64 65 72 20 74 68 65 20 calls under the
4140: 68 6f 6f 64 2e 0a 20 20 20 20 3b 3b 20 28 69 66 hood.. ;; (if
4150: 20 28 61 6e 64 20 74 65 73 74 2d 69 64 20 73 74 (and test-id st
4160: 61 74 65 20 73 74 61 74 75 73 20 28 65 71 75 61 ate status (equa
4170: 6c 3f 20 73 74 61 74 75 73 20 22 41 55 54 4f 22 l? status "AUTO"
4180: 29 29 20 0a 20 20 20 20 3b 3b 20 09 28 72 6d 74 )) . ;; .(rmt
4190: 3a 74 65 73 74 2d 64 61 74 61 2d 72 6f 6c 6c 75 :test-data-rollu
41a0: 70 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 69 64 p run-id test-id
41b0: 20 73 74 61 74 75 73 29 29 0a 0a 20 20 20 20 3b status)).. ;
41c0: 3b 20 61 64 64 20 6d 65 74 61 64 61 74 61 20 28 ; add metadata (
41d0: 6e 65 65 64 20 74 6f 20 64 6f 20 74 68 69 73 20 need to do this
41e0: 77 61 79 20 74 6f 20 61 76 6f 69 64 20 53 51 4c way to avoid SQL
41f0: 20 69 6e 6a 65 63 74 69 6f 6e 20 69 73 73 75 65 injection issue
4200: 73 29 0a 0a 20 20 20 20 3b 3b 20 3a 66 69 72 73 s).. ;; :firs
4210: 74 5f 65 72 72 0a 20 20 20 20 3b 3b 20 28 6c 65 t_err. ;; (le
4220: 74 20 28 28 76 61 6c 20 28 68 61 73 68 2d 74 61 t ((val (hash-ta
4230: 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 ble-ref/default
4240: 6f 74 68 65 72 64 61 74 20 22 3a 66 69 72 73 74 otherdat ":first
4250: 5f 65 72 72 22 20 23 66 29 29 29 0a 20 20 20 20 _err" #f))).
4260: 3b 3b 20 20 20 28 69 66 20 76 61 6c 0a 20 20 20 ;; (if val.
4270: 20 3b 3b 20 20 20 20 20 20 20 28 73 71 6c 69 74 ;; (sqlit
4280: 65 33 3a 65 78 65 63 75 74 65 20 64 62 20 22 55 e3:execute db "U
4290: 50 44 41 54 45 20 74 65 73 74 73 20 53 45 54 20 PDATE tests SET
42a0: 66 69 72 73 74 5f 65 72 72 3d 3f 20 57 48 45 52 first_err=? WHER
42b0: 45 20 72 75 6e 5f 69 64 3d 3f 20 41 4e 44 20 74 E run_id=? AND t
42c0: 65 73 74 6e 61 6d 65 3d 3f 20 41 4e 44 20 69 74 estname=? AND it
42d0: 65 6d 5f 70 61 74 68 3d 3f 3b 22 20 76 61 6c 20 em_path=?;" val
42e0: 72 75 6e 2d 69 64 20 74 65 73 74 2d 6e 61 6d 65 run-id test-name
42f0: 20 69 74 65 6d 2d 70 61 74 68 29 29 29 0a 20 20 item-path))).
4300: 20 20 3b 3b 20 0a 20 20 20 20 3b 3b 20 3b 3b 20 ;; . ;; ;;
4310: 3a 66 69 72 73 74 5f 77 61 72 6e 0a 20 20 20 20 :first_warn.
4320: 3b 3b 20 28 6c 65 74 20 28 28 76 61 6c 20 28 68 ;; (let ((val (h
4330: 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 ash-table-ref/de
4340: 66 61 75 6c 74 20 6f 74 68 65 72 64 61 74 20 22 fault otherdat "
4350: 3a 66 69 72 73 74 5f 77 61 72 6e 22 20 23 66 29 :first_warn" #f)
4360: 29 29 0a 20 20 20 20 3b 3b 20 20 20 28 69 66 20 )). ;; (if
4370: 76 61 6c 0a 20 20 20 20 3b 3b 20 20 20 20 20 20 val. ;;
4380: 20 28 73 71 6c 69 74 65 33 3a 65 78 65 63 75 74 (sqlite3:execut
4390: 65 20 64 62 20 22 55 50 44 41 54 45 20 74 65 73 e db "UPDATE tes
43a0: 74 73 20 53 45 54 20 66 69 72 73 74 5f 77 61 72 ts SET first_war
43b0: 6e 3d 3f 20 57 48 45 52 45 20 72 75 6e 5f 69 64 n=? WHERE run_id
43c0: 3d 3f 20 41 4e 44 20 74 65 73 74 6e 61 6d 65 3d =? AND testname=
43d0: 3f 20 41 4e 44 20 69 74 65 6d 5f 70 61 74 68 3d ? AND item_path=
43e0: 3f 3b 22 20 76 61 6c 20 72 75 6e 2d 69 64 20 74 ?;" val run-id t
43f0: 65 73 74 2d 6e 61 6d 65 20 69 74 65 6d 2d 70 61 est-name item-pa
4400: 74 68 29 29 29 0a 0a 20 20 20 20 28 6c 65 74 20 th))).. (let
4410: 28 28 63 61 74 65 67 6f 72 79 20 28 68 61 73 68 ((category (hash
4420: 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 -table-ref/defau
4430: 6c 74 20 6f 74 68 65 72 64 61 74 20 22 3a 63 61 lt otherdat ":ca
4440: 74 65 67 6f 72 79 22 20 22 22 29 29 0a 09 20 20 tegory" ""))..
4450: 28 76 61 72 69 61 62 6c 65 20 28 68 61 73 68 2d (variable (hash-
4460: 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c table-ref/defaul
4470: 74 20 6f 74 68 65 72 64 61 74 20 22 3a 76 61 72 t otherdat ":var
4480: 69 61 62 6c 65 22 20 22 22 29 29 0a 09 20 20 28 iable" "")).. (
4490: 76 61 6c 75 65 20 20 20 20 28 68 61 73 68 2d 74 value (hash-t
44a0: 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 able-ref/default
44b0: 20 6f 74 68 65 72 64 61 74 20 22 3a 76 61 6c 75 otherdat ":valu
44c0: 65 22 20 20 20 20 23 66 29 29 0a 09 20 20 28 65 e" #f)).. (e
44d0: 78 70 65 63 74 65 64 20 28 68 61 73 68 2d 74 61 xpected (hash-ta
44e0: 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 ble-ref/default
44f0: 6f 74 68 65 72 64 61 74 20 22 3a 65 78 70 65 63 otherdat ":expec
4500: 74 65 64 22 20 23 66 29 29 0a 09 20 20 28 74 6f ted" #f)).. (to
4510: 6c 20 20 20 20 20 20 28 68 61 73 68 2d 74 61 62 l (hash-tab
4520: 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 6f le-ref/default o
4530: 74 68 65 72 64 61 74 20 22 3a 74 6f 6c 22 20 20 therdat ":tol"
4540: 20 20 20 20 23 66 29 29 0a 09 20 20 28 75 6e 69 #f)).. (uni
4550: 74 73 20 20 20 20 28 68 61 73 68 2d 74 61 62 6c ts (hash-tabl
4560: 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 6f 74 e-ref/default ot
4570: 68 65 72 64 61 74 20 22 3a 75 6e 69 74 73 22 20 herdat ":units"
4580: 20 20 20 22 22 29 29 0a 09 20 20 28 74 79 70 65 "")).. (type
4590: 20 20 20 20 20 28 68 61 73 68 2d 74 61 62 6c 65 (hash-table
45a0: 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 6f 74 68 -ref/default oth
45b0: 65 72 64 61 74 20 22 3a 74 79 70 65 22 20 20 20 erdat ":type"
45c0: 20 20 22 22 29 29 0a 09 20 20 28 64 63 6f 6d 6d "")).. (dcomm
45d0: 65 6e 74 20 28 68 61 73 68 2d 74 61 62 6c 65 2d ent (hash-table-
45e0: 72 65 66 2f 64 65 66 61 75 6c 74 20 6f 74 68 65 ref/default othe
45f0: 72 64 61 74 20 22 3a 63 6f 6d 6d 65 6e 74 22 20 rdat ":comment"
4600: 20 22 22 29 29 29 0a 20 20 20 20 20 20 28 64 65 ""))). (de
4610: 62 75 67 3a 70 72 69 6e 74 20 34 20 2a 64 65 66 bug:print 4 *def
4620: 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 0a ault-log-port* .
4630: 09 09 20 20 20 22 63 61 74 65 67 6f 72 79 3a 20 .. "category:
4640: 22 20 63 61 74 65 67 6f 72 79 20 22 2c 20 76 61 " category ", va
4650: 72 69 61 62 6c 65 3a 20 22 20 76 61 72 69 61 62 riable: " variab
4660: 6c 65 20 22 2c 20 76 61 6c 75 65 3a 20 22 20 76 le ", value: " v
4670: 61 6c 75 65 0a 09 09 20 20 20 22 2c 20 65 78 70 alue... ", exp
4680: 65 63 74 65 64 3a 20 22 20 65 78 70 65 63 74 65 ected: " expecte
4690: 64 20 22 2c 20 74 6f 6c 3a 20 22 20 74 6f 6c 20 d ", tol: " tol
46a0: 22 2c 20 75 6e 69 74 73 3a 20 22 20 75 6e 69 74 ", units: " unit
46b0: 73 29 0a 20 20 20 20 20 20 28 69 66 20 28 61 6e s). (if (an
46c0: 64 20 76 61 6c 75 65 20 65 78 70 65 63 74 65 64 d value expected
46d0: 20 74 6f 6c 29 20 3b 3b 20 61 6c 6c 20 74 68 72 tol) ;; all thr
46e0: 65 65 20 72 65 71 75 69 72 65 64 0a 09 20 20 28 ee required.. (
46f0: 6c 65 74 20 28 28 64 61 74 20 28 63 6f 6e 63 20 let ((dat (conc
4700: 63 61 74 65 67 6f 72 79 20 22 2c 22 0a 09 09 09 category ","....
4710: 20 20 20 76 61 72 69 61 62 6c 65 20 22 2c 22 0a variable ",".
4720: 09 09 09 20 20 20 76 61 6c 75 65 20 20 20 20 22 ... value "
4730: 2c 22 0a 09 09 09 20 20 20 65 78 70 65 63 74 65 ,".... expecte
4740: 64 20 22 2c 22 0a 09 09 09 20 20 20 74 6f 6c 20 d ",".... tol
4750: 20 20 20 20 20 22 2c 22 0a 09 09 09 20 20 20 75 ",".... u
4760: 6e 69 74 73 20 20 20 20 22 2c 22 0a 09 09 09 20 nits ","....
4770: 20 20 64 63 6f 6d 6d 65 6e 74 20 22 2c 2c 22 20 dcomment ",,"
4780: 3b 3b 20 65 78 74 72 61 20 63 6f 6d 6d 61 20 66 ;; extra comma f
4790: 6f 72 20 73 74 61 74 75 73 0a 09 09 09 20 20 20 or status....
47a0: 74 79 70 65 20 20 20 20 20 29 29 29 0a 09 20 20 type )))..
47b0: 20 20 3b 3b 20 54 68 69 73 20 77 61 73 20 72 75 ;; This was ru
47c0: 6e 20 72 65 6d 6f 74 65 2c 20 64 6f 6e 27 74 20 n remote, don't
47d0: 74 68 69 6e 6b 20 74 68 61 74 20 6d 61 6b 65 73 think that makes
47e0: 20 73 65 6e 73 65 2e 20 50 65 72 68 61 70 73 20 sense. Perhaps
47f0: 6e 6f 74 2c 20 62 75 74 20 74 68 61 74 20 69 73 not, but that is
4800: 20 74 68 65 20 65 61 73 69 65 73 74 20 70 61 74 the easiest pat
4810: 68 20 66 6f 72 20 74 68 65 20 6d 6f 6d 65 6e 74 h for the moment
4820: 2e 0a 09 20 20 20 20 28 72 6d 74 3a 63 73 76 2d ... (rmt:csv-
4830: 3e 74 65 73 74 2d 64 61 74 61 20 72 75 6e 2d 69 >test-data run-i
4840: 64 20 74 65 73 74 2d 69 64 0a 09 09 09 09 64 61 d test-id.....da
4850: 74 29 29 29 29 0a 20 20 20 20 20 20 0a 20 20 20 t)))). .
4860: 20 3b 3b 20 6e 65 65 64 20 74 6f 20 75 70 64 61 ;; need to upda
4870: 74 65 20 74 68 65 20 74 6f 70 20 74 65 73 74 20 te the top test
4880: 72 65 63 6f 72 64 20 69 66 20 50 41 53 53 20 6f record if PASS o
4890: 72 20 46 41 49 4c 20 61 6e 64 20 74 68 69 73 20 r FAIL and this
48a0: 69 73 20 61 20 73 75 62 74 65 73 74 0a 20 20 20 is a subtest.
48b0: 20 3b 3b 3b 3b 3b 3b 20 28 69 66 20 28 6e 6f 74 ;;;;;; (if (not
48c0: 20 28 65 71 75 61 6c 3f 20 69 74 65 6d 2d 70 61 (equal? item-pa
48d0: 74 68 20 22 22 29 29 0a 20 20 20 20 3b 3b 3b 3b th "")). ;;;;
48e0: 3b 3b 20 20 20 20 20 28 72 6d 74 3a 73 65 74 2d ;; (rmt:set-
48f0: 73 74 61 74 65 2d 73 74 61 74 75 73 2d 61 6e 64 state-status-and
4900: 2d 72 6f 6c 6c 2d 75 70 2d 69 74 65 6d 73 20 72 -roll-up-items r
4910: 75 6e 2d 69 64 20 74 65 73 74 2d 6e 61 6d 65 20 un-id test-name
4920: 69 74 65 6d 2d 70 61 74 68 20 73 74 61 74 65 20 item-path state
4930: 73 74 61 74 75 73 20 23 66 29 20 3b 3b 3b 3b 3b status #f) ;;;;;
4940: 29 0a 0a 20 20 20 20 28 69 66 20 28 6f 72 20 28 ).. (if (or (
4950: 61 6e 64 20 28 73 74 72 69 6e 67 3f 20 63 6f 6d and (string? com
4960: 6d 65 6e 74 29 0a 09 09 20 28 73 74 72 69 6e 67 ment)... (string
4970: 2d 6d 61 74 63 68 20 28 72 65 67 65 78 70 20 22 -match (regexp "
4980: 5c 5c 53 2b 22 29 20 63 6f 6d 6d 65 6e 74 29 29 \\S+") comment))
4990: 0a 09 20 20 20 20 77 61 69 76 65 64 29 0a 09 28 .. waived)..(
49a0: 6c 65 74 20 28 28 63 6d 74 20 20 28 69 66 20 77 let ((cmt (if w
49b0: 61 69 76 65 64 20 77 61 69 76 65 64 20 63 6f 6d aived waived com
49c0: 6d 65 6e 74 29 29 29 0a 09 20 20 28 72 6d 74 3a ment))).. (rmt:
49d0: 67 65 6e 65 72 61 6c 2d 63 61 6c 6c 20 27 73 65 general-call 'se
49e0: 74 2d 74 65 73 74 2d 63 6f 6d 6d 65 6e 74 20 72 t-test-comment r
49f0: 75 6e 2d 69 64 20 63 6d 74 20 74 65 73 74 2d 69 un-id cmt test-i
4a00: 64 29 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 d)))))..(define
4a10: 28 74 65 73 74 73 3a 74 65 73 74 2d 73 65 74 2d (tests:test-set-
4a20: 74 6f 70 6c 6f 67 21 20 72 75 6e 2d 69 64 20 74 toplog! run-id t
4a30: 65 73 74 2d 6e 61 6d 65 20 6c 6f 67 66 29 20 0a est-name logf) .
4a40: 20 20 28 72 6d 74 3a 67 65 6e 65 72 61 6c 2d 63 (rmt:general-c
4a50: 61 6c 6c 20 27 74 65 73 74 73 3a 74 65 73 74 2d all 'tests:test-
4a60: 73 65 74 2d 74 6f 70 6c 6f 67 20 72 75 6e 2d 69 set-toplog run-i
4a70: 64 20 6c 6f 67 66 20 72 75 6e 2d 69 64 20 74 65 d logf run-id te
4a80: 73 74 2d 6e 61 6d 65 29 29 0a 0a 28 64 65 66 69 st-name))..(defi
4a90: 6e 65 20 28 74 65 73 74 73 3a 73 75 6d 6d 61 72 ne (tests:summar
4aa0: 69 7a 65 2d 69 74 65 6d 73 20 72 75 6e 2d 69 64 ize-items run-id
4ab0: 20 74 65 73 74 2d 69 64 20 74 65 73 74 2d 6e 61 test-id test-na
4ac0: 6d 65 20 66 6f 72 63 65 29 0a 20 20 3b 3b 20 69 me force). ;; i
4ad0: 66 20 6e 6f 74 20 66 6f 72 63 65 20 74 68 65 6e f not force then
4ae0: 20 6f 6e 6c 79 20 75 70 64 61 74 65 20 74 68 65 only update the
4af0: 20 72 65 63 6f 72 64 20 69 66 20 6f 6e 65 20 6f record if one o
4b00: 66 20 74 68 65 73 65 20 69 73 20 74 72 75 65 3a f these is true:
4b10: 0a 20 20 3b 3b 20 20 20 31 2e 20 6c 6f 67 66 20 . ;; 1. logf
4b20: 69 73 20 22 6c 6f 67 2f 66 69 6e 61 6c 2e 6c 6f is "log/final.lo
4b30: 67 0a 20 20 3b 3b 20 20 20 32 2e 20 6c 6f 67 66 g. ;; 2. logf
4b40: 20 69 73 20 73 61 6d 65 20 61 73 20 6f 75 74 70 is same as outp
4b50: 75 74 66 69 6c 65 6e 61 6d 65 0a 20 20 28 6c 65 utfilename. (le
4b60: 74 2a 20 28 28 6f 75 74 70 75 74 66 69 6c 65 6e t* ((outputfilen
4b70: 61 6d 65 20 28 63 6f 6e 63 20 22 6d 65 67 61 74 ame (conc "megat
4b80: 65 73 74 2d 72 6f 6c 6c 75 70 2d 22 20 74 65 73 est-rollup-" tes
4b90: 74 2d 6e 61 6d 65 20 22 2e 68 74 6d 6c 22 29 29 t-name ".html"))
4ba0: 0a 09 20 28 6f 72 69 67 2d 64 69 72 20 20 20 20 .. (orig-dir
4bb0: 20 20 20 28 63 75 72 72 65 6e 74 2d 64 69 72 65 (current-dire
4bc0: 63 74 6f 72 79 29 29 0a 09 20 28 6c 6f 67 66 2d ctory)).. (logf-
4bd0: 69 6e 66 6f 20 20 20 20 20 20 28 72 6d 74 3a 74 info (rmt:t
4be0: 65 73 74 2d 67 65 74 2d 6c 6f 67 66 69 6c 65 2d est-get-logfile-
4bf0: 69 6e 66 6f 20 72 75 6e 2d 69 64 20 74 65 73 74 info run-id test
4c00: 2d 6e 61 6d 65 29 29 0a 09 20 28 6c 6f 67 66 20 -name)).. (logf
4c10: 20 20 20 20 20 20 20 20 20 20 28 69 66 20 6c 6f (if lo
4c20: 67 66 2d 69 6e 66 6f 20 28 63 61 64 72 20 6c 6f gf-info (cadr lo
4c30: 67 66 2d 69 6e 66 6f 29 20 23 66 29 29 0a 09 20 gf-info) #f))..
4c40: 28 70 61 74 68 20 20 20 20 20 20 20 20 20 20 20 (path
4c50: 28 69 66 20 6c 6f 67 66 2d 69 6e 66 6f 20 28 63 (if logf-info (c
4c60: 61 72 20 20 6c 6f 67 66 2d 69 6e 66 6f 29 20 23 ar logf-info) #
4c70: 66 29 29 29 0a 20 20 20 20 3b 3b 20 54 68 69 73 f))). ;; This
4c80: 20 71 75 65 72 79 20 66 69 6e 64 73 20 74 68 65 query finds the
4c90: 20 70 61 74 68 20 61 6e 64 20 63 68 61 6e 67 65 path and change
4ca0: 73 20 74 68 65 20 64 69 72 65 63 74 6f 72 79 20 s the directory
4cb0: 74 6f 20 69 74 20 66 6f 72 20 74 68 65 20 74 65 to it for the te
4cc0: 73 74 0a 20 20 20 20 28 69 66 20 28 61 6e 64 20 st. (if (and
4cd0: 28 73 74 72 69 6e 67 3f 20 70 61 74 68 29 0a 09 (string? path)..
4ce0: 20 20 20 20 20 28 64 69 72 65 63 74 6f 72 79 3f (directory?
4cf0: 20 70 61 74 68 29 29 20 3b 3b 20 63 61 6e 20 67 path)) ;; can g
4d00: 65 74 20 23 66 20 68 65 72 65 20 75 6e 64 65 72 et #f here under
4d10: 20 73 6f 6d 65 20 77 69 65 72 64 20 63 6f 6e 64 some wierd cond
4d20: 69 74 69 6f 6e 73 2e 20 77 68 79 2c 20 75 6e 6b itions. why, unk
4d30: 6e 6f 77 6e 20 2e 2e 2e 0a 09 28 62 65 67 69 6e nown .....(begin
4d40: 0a 09 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 .. (debug:print
4d50: 20 34 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 4 *default-log-
4d60: 70 6f 72 74 2a 20 22 46 6f 75 6e 64 20 70 61 74 port* "Found pat
4d70: 68 3a 20 22 20 70 61 74 68 29 0a 09 20 20 28 63 h: " path).. (c
4d80: 68 61 6e 67 65 2d 64 69 72 65 63 74 6f 72 79 20 hange-directory
4d90: 70 61 74 68 29 29 0a 09 3b 3b 20 28 73 65 74 21 path))..;; (set!
4da0: 20 6f 75 74 70 75 74 66 69 6c 65 6e 61 6d 65 20 outputfilename
4db0: 28 63 6f 6e 63 20 70 61 74 68 20 22 2f 22 20 6f (conc path "/" o
4dc0: 75 74 70 75 74 66 69 6c 65 6e 61 6d 65 29 29 29 utputfilename)))
4dd0: 0a 09 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 65 ..(debug:print-e
4de0: 72 72 6f 72 20 30 20 2a 64 65 66 61 75 6c 74 2d rror 0 *default-
4df0: 6c 6f 67 2d 70 6f 72 74 2a 20 22 73 75 6d 6d 61 log-port* "summa
4e00: 72 69 7a 65 2d 69 74 65 6d 73 20 66 6f 72 20 72 rize-items for r
4e10: 75 6e 2d 69 64 3d 22 20 72 75 6e 2d 69 64 20 22 un-id=" run-id "
4e20: 2c 20 74 65 73 74 2d 6e 61 6d 65 3d 22 20 74 65 , test-name=" te
4e30: 73 74 2d 6e 61 6d 65 20 22 2c 20 6e 6f 20 73 75 st-name ", no su
4e40: 63 68 20 70 61 74 68 3a 20 22 20 70 61 74 68 29 ch path: " path)
4e50: 29 0a 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 ). (debug:pri
4e60: 6e 74 20 34 20 2a 64 65 66 61 75 6c 74 2d 6c 6f nt 4 *default-lo
4e70: 67 2d 70 6f 72 74 2a 20 22 73 75 6d 6d 61 72 69 g-port* "summari
4e80: 7a 65 2d 69 74 65 6d 73 20 77 69 74 68 20 6c 6f ze-items with lo
4e90: 67 66 20 22 20 6c 6f 67 66 20 22 2c 20 6f 75 74 gf " logf ", out
4ea0: 70 75 74 66 69 6c 65 6e 61 6d 65 20 22 20 6f 75 putfilename " ou
4eb0: 74 70 75 74 66 69 6c 65 6e 61 6d 65 20 22 20 61 tputfilename " a
4ec0: 6e 64 20 66 6f 72 63 65 20 22 20 66 6f 72 63 65 nd force " force
4ed0: 29 0a 20 20 20 20 28 69 66 20 28 6f 72 20 28 65 ). (if (or (e
4ee0: 71 75 61 6c 3f 20 6c 6f 67 66 20 22 6c 6f 67 73 qual? logf "logs
4ef0: 2f 66 69 6e 61 6c 2e 6c 6f 67 22 29 0a 09 20 20 /final.log")..
4f00: 20 20 28 65 71 75 61 6c 3f 20 6c 6f 67 66 20 6f (equal? logf o
4f10: 75 74 70 75 74 66 69 6c 65 6e 61 6d 65 29 0a 09 utputfilename)..
4f20: 20 20 20 20 66 6f 72 63 65 29 0a 09 28 6c 65 74 force)..(let
4f30: 20 28 28 6d 79 2d 73 74 61 72 74 2d 74 69 6d 65 ((my-start-time
4f40: 20 28 63 75 72 72 65 6e 74 2d 73 65 63 6f 6e 64 (current-second
4f50: 73 29 29 0a 09 20 20 20 20 20 20 28 6c 6f 63 6b s)).. (lock
4f60: 66 20 20 20 20 20 20 20 20 20 28 63 6f 6e 63 20 f (conc
4f70: 6f 75 74 70 75 74 66 69 6c 65 6e 61 6d 65 20 22 outputfilename "
4f80: 2e 6c 6f 63 6b 22 29 29 29 0a 09 20 20 28 6c 65 .lock"))).. (le
4f90: 74 20 6c 6f 6f 70 20 28 28 68 61 76 65 2d 6c 6f t loop ((have-lo
4fa0: 63 6b 20 20 28 63 6f 6d 6d 6f 6e 3a 73 69 6d 70 ck (common:simp
4fb0: 6c 65 2d 66 69 6c 65 2d 6c 6f 63 6b 20 6c 6f 63 le-file-lock loc
4fc0: 6b 66 29 29 29 0a 09 20 20 20 20 28 69 66 20 68 kf))).. (if h
4fd0: 61 76 65 2d 6c 6f 63 6b 0a 09 09 28 6c 65 74 20 ave-lock...(let
4fe0: 28 28 73 63 72 69 70 74 20 28 63 6f 6e 66 69 67 ((script (config
4ff0: 66 3a 6c 6f 6f 6b 75 70 20 2a 63 6f 6e 66 69 67 f:lookup *config
5000: 64 61 74 2a 20 22 74 65 73 74 72 6f 6c 6c 75 70 dat* "testrollup
5010: 22 20 74 65 73 74 2d 6e 61 6d 65 29 29 29 0a 09 " test-name)))..
5020: 09 20 20 28 70 72 69 6e 74 20 22 4f 62 74 61 69 . (print "Obtai
5030: 6e 65 64 20 6c 6f 63 6b 20 66 6f 72 20 22 20 6f ned lock for " o
5040: 75 74 70 75 74 66 69 6c 65 6e 61 6d 65 29 0a 09 utputfilename)..
5050: 09 20 20 28 72 6d 74 3a 73 65 74 2d 73 74 61 74 . (rmt:set-stat
5060: 65 2d 73 74 61 74 75 73 2d 61 6e 64 2d 72 6f 6c e-status-and-rol
5070: 6c 2d 75 70 2d 69 74 65 6d 73 20 72 75 6e 2d 69 l-up-items run-i
5080: 64 20 74 65 73 74 2d 6e 61 6d 65 20 22 22 20 23 d test-name "" #
5090: 66 20 23 66 20 23 66 29 0a 09 09 20 20 28 69 66 f #f #f)... (if
50a0: 20 73 63 72 69 70 74 0a 09 09 20 20 20 20 20 20 script...
50b0: 28 73 79 73 74 65 6d 20 28 63 6f 6e 63 20 73 63 (system (conc sc
50c0: 72 69 70 74 20 22 20 3e 20 22 20 6f 75 74 70 75 ript " > " outpu
50d0: 74 66 69 6c 65 6e 61 6d 65 20 22 20 26 20 22 29 tfilename " & ")
50e0: 29 0a 09 09 20 20 20 20 20 20 28 74 65 73 74 73 )... (tests
50f0: 3a 67 65 6e 65 72 61 74 65 2d 68 74 6d 6c 2d 73 :generate-html-s
5100: 75 6d 6d 61 72 79 2d 66 6f 72 2d 69 74 65 72 61 ummary-for-itera
5110: 74 65 64 2d 74 65 73 74 20 72 75 6e 2d 69 64 20 ted-test run-id
5120: 74 65 73 74 2d 69 64 20 74 65 73 74 2d 6e 61 6d test-id test-nam
5130: 65 20 6f 75 74 70 75 74 66 69 6c 65 6e 61 6d 65 e outputfilename
5140: 29 29 0a 09 09 20 20 28 63 6f 6d 6d 6f 6e 3a 73 ))... (common:s
5150: 69 6d 70 6c 65 2d 66 69 6c 65 2d 72 65 6c 65 61 imple-file-relea
5160: 73 65 2d 6c 6f 63 6b 20 6c 6f 63 6b 66 29 0a 09 se-lock lockf)..
5170: 09 20 20 28 63 68 61 6e 67 65 2d 64 69 72 65 63 . (change-direc
5180: 74 6f 72 79 20 6f 72 69 67 2d 64 69 72 29 0a 09 tory orig-dir)..
5190: 09 20 20 3b 3b 20 4e 42 2f 2f 20 74 65 73 74 73 . ;; NB// tests
51a0: 3a 74 65 73 74 2d 73 65 74 2d 74 6f 70 6c 6f 67 :test-set-toplog
51b0: 21 20 69 73 20 72 65 6d 6f 74 65 20 69 6e 74 65 ! is remote inte
51c0: 72 6e 61 6c 2e 2e 2e 0a 09 09 20 20 28 74 65 73 rnal...... (tes
51d0: 74 73 3a 74 65 73 74 2d 73 65 74 2d 74 6f 70 6c ts:test-set-topl
51e0: 6f 67 21 20 72 75 6e 2d 69 64 20 74 65 73 74 2d og! run-id test-
51f0: 6e 61 6d 65 20 6f 75 74 70 75 74 66 69 6c 65 6e name outputfilen
5200: 61 6d 65 29 29 0a 09 09 3b 3b 20 64 69 64 6e 27 ame))...;; didn'
5210: 74 20 67 65 74 20 74 68 65 20 6c 6f 63 6b 2c 20 t get the lock,
5220: 63 68 65 63 6b 20 74 6f 20 73 65 65 20 69 66 20 check to see if
5230: 63 75 72 72 65 6e 74 20 75 70 64 61 74 65 20 73 current update s
5240: 74 61 72 74 65 64 20 6c 61 74 65 72 20 74 68 61 tarted later tha
5250: 6e 20 74 68 69 73 20 0a 09 09 3b 3b 20 75 70 64 n this ...;; upd
5260: 61 74 65 2c 20 69 66 20 73 6f 20 77 65 20 63 61 ate, if so we ca
5270: 6e 20 65 78 69 74 20 77 69 74 68 6f 75 74 20 64 n exit without d
5280: 6f 69 6e 67 20 61 6e 79 20 77 6f 72 6b 0a 09 09 oing any work...
5290: 28 69 66 20 28 3e 20 6d 79 2d 73 74 61 72 74 2d (if (> my-start-
52a0: 74 69 6d 65 20 28 68 61 6e 64 6c 65 2d 65 78 63 time (handle-exc
52b0: 65 70 74 69 6f 6e 73 0a 09 09 09 09 09 20 65 78 eptions...... ex
52c0: 6e 0a 09 09 09 09 09 20 30 0a 09 09 09 09 20 20 n...... 0.....
52d0: 20 20 20 20 20 28 66 69 6c 65 2d 6d 6f 64 69 66 (file-modif
52e0: 69 63 61 74 69 6f 6e 2d 74 69 6d 65 20 6c 6f 63 ication-time loc
52f0: 6b 66 29 29 29 0a 09 09 20 20 20 20 3b 3b 20 77 kf)))... ;; w
5300: 65 20 73 74 61 72 74 65 64 20 73 69 6e 63 65 20 e started since
5310: 63 75 72 72 65 6e 74 20 72 65 2d 67 65 6e 20 69 current re-gen i
5320: 6e 20 66 6c 69 67 68 74 2c 20 64 65 6c 61 79 20 n flight, delay
5330: 61 20 6c 69 74 74 6c 65 20 61 6e 64 20 74 72 79 a little and try
5340: 20 61 67 61 69 6e 0a 09 09 20 20 20 20 28 62 65 again... (be
5350: 67 69 6e 0a 09 09 20 20 20 20 20 20 28 64 65 62 gin... (deb
5360: 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 31 20 ug:print-info 1
5370: 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 *default-log-por
5380: 74 2a 20 22 57 61 69 74 69 6e 67 20 74 6f 20 75 t* "Waiting to u
5390: 70 64 61 74 65 20 22 20 6f 75 74 70 75 74 66 69 pdate " outputfi
53a0: 6c 65 6e 61 6d 65 20 22 2c 20 61 6e 6f 74 68 65 lename ", anothe
53b0: 72 20 74 65 73 74 20 63 75 72 72 65 6e 74 6c 79 r test currently
53c0: 20 75 70 64 61 74 69 6e 67 20 69 74 22 29 0a 09 updating it")..
53d0: 09 20 20 20 20 20 20 28 74 68 72 65 61 64 2d 73 . (thread-s
53e0: 6c 65 65 70 21 20 28 2b 20 35 20 28 72 61 6e 64 leep! (+ 5 (rand
53f0: 6f 6d 20 35 29 29 29 20 3b 3b 20 64 65 6c 61 79 om 5))) ;; delay
5400: 20 62 65 74 77 65 65 6e 20 35 20 61 6e 64 20 31 between 5 and 1
5410: 30 20 73 65 63 6f 6e 64 73 0a 09 09 20 20 20 20 0 seconds...
5420: 20 20 28 6c 6f 6f 70 20 28 63 6f 6d 6d 6f 6e 3a (loop (common:
5430: 73 69 6d 70 6c 65 2d 66 69 6c 65 2d 6c 6f 63 6b simple-file-lock
5440: 20 6c 6f 63 6b 66 29 29 29 29 29 29 29 29 29 29 lockf))))))))))
5450: 0a 0a 28 64 65 66 69 6e 65 20 28 74 65 73 74 73 ..(define (tests
5460: 3a 67 65 6e 65 72 61 74 65 2d 68 74 6d 6c 2d 73 :generate-html-s
5470: 75 6d 6d 61 72 79 2d 66 6f 72 2d 69 74 65 72 61 ummary-for-itera
5480: 74 65 64 2d 74 65 73 74 20 72 75 6e 2d 69 64 20 ted-test run-id
5490: 74 65 73 74 2d 69 64 20 74 65 73 74 2d 6e 61 6d test-id test-nam
54a0: 65 20 6f 75 74 70 75 74 66 69 6c 65 6e 61 6d 65 e outputfilename
54b0: 29 0a 20 20 28 6c 65 74 20 28 28 63 6f 75 6e 74 ). (let ((count
54c0: 73 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 s (
54d0: 6d 61 6b 65 2d 68 61 73 68 2d 74 61 62 6c 65 29 make-hash-table)
54e0: 29 0a 09 28 73 74 61 74 65 63 6f 75 6e 74 73 20 )..(statecounts
54f0: 20 20 20 20 20 20 20 20 28 6d 61 6b 65 2d 68 61 (make-ha
5500: 73 68 2d 74 61 62 6c 65 29 29 0a 09 28 6f 75 74 sh-table))..(out
5510: 74 78 74 20 20 20 20 20 20 20 20 20 20 20 20 20 txt
5520: 20 22 22 29 0a 09 28 74 6f 74 20 20 20 20 20 20 "")..(tot
5530: 20 20 20 20 20 20 20 20 20 20 20 30 29 0a 09 28 0)..(
5540: 74 65 73 74 64 61 74 20 20 20 20 20 20 20 20 20 testdat
5550: 20 20 20 20 28 72 6d 74 3a 74 65 73 74 2d 67 65 (rmt:test-ge
5560: 74 2d 72 65 63 6f 72 64 73 2d 66 6f 72 2d 69 6e t-records-for-in
5570: 64 65 78 2d 66 69 6c 65 20 72 75 6e 2d 69 64 20 dex-file run-id
5580: 74 65 73 74 2d 6e 61 6d 65 29 29 29 0a 20 20 20 test-name))).
5590: 20 28 77 69 74 68 2d 6f 75 74 70 75 74 2d 74 6f (with-output-to
55a0: 2d 66 69 6c 65 20 6f 75 74 70 75 74 66 69 6c 65 -file outputfile
55b0: 6e 61 6d 65 0a 20 20 20 20 20 20 28 6c 61 6d 62 name. (lamb
55c0: 64 61 20 28 29 0a 09 28 73 65 74 21 20 6f 75 74 da ()..(set! out
55d0: 74 78 74 20 28 63 6f 6e 63 20 6f 75 74 74 78 74 txt (conc outtxt
55e0: 20 22 3c 68 74 6d 6c 3e 3c 74 69 74 6c 65 3e 53 "<html><title>S
55f0: 75 6d 6d 61 72 79 3a 20 22 20 74 65 73 74 2d 6e ummary: " test-n
5600: 61 6d 65 20 0a 09 09 09 20 20 20 22 3c 2f 74 69 ame .... "</ti
5610: 74 6c 65 3e 3c 62 6f 64 79 3e 3c 68 32 3e 53 75 tle><body><h2>Su
5620: 6d 6d 61 72 79 20 66 6f 72 20 22 20 74 65 73 74 mmary for " test
5630: 2d 6e 61 6d 65 20 22 3c 2f 68 32 3e 22 29 29 0a -name "</h2>")).
5640: 09 28 66 6f 72 2d 65 61 63 68 0a 09 20 28 6c 61 .(for-each.. (la
5650: 6d 62 64 61 20 28 74 65 73 74 72 65 63 6f 72 64 mbda (testrecord
5660: 29 0a 09 20 20 20 28 6c 65 74 20 28 28 69 64 20 ).. (let ((id
5670: 20 20 20 20 20 20 20 20 20 20 20 20 28 76 65 63 (vec
5680: 74 6f 72 2d 72 65 66 20 74 65 73 74 72 65 63 6f tor-ref testreco
5690: 72 64 20 30 29 29 0a 09 09 20 28 69 74 65 6d 70 rd 0))... (itemp
56a0: 61 74 68 20 20 20 20 20 20 20 28 76 65 63 74 6f ath (vecto
56b0: 72 2d 72 65 66 20 74 65 73 74 72 65 63 6f 72 64 r-ref testrecord
56c0: 20 31 29 29 0a 09 09 20 28 73 74 61 74 65 20 20 1))... (state
56d0: 20 20 20 20 20 20 20 20 28 76 65 63 74 6f 72 2d (vector-
56e0: 72 65 66 20 74 65 73 74 72 65 63 6f 72 64 20 32 ref testrecord 2
56f0: 29 29 0a 09 09 20 28 73 74 61 74 75 73 20 20 20 ))... (status
5700: 20 20 20 20 20 20 28 76 65 63 74 6f 72 2d 72 65 (vector-re
5710: 66 20 74 65 73 74 72 65 63 6f 72 64 20 33 29 29 f testrecord 3))
5720: 0a 09 09 20 28 72 75 6e 5f 64 75 72 61 74 69 6f ... (run_duratio
5730: 6e 20 20 20 28 76 65 63 74 6f 72 2d 72 65 66 20 n (vector-ref
5740: 74 65 73 74 72 65 63 6f 72 64 20 34 29 29 0a 09 testrecord 4))..
5750: 09 20 28 6c 6f 67 66 20 20 20 20 20 20 20 20 20 . (logf
5760: 20 20 28 76 65 63 74 6f 72 2d 72 65 66 20 74 65 (vector-ref te
5770: 73 74 72 65 63 6f 72 64 20 35 29 29 0a 09 09 20 strecord 5))...
5780: 28 63 6f 6d 6d 65 6e 74 20 20 20 20 20 20 20 20 (comment
5790: 28 76 65 63 74 6f 72 2d 72 65 66 20 74 65 73 74 (vector-ref test
57a0: 72 65 63 6f 72 64 20 36 29 29 29 0a 09 20 20 20 record 6)))..
57b0: 20 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 (hash-table-se
57c0: 74 21 20 63 6f 75 6e 74 73 20 73 74 61 74 75 73 t! counts status
57d0: 20 28 2b 20 31 20 28 68 61 73 68 2d 74 61 62 6c (+ 1 (hash-tabl
57e0: 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 63 6f e-ref/default co
57f0: 75 6e 74 73 20 73 74 61 74 75 73 20 30 29 29 29 unts status 0)))
5800: 0a 09 20 20 20 20 20 28 68 61 73 68 2d 74 61 62 .. (hash-tab
5810: 6c 65 2d 73 65 74 21 20 73 74 61 74 65 63 6f 75 le-set! statecou
5820: 6e 74 73 20 73 74 61 74 65 20 28 2b 20 31 20 28 nts state (+ 1 (
5830: 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 hash-table-ref/d
5840: 65 66 61 75 6c 74 20 73 74 61 74 65 63 6f 75 6e efault statecoun
5850: 74 73 20 73 74 61 74 65 20 30 29 29 29 0a 09 20 ts state 0)))..
5860: 20 20 20 20 28 73 65 74 21 20 6f 75 74 74 78 74 (set! outtxt
5870: 20 28 63 6f 6e 63 20 6f 75 74 74 78 74 20 22 3c (conc outtxt "<
5880: 74 72 3e 22 0a 09 09 09 09 3b 3b 20 22 3c 74 64 tr>".....;; "<td
5890: 3e 3c 61 20 68 72 65 66 3d 5c 22 22 20 69 74 65 ><a href=\"" ite
58a0: 6d 70 61 74 68 20 22 2f 22 20 6c 6f 67 66 20 22 mpath "/" logf "
58b0: 5c 22 3e 20 22 20 69 74 65 6d 70 61 74 68 20 22 \"> " itempath "
58c0: 3c 2f 61 3e 3c 2f 74 64 3e 22 20 0a 09 09 09 09 </a></td>" .....
58d0: 22 3c 74 64 3e 3c 61 20 68 72 65 66 3d 5c 22 22 "<td><a href=\""
58e0: 20 69 74 65 6d 70 61 74 68 20 22 2f 74 65 73 74 itempath "/test
58f0: 2d 73 75 6d 6d 61 72 79 2e 68 74 6d 6c 5c 22 3e -summary.html\">
5900: 20 22 20 69 74 65 6d 70 61 74 68 20 22 3c 2f 61 " itempath "</a
5910: 3e 3c 2f 74 64 3e 22 20 0a 09 09 09 09 22 3c 74 ></td>" ....."<t
5920: 64 3e 22 20 73 74 61 74 65 20 20 20 20 22 3c 2f d>" state "</
5930: 74 64 3e 22 20 0a 09 09 09 09 22 3c 74 64 3e 3c td>" ....."<td><
5940: 66 6f 6e 74 20 63 6f 6c 6f 72 3d 22 20 28 63 6f font color=" (co
5950: 6d 6d 6f 6e 3a 67 65 74 2d 63 6f 6c 6f 72 2d 66 mmon:get-color-f
5960: 72 6f 6d 2d 73 74 61 74 75 73 20 73 74 61 74 75 rom-status statu
5970: 73 29 0a 09 09 09 09 22 3e 22 20 20 20 73 74 61 s).....">" sta
5980: 74 75 73 20 20 20 22 3c 2f 66 6f 6e 74 3e 3c 2f tus "</font></
5990: 74 64 3e 22 0a 09 09 09 09 22 3c 74 64 3e 22 20 td>"....."<td>"
59a0: 28 69 66 20 28 65 71 75 61 6c 3f 20 63 6f 6d 6d (if (equal? comm
59b0: 65 6e 74 20 22 22 29 0a 09 09 09 09 09 20 20 20 ent "")......
59c0: 22 26 6e 62 73 70 3b 22 0a 09 09 09 09 09 20 20 " "......
59d0: 20 63 6f 6d 6d 65 6e 74 29 20 22 3c 2f 74 64 3e comment) "</td>
59e0: 22 0a 09 09 09 09 09 20 20 20 22 3c 2f 74 72 3e "...... "</tr>
59f0: 22 29 29 29 29 0a 09 20 28 69 66 20 28 6c 69 73 ")))).. (if (lis
5a00: 74 3f 20 74 65 73 74 64 61 74 29 0a 09 20 20 20 t? testdat)..
5a10: 20 20 74 65 73 74 64 61 74 0a 09 20 20 20 20 20 testdat..
5a20: 28 62 65 67 69 6e 0a 09 20 20 20 20 20 20 20 28 (begin.. (
5a30: 70 72 69 6e 74 20 22 45 52 52 4f 52 3a 20 66 61 print "ERROR: fa
5a40: 69 6c 65 64 20 74 6f 20 67 65 74 20 72 65 63 6f iled to get reco
5a50: 72 64 73 20 77 69 74 68 20 72 6d 74 3a 74 65 73 rds with rmt:tes
5a60: 74 2d 67 65 74 2d 72 65 63 6f 72 64 73 2d 66 6f t-get-records-fo
5a70: 72 2d 69 6e 64 65 78 2d 66 69 6c 65 20 72 75 6e r-index-file run
5a80: 2d 69 64 3d 22 20 72 75 6e 2d 69 64 20 22 74 65 -id=" run-id "te
5a90: 73 74 2d 6e 61 6d 65 3d 22 20 74 65 73 74 2d 6e st-name=" test-n
5aa0: 61 6d 65 29 0a 09 20 20 20 20 20 20 20 27 28 29 ame).. '()
5ab0: 29 29 29 0a 09 0a 09 28 70 72 69 6e 74 20 22 3c )))....(print "<
5ac0: 74 61 62 6c 65 3e 3c 74 72 3e 3c 74 64 20 76 61 table><tr><td va
5ad0: 6c 69 67 6e 3d 5c 22 74 6f 70 5c 22 3e 22 29 0a lign=\"top\">").
5ae0: 09 3b 3b 20 50 72 69 6e 74 20 6f 75 74 20 73 74 .;; Print out st
5af0: 61 74 73 20 66 6f 72 20 73 74 61 74 75 73 0a 09 ats for status..
5b00: 28 73 65 74 21 20 74 6f 74 20 30 29 0a 09 28 70 (set! tot 0)..(p
5b10: 72 69 6e 74 20 22 3c 74 61 62 6c 65 20 63 65 6c rint "<table cel
5b20: 6c 73 70 61 63 69 6e 67 3d 5c 22 30 5c 22 20 62 lspacing=\"0\" b
5b30: 6f 72 64 65 72 3d 5c 22 31 5c 22 3e 3c 74 72 3e order=\"1\"><tr>
5b40: 3c 74 64 20 63 6f 6c 73 70 61 6e 3d 5c 22 32 5c <td colspan=\"2\
5b50: 22 3e 3c 68 32 3e 53 74 61 74 65 20 73 74 61 74 "><h2>State stat
5b60: 73 3c 2f 68 32 3e 3c 2f 74 64 3e 3c 2f 74 72 3e s</h2></td></tr>
5b70: 22 29 0a 09 28 66 6f 72 2d 65 61 63 68 20 28 6c ")..(for-each (l
5b80: 61 6d 62 64 61 20 28 73 74 61 74 65 29 0a 09 09 ambda (state)...
5b90: 20 20 20 20 28 73 65 74 21 20 74 6f 74 20 28 2b (set! tot (+
5ba0: 20 74 6f 74 20 28 68 61 73 68 2d 74 61 62 6c 65 tot (hash-table
5bb0: 2d 72 65 66 20 73 74 61 74 65 63 6f 75 6e 74 73 -ref statecounts
5bc0: 20 73 74 61 74 65 29 29 29 0a 09 09 20 20 20 20 state)))...
5bd0: 28 70 72 69 6e 74 20 22 3c 74 72 3e 3c 74 64 3e (print "<tr><td>
5be0: 22 20 73 74 61 74 65 20 22 3c 2f 74 64 3e 3c 74 " state "</td><t
5bf0: 64 3e 22 20 28 68 61 73 68 2d 74 61 62 6c 65 2d d>" (hash-table-
5c00: 72 65 66 20 73 74 61 74 65 63 6f 75 6e 74 73 20 ref statecounts
5c10: 73 74 61 74 65 29 20 22 3c 2f 74 64 3e 3c 2f 74 state) "</td></t
5c20: 72 3e 22 29 29 0a 09 09 20 20 28 68 61 73 68 2d r>"))... (hash-
5c30: 74 61 62 6c 65 2d 6b 65 79 73 20 73 74 61 74 65 table-keys state
5c40: 63 6f 75 6e 74 73 29 29 0a 09 28 70 72 69 6e 74 counts))..(print
5c50: 20 22 3c 74 72 3e 3c 74 64 3e 54 6f 74 61 6c 3c "<tr><td>Total<
5c60: 2f 74 64 3e 3c 74 64 3e 22 20 74 6f 74 20 22 3c /td><td>" tot "<
5c70: 2f 74 64 3e 3c 2f 74 72 3e 3c 2f 74 61 62 6c 65 /td></tr></table
5c80: 3e 22 29 0a 09 28 70 72 69 6e 74 20 22 3c 2f 74 >")..(print "</t
5c90: 64 3e 3c 74 64 20 76 61 6c 69 67 6e 3d 5c 22 74 d><td valign=\"t
5ca0: 6f 70 5c 22 3e 22 29 0a 09 3b 3b 20 50 72 69 6e op\">")..;; Prin
5cb0: 74 20 6f 75 74 20 73 74 61 74 73 20 66 6f 72 20 t out stats for
5cc0: 73 74 61 74 65 0a 09 28 73 65 74 21 20 74 6f 74 state..(set! tot
5cd0: 20 30 29 0a 09 28 70 72 69 6e 74 20 22 3c 74 61 0)..(print "<ta
5ce0: 62 6c 65 20 63 65 6c 6c 73 70 61 63 69 6e 67 3d ble cellspacing=
5cf0: 5c 22 30 5c 22 20 62 6f 72 64 65 72 3d 5c 22 31 \"0\" border=\"1
5d00: 5c 22 3e 3c 74 72 3e 3c 74 64 20 63 6f 6c 73 70 \"><tr><td colsp
5d10: 61 6e 3d 5c 22 32 5c 22 3e 3c 68 32 3e 53 74 61 an=\"2\"><h2>Sta
5d20: 74 75 73 20 73 74 61 74 73 3c 2f 68 32 3e 3c 2f tus stats</h2></
5d30: 74 64 3e 3c 2f 74 72 3e 22 29 0a 09 28 66 6f 72 td></tr>")..(for
5d40: 2d 65 61 63 68 20 28 6c 61 6d 62 64 61 20 28 73 -each (lambda (s
5d50: 74 61 74 75 73 29 0a 09 09 20 20 20 20 28 73 65 tatus)... (se
5d60: 74 21 20 74 6f 74 20 28 2b 20 74 6f 74 20 28 68 t! tot (+ tot (h
5d70: 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 20 63 6f ash-table-ref co
5d80: 75 6e 74 73 20 73 74 61 74 75 73 29 29 29 0a 09 unts status)))..
5d90: 09 20 20 20 20 28 70 72 69 6e 74 20 22 3c 74 72 . (print "<tr
5da0: 3e 3c 74 64 3e 3c 66 6f 6e 74 20 63 6f 6c 6f 72 ><td><font color
5db0: 3d 5c 22 22 20 28 63 6f 6d 6d 6f 6e 3a 67 65 74 =\"" (common:get
5dc0: 2d 63 6f 6c 6f 72 2d 66 72 6f 6d 2d 73 74 61 74 -color-from-stat
5dd0: 75 73 20 73 74 61 74 75 73 29 20 22 5c 22 3e 22 us status) "\">"
5de0: 20 73 74 61 74 75 73 0a 09 09 09 20 20 20 22 3c status.... "<
5df0: 2f 66 6f 6e 74 3e 3c 2f 74 64 3e 3c 74 64 3e 22 /font></td><td>"
5e00: 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 (hash-table-ref
5e10: 20 63 6f 75 6e 74 73 20 73 74 61 74 75 73 29 20 counts status)
5e20: 22 3c 2f 74 64 3e 3c 2f 74 72 3e 22 29 29 0a 09 "</td></tr>"))..
5e30: 09 20 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 6b . (hash-table-k
5e40: 65 79 73 20 63 6f 75 6e 74 73 29 29 0a 09 28 70 eys counts))..(p
5e50: 72 69 6e 74 20 22 3c 74 72 3e 3c 74 64 3e 54 6f rint "<tr><td>To
5e60: 74 61 6c 3c 2f 74 64 3e 3c 74 64 3e 22 20 74 6f tal</td><td>" to
5e70: 74 20 22 3c 2f 74 64 3e 3c 2f 74 72 3e 3c 2f 74 t "</td></tr></t
5e80: 61 62 6c 65 3e 22 29 0a 09 28 70 72 69 6e 74 20 able>")..(print
5e90: 22 3c 2f 74 64 3e 3c 2f 74 64 3e 3c 2f 74 72 3e "</td></td></tr>
5ea0: 3c 2f 74 61 62 6c 65 3e 22 29 0a 09 0a 09 28 70 </table>")....(p
5eb0: 72 69 6e 74 20 22 3c 74 61 62 6c 65 20 63 65 6c rint "<table cel
5ec0: 6c 73 70 61 63 69 6e 67 3d 5c 22 30 5c 22 20 62 lspacing=\"0\" b
5ed0: 6f 72 64 65 72 3d 5c 22 31 5c 22 3e 22 20 0a 09 order=\"1\">" ..
5ee0: 20 20 20 20 20 20 20 22 3c 74 72 3e 3c 74 64 3e "<tr><td>
5ef0: 49 74 65 6d 3c 2f 74 64 3e 3c 74 64 3e 53 74 61 Item</td><td>Sta
5f00: 74 65 3c 2f 74 64 3e 3c 74 64 3e 53 74 61 74 75 te</td><td>Statu
5f10: 73 3c 2f 74 64 3e 3c 74 64 3e 43 6f 6d 6d 65 6e s</td><td>Commen
5f20: 74 3c 2f 74 64 3e 22 0a 09 20 20 20 20 20 20 20 t</td>"..
5f30: 6f 75 74 74 78 74 20 22 3c 2f 74 61 62 6c 65 3e outtxt "</table>
5f40: 3c 2f 62 6f 64 79 3e 3c 2f 68 74 6d 6c 3e 22 29 </body></html>")
5f50: 0a 09 3b 3b 20 28 72 65 6c 65 61 73 65 2d 64 6f ..;; (release-do
5f60: 74 2d 6c 6f 63 6b 20 6f 75 74 70 75 74 66 69 6c t-lock outputfil
5f70: 65 6e 61 6d 65 29 0a 09 3b 3b 28 72 6d 74 3a 75 ename)..;;(rmt:u
5f80: 70 64 61 74 65 2d 72 75 6e 2d 73 74 61 74 73 20 pdate-run-stats
5f90: 0a 09 3b 3b 20 72 75 6e 2d 69 64 0a 09 3b 3b 20 ..;; run-id..;;
5fa0: 28 68 61 73 68 2d 74 61 62 6c 65 2d 6d 61 70 0a (hash-table-map.
5fb0: 09 3b 3b 20 20 73 74 61 74 65 2d 73 74 61 74 75 .;; state-statu
5fc0: 73 2d 63 6f 75 6e 74 73 0a 09 3b 3b 20 20 28 6c s-counts..;; (l
5fd0: 61 6d 62 64 61 20 28 6b 65 79 20 76 61 6c 29 0a ambda (key val).
5fe0: 09 3b 3b 09 28 61 70 70 65 6e 64 20 6b 65 79 20 .;;.(append key
5ff0: 28 6c 69 73 74 20 76 61 6c 29 29 29 29 29 0a 09 (list val)))))..
6000: 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 74 65 ))))..(define te
6010: 73 74 73 3a 63 73 73 2d 6a 73 63 72 69 70 74 2d sts:css-jscript-
6020: 62 6c 6f 63 6b 0a 23 3c 3c 45 4f 46 0a 3c 73 74 block.#<<EOF.<st
6030: 79 6c 65 20 74 79 70 65 3d 22 74 65 78 74 2f 63 yle type="text/c
6040: 73 73 22 3e 0a 75 6c 2e 4c 69 6e 6b 65 64 4c 69 ss">.ul.LinkedLi
6050: 73 74 20 7b 20 64 69 73 70 6c 61 79 3a 20 62 6c st { display: bl
6060: 6f 63 6b 3b 20 7d 0a 2f 2a 20 75 6c 2e 4c 69 6e ock; }./* ul.Lin
6070: 6b 65 64 4c 69 73 74 20 75 6c 20 7b 20 64 69 73 kedList ul { dis
6080: 70 6c 61 79 3a 20 6e 6f 6e 65 3b 20 7d 20 2a 2f play: none; } */
6090: 0a 2e 48 61 6e 64 43 75 72 73 6f 72 53 74 79 6c ..HandCursorStyl
60a0: 65 20 7b 20 63 75 72 73 6f 72 3a 20 70 6f 69 6e e { cursor: poin
60b0: 74 65 72 3b 20 63 75 72 73 6f 72 3a 20 68 61 6e ter; cursor: han
60c0: 64 3b 20 7d 20 20 2f 2a 20 46 6f 72 20 49 45 20 d; } /* For IE
60d0: 2a 2f 0a 74 68 20 7b 62 61 63 6b 67 72 6f 75 6e */.th {backgroun
60e0: 64 2d 63 6f 6c 6f 72 3a 20 23 38 63 38 63 38 63 d-color: #8c8c8c
60f0: 3b 7d 0a 74 64 2e 74 65 73 74 20 7b 62 61 63 6b ;}.td.test {back
6100: 67 72 6f 75 6e 64 2d 63 6f 6c 6f 72 3a 20 23 64 ground-color: #d
6110: 39 64 62 64 64 3b 7d 0a 74 64 2e 50 41 53 53 20 9dbdd;}.td.PASS
6120: 7b 62 61 63 6b 67 72 6f 75 6e 64 2d 63 6f 6c 6f {background-colo
6130: 72 3a 20 23 33 34 37 35 33 33 3b 7d 0a 74 64 2e r: #347533;}.td.
6140: 46 41 49 4c 20 7b 62 61 63 6b 67 72 6f 75 6e 64 FAIL {background
6150: 2d 63 6f 6c 6f 72 3a 20 23 63 63 32 38 31 32 3b -color: #cc2812;
6160: 7d 0a 0a 20 20 3c 2f 73 74 79 6c 65 3e 0a 20 20 }.. </style>.
6170: 3c 73 63 72 69 70 74 20 73 72 63 3d 2f 6e 66 73 <script src=/nfs
6180: 2f 73 69 74 65 2f 64 69 73 6b 73 2f 63 68 5f 63 /site/disks/ch_c
6190: 69 61 66 5f 64 69 73 6b 30 32 33 2f 66 64 6b 5f iaf_disk023/fdk_
61a0: 67 77 61 5f 64 69 73 6b 30 30 33 2f 70 6a 68 61 gwa_disk003/pjha
61b0: 74 77 61 6c 2f 66 64 6b 2f 64 6f 63 73 2f 71 61 twal/fdk/docs/qa
61c0: 2d 65 6e 76 2d 74 65 61 6d 2f 6a 71 75 65 72 79 -env-team/jquery
61d0: 2d 33 2e 31 2e 30 2e 73 6c 69 6d 2e 6d 69 6e 2e -3.1.0.slim.min.
61e0: 6a 73 3e 3c 2f 73 63 72 69 70 74 3e 0a 0a 0a 20 js></script>...
61f0: 20 3c 73 63 72 69 70 74 20 74 79 70 65 3d 22 74 <script type="t
6200: 65 78 74 2f 4a 61 76 61 53 63 72 69 70 74 22 3e ext/JavaScript">
6210: 0a 0a 20 20 20 20 66 75 6e 63 74 69 6f 6e 20 66 .. function f
6220: 69 6c 74 65 72 73 6f 6d 65 28 29 20 7b 0a 20 20 iltersome() {.
6230: 24 28 22 74 72 22 29 2e 73 68 6f 77 28 29 3b 0a $("tr").show();.
6240: 20 20 24 28 22 2e 74 65 73 74 22 29 2e 66 69 6c $(".test").fil
6250: 74 65 72 28 0a 20 20 20 20 66 75 6e 63 74 69 6f ter(. functio
6260: 6e 28 29 20 7b 0a 20 20 20 20 20 20 76 61 72 20 n() {. var
6270: 6e 61 6d 65 73 20 3d 20 24 28 27 23 74 65 73 74 names = $('#test
6280: 6e 61 6d 65 27 29 2e 76 61 6c 28 29 2e 73 70 6c name').val().spl
6290: 69 74 28 27 2c 27 29 3b 0a 20 20 20 20 20 20 76 it(',');. v
62a0: 61 72 20 67 6f 6f 64 3d 31 3b 0a 20 20 20 20 20 ar good=1;.
62b0: 20 66 6f 72 20 28 76 61 72 20 69 3d 30 2c 20 6c for (var i=0, l
62c0: 65 6e 3d 6e 61 6d 65 73 2e 6c 65 6e 67 74 68 3b en=names.length;
62d0: 20 69 3c 6c 65 6e 3b 20 69 2b 2b 29 20 7b 0a 20 i<len; i++) {.
62e0: 20 20 20 20 20 20 20 76 61 72 20 75 6e 61 6d 65 var uname
62f0: 3d 6e 61 6d 65 73 5b 69 5d 3b 0a 20 20 20 20 20 =names[i];.
6300: 20 20 20 63 6f 6e 73 6f 6c 65 2e 6c 6f 67 28 22 console.log("
6310: 54 72 79 69 6e 67 20 74 6f 20 63 68 65 63 6b 20 Trying to check
6320: 66 6f 72 20 22 20 2b 20 75 6e 61 6d 65 29 3b 20 for " + uname);
6330: 0a 20 20 20 20 20 20 20 20 69 66 28 24 28 74 68 . if($(th
6340: 69 73 29 2e 74 65 78 74 28 29 2e 69 6e 64 65 78 is).text().index
6350: 4f 66 28 75 6e 61 6d 65 29 20 21 3d 20 2d 31 29 Of(uname) != -1)
6360: 20 7b 0a 20 20 20 20 20 20 20 20 20 20 67 6f 6f {. goo
6370: 64 3d 20 30 3b 0a 20 20 20 20 20 20 20 20 20 20 d= 0;.
6380: 63 6f 6e 73 6f 6c 65 2e 6c 6f 67 28 22 46 6f 75 console.log("Fou
6390: 6e 64 20 22 2b 75 6e 61 6d 65 29 3b 0a 20 20 20 nd "+uname);.
63a0: 20 20 20 20 20 7d 0a 20 20 20 20 20 20 7d 0a 20 }. }.
63b0: 20 20 20 20 20 72 65 74 75 72 6e 20 67 6f 6f 64 return good
63c0: 3b 20 0a 20 20 20 20 7d 0a 20 20 29 2e 70 61 72 ; . }. ).par
63d0: 65 6e 74 28 29 2e 68 69 64 65 28 29 3b 0a 2f 2f ent().hide();.//
63e0: 20 20 24 28 22 2e 73 75 6d 22 29 2e 73 68 6f 77 $(".sum").show
63f0: 28 29 3b 0a 7d 0a 20 20 0a 20 20 20 20 2f 2f 20 ();.}. . //
6400: 41 64 64 20 74 68 69 73 20 74 6f 20 74 68 65 20 Add this to the
6410: 6f 6e 6c 6f 61 64 20 65 76 65 6e 74 20 6f 66 20 onload event of
6420: 74 68 65 20 42 4f 44 59 20 65 6c 65 6d 65 6e 74 the BODY element
6430: 0a 20 20 20 20 66 75 6e 63 74 69 6f 6e 20 61 64 . function ad
6440: 64 45 76 65 6e 74 73 28 29 20 7b 0a 20 20 20 20 dEvents() {.
6450: 20 20 61 63 74 69 76 61 74 65 54 72 65 65 28 64 activateTree(d
6460: 6f 63 75 6d 65 6e 74 2e 67 65 74 45 6c 65 6d 65 ocument.getEleme
6470: 6e 74 42 79 49 64 28 22 4c 69 6e 6b 65 64 4c 69 ntById("LinkedLi
6480: 73 74 31 22 29 29 3b 0a 20 20 20 20 7d 0a 0a 20 st1"));. }..
6490: 20 20 20 2f 2f 20 54 68 69 73 20 66 75 6e 63 74 // This funct
64a0: 69 6f 6e 20 74 72 61 76 65 72 73 65 73 20 74 68 ion traverses th
64b0: 65 20 6c 69 73 74 20 61 6e 64 20 61 64 64 20 6c e list and add l
64c0: 69 6e 6b 73 20 0a 20 20 20 20 2f 2f 20 74 6f 20 inks . // to
64d0: 6e 65 73 74 65 64 20 6c 69 73 74 20 69 74 65 6d nested list item
64e0: 73 0a 20 20 20 20 66 75 6e 63 74 69 6f 6e 20 61 s. function a
64f0: 63 74 69 76 61 74 65 54 72 65 65 28 6f 4c 69 73 ctivateTree(oLis
6500: 74 29 20 7b 0a 20 20 20 20 20 20 2f 2f 20 43 6f t) {. // Co
6510: 6c 6c 61 70 73 65 20 74 68 65 20 74 72 65 65 0a llapse the tree.
6520: 20 20 20 20 20 20 66 6f 72 20 28 76 61 72 20 69 for (var i
6530: 3d 30 3b 20 69 20 3c 20 6f 4c 69 73 74 2e 67 65 =0; i < oList.ge
6540: 74 45 6c 65 6d 65 6e 74 73 42 79 54 61 67 4e 61 tElementsByTagNa
6550: 6d 65 28 22 75 6c 22 29 2e 6c 65 6e 67 74 68 3b me("ul").length;
6560: 20 69 2b 2b 29 20 7b 0a 20 20 20 20 20 20 20 20 i++) {.
6570: 6f 4c 69 73 74 2e 67 65 74 45 6c 65 6d 65 6e 74 oList.getElement
6580: 73 42 79 54 61 67 4e 61 6d 65 28 22 75 6c 22 29 sByTagName("ul")
6590: 5b 69 5d 2e 73 74 79 6c 65 2e 64 69 73 70 6c 61 [i].style.displa
65a0: 79 3d 22 6e 6f 6e 65 22 3b 20 20 20 20 20 20 20 y="none";
65b0: 20 20 20 20 20 0a 20 20 20 20 20 20 7d 20 20 20 . }
65c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
65d0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
65e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
65f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 0a .
6600: 20 20 20 20 20 20 2f 2f 20 41 64 64 20 74 68 65 // Add the
6610: 20 63 6c 69 63 6b 2d 65 76 65 6e 74 20 68 61 6e click-event han
6620: 64 6c 65 72 20 74 6f 20 74 68 65 20 6c 69 73 74 dler to the list
6630: 20 69 74 65 6d 73 0a 20 20 20 20 20 20 69 66 20 items. if
6640: 28 6f 4c 69 73 74 2e 61 64 64 45 76 65 6e 74 4c (oList.addEventL
6650: 69 73 74 65 6e 65 72 29 20 7b 0a 20 20 20 20 20 istener) {.
6660: 20 20 20 6f 4c 69 73 74 2e 61 64 64 45 76 65 6e oList.addEven
6670: 74 4c 69 73 74 65 6e 65 72 28 22 63 6c 69 63 6b tListener("click
6680: 22 2c 20 74 6f 67 67 6c 65 42 72 61 6e 63 68 2c ", toggleBranch,
6690: 20 66 61 6c 73 65 29 3b 0a 20 20 20 20 20 20 7d false);. }
66a0: 20 65 6c 73 65 20 69 66 20 28 6f 4c 69 73 74 2e else if (oList.
66b0: 61 74 74 61 63 68 45 76 65 6e 74 29 20 7b 20 2f attachEvent) { /
66c0: 2f 20 46 6f 72 20 49 45 0a 20 20 20 20 20 20 20 / For IE.
66d0: 20 6f 4c 69 73 74 2e 61 74 74 61 63 68 45 76 65 oList.attachEve
66e0: 6e 74 28 22 6f 6e 63 6c 69 63 6b 22 2c 20 74 6f nt("onclick", to
66f0: 67 67 6c 65 42 72 61 6e 63 68 29 3b 0a 20 20 20 ggleBranch);.
6700: 20 20 20 7d 0a 20 20 20 20 20 20 2f 2f 20 4d 61 }. // Ma
6710: 6b 65 20 74 68 65 20 6e 65 73 74 65 64 20 69 74 ke the nested it
6720: 65 6d 73 20 6c 6f 6f 6b 20 6c 69 6b 65 20 6c 69 ems look like li
6730: 6e 6b 73 0a 20 20 20 20 20 20 61 64 64 4c 69 6e nks. addLin
6740: 6b 73 54 6f 42 72 61 6e 63 68 65 73 28 6f 4c 69 ksToBranches(oLi
6750: 73 74 29 3b 0a 20 20 20 20 7d 0a 0a 20 20 20 20 st);. }..
6760: 2f 2f 20 54 68 69 73 20 69 73 20 74 68 65 20 63 // This is the c
6770: 6c 69 63 6b 2d 65 76 65 6e 74 20 68 61 6e 64 6c lick-event handl
6780: 65 72 0a 20 20 20 20 66 75 6e 63 74 69 6f 6e 20 er. function
6790: 74 6f 67 67 6c 65 42 72 61 6e 63 68 28 65 76 65 toggleBranch(eve
67a0: 6e 74 29 20 7b 0a 20 20 20 20 20 20 76 61 72 20 nt) {. var
67b0: 6f 42 72 61 6e 63 68 2c 20 63 53 75 62 42 72 61 oBranch, cSubBra
67c0: 6e 63 68 65 73 3b 0a 20 20 20 20 20 20 69 66 20 nches;. if
67d0: 28 65 76 65 6e 74 2e 74 61 72 67 65 74 29 20 7b (event.target) {
67e0: 0a 20 20 20 20 20 20 20 20 6f 42 72 61 6e 63 68 . oBranch
67f0: 20 3d 20 65 76 65 6e 74 2e 74 61 72 67 65 74 3b = event.target;
6800: 0a 20 20 20 20 20 20 7d 20 65 6c 73 65 20 69 66 . } else if
6810: 20 28 65 76 65 6e 74 2e 73 72 63 45 6c 65 6d 65 (event.srcEleme
6820: 6e 74 29 20 7b 20 2f 2f 20 46 6f 72 20 49 45 0a nt) { // For IE.
6830: 20 20 20 20 20 20 20 20 6f 42 72 61 6e 63 68 20 oBranch
6840: 3d 20 65 76 65 6e 74 2e 73 72 63 45 6c 65 6d 65 = event.srcEleme
6850: 6e 74 3b 0a 20 20 20 20 20 20 7d 0a 20 20 20 20 nt;. }.
6860: 20 20 63 53 75 62 42 72 61 6e 63 68 65 73 20 3d cSubBranches =
6870: 20 6f 42 72 61 6e 63 68 2e 67 65 74 45 6c 65 6d oBranch.getElem
6880: 65 6e 74 73 42 79 54 61 67 4e 61 6d 65 28 22 75 entsByTagName("u
6890: 6c 22 29 3b 0a 20 20 20 20 20 20 69 66 20 28 63 l");. if (c
68a0: 53 75 62 42 72 61 6e 63 68 65 73 2e 6c 65 6e 67 SubBranches.leng
68b0: 74 68 20 3e 20 30 29 20 7b 0a 20 20 20 20 20 20 th > 0) {.
68c0: 20 20 69 66 20 28 63 53 75 62 42 72 61 6e 63 68 if (cSubBranch
68d0: 65 73 5b 30 5d 2e 73 74 79 6c 65 2e 64 69 73 70 es[0].style.disp
68e0: 6c 61 79 20 3d 3d 20 22 62 6c 6f 63 6b 22 29 20 lay == "block")
68f0: 7b 0a 20 20 20 20 20 20 20 20 20 20 63 53 75 62 {. cSub
6900: 42 72 61 6e 63 68 65 73 5b 30 5d 2e 73 74 79 6c Branches[0].styl
6910: 65 2e 64 69 73 70 6c 61 79 20 3d 20 22 6e 6f 6e e.display = "non
6920: 65 22 3b 0a 20 20 20 20 20 20 20 20 7d 20 65 6c e";. } el
6930: 73 65 20 7b 0a 20 20 20 20 20 20 20 20 20 20 63 se {. c
6940: 53 75 62 42 72 61 6e 63 68 65 73 5b 30 5d 2e 73 SubBranches[0].s
6950: 74 79 6c 65 2e 64 69 73 70 6c 61 79 20 3d 20 22 tyle.display = "
6960: 62 6c 6f 63 6b 22 3b 0a 20 20 20 20 20 20 20 20 block";.
6970: 7d 0a 20 20 20 20 20 20 7d 0a 20 20 20 20 7d 0a }. }. }.
6980: 0a 20 20 20 20 2f 2f 20 54 68 69 73 20 66 75 6e . // This fun
6990: 63 74 69 6f 6e 20 6d 61 6b 65 73 20 6e 65 73 74 ction makes nest
69a0: 65 64 20 6c 69 73 74 20 69 74 65 6d 73 20 6c 6f ed list items lo
69b0: 6f 6b 20 6c 69 6b 65 20 6c 69 6e 6b 73 0a 20 20 ok like links.
69c0: 20 20 66 75 6e 63 74 69 6f 6e 20 61 64 64 4c 69 function addLi
69d0: 6e 6b 73 54 6f 42 72 61 6e 63 68 65 73 28 6f 4c nksToBranches(oL
69e0: 69 73 74 29 20 7b 0a 20 20 20 20 20 20 76 61 72 ist) {. var
69f0: 20 63 42 72 61 6e 63 68 65 73 20 3d 20 6f 4c 69 cBranches = oLi
6a00: 73 74 2e 67 65 74 45 6c 65 6d 65 6e 74 73 42 79 st.getElementsBy
6a10: 54 61 67 4e 61 6d 65 28 22 6c 69 22 29 3b 0a 20 TagName("li");.
6a20: 20 20 20 20 20 76 61 72 20 69 2c 20 6e 2c 20 63 var i, n, c
6a30: 53 75 62 42 72 61 6e 63 68 65 73 3b 0a 20 20 20 SubBranches;.
6a40: 20 20 20 69 66 20 28 63 42 72 61 6e 63 68 65 73 if (cBranches
6a50: 2e 6c 65 6e 67 74 68 20 3e 20 30 29 20 7b 0a 20 .length > 0) {.
6a60: 20 20 20 20 20 20 20 66 6f 72 20 28 69 3d 30 2c for (i=0,
6a70: 20 6e 20 3d 20 63 42 72 61 6e 63 68 65 73 2e 6c n = cBranches.l
6a80: 65 6e 67 74 68 3b 20 69 20 3c 20 6e 3b 20 69 2b ength; i < n; i+
6a90: 2b 29 20 7b 0a 20 20 20 20 20 20 20 20 20 20 63 +) {. c
6aa0: 53 75 62 42 72 61 6e 63 68 65 73 20 3d 20 63 42 SubBranches = cB
6ab0: 72 61 6e 63 68 65 73 5b 69 5d 2e 67 65 74 45 6c ranches[i].getEl
6ac0: 65 6d 65 6e 74 73 42 79 54 61 67 4e 61 6d 65 28 ementsByTagName(
6ad0: 22 75 6c 22 29 3b 0a 20 20 20 20 20 20 20 20 20 "ul");.
6ae0: 20 69 66 20 28 63 53 75 62 42 72 61 6e 63 68 65 if (cSubBranche
6af0: 73 2e 6c 65 6e 67 74 68 20 3e 20 30 29 20 7b 0a s.length > 0) {.
6b00: 20 20 20 20 20 20 20 20 20 20 20 20 61 64 64 4c addL
6b10: 69 6e 6b 73 54 6f 42 72 61 6e 63 68 65 73 28 63 inksToBranches(c
6b20: 53 75 62 42 72 61 6e 63 68 65 73 5b 30 5d 29 3b SubBranches[0]);
6b30: 0a 20 20 20 20 20 20 20 20 20 20 20 20 63 42 72 . cBr
6b40: 61 6e 63 68 65 73 5b 69 5d 2e 63 6c 61 73 73 4e anches[i].classN
6b50: 61 6d 65 20 3d 20 22 48 61 6e 64 43 75 72 73 6f ame = "HandCurso
6b60: 72 53 74 79 6c 65 22 3b 0a 20 20 20 20 20 20 20 rStyle";.
6b70: 20 20 20 20 20 63 42 72 61 6e 63 68 65 73 5b 69 cBranches[i
6b80: 5d 2e 73 74 79 6c 65 2e 63 6f 6c 6f 72 20 3d 20 ].style.color =
6b90: 22 62 6c 75 65 22 3b 0a 20 20 20 20 20 20 20 20 "blue";.
6ba0: 20 20 20 20 63 53 75 62 42 72 61 6e 63 68 65 73 cSubBranches
6bb0: 5b 30 5d 2e 73 74 79 6c 65 2e 63 6f 6c 6f 72 20 [0].style.color
6bc0: 3d 20 22 62 6c 61 63 6b 22 3b 0a 20 20 20 20 20 = "black";.
6bd0: 20 20 20 20 20 20 20 63 53 75 62 42 72 61 6e 63 cSubBranc
6be0: 68 65 73 5b 30 5d 2e 73 74 79 6c 65 2e 63 75 72 hes[0].style.cur
6bf0: 73 6f 72 20 3d 20 22 61 75 74 6f 22 3b 0a 20 20 sor = "auto";.
6c00: 20 20 20 20 20 20 20 20 7d 0a 20 20 20 20 20 20 }.
6c10: 20 20 7d 0a 20 20 20 20 20 20 7d 0a 20 20 20 20 }. }.
6c20: 7d 0a 20 20 3c 2f 73 63 72 69 70 74 3e 0a 45 4f }. </script>.EO
6c30: 46 0a 29 0a 0a 28 64 65 66 69 6e 65 20 28 74 65 F.)..(define (te
6c40: 73 74 73 3a 72 75 6e 2d 72 65 63 6f 72 64 2d 3e sts:run-record->
6c50: 74 65 73 74 2d 70 61 74 68 20 72 75 6e 20 6e 75 test-path run nu
6c60: 6d 6b 65 79 73 29 0a 20 20 20 28 61 70 70 65 6e mkeys). (appen
6c70: 64 20 28 74 61 6b 65 20 28 76 65 63 74 6f 72 2d d (take (vector-
6c80: 3e 6c 69 73 74 20 72 75 6e 29 20 6e 75 6d 6b 65 >list run) numke
6c90: 79 73 29 0a 09 20 20 20 28 6c 69 73 74 20 28 76 ys).. (list (v
6ca0: 65 63 74 6f 72 2d 72 65 66 20 72 75 6e 20 28 2b ector-ref run (+
6cb0: 20 31 20 6e 75 6d 6b 65 79 73 29 29 29 29 29 0a 1 numkeys))))).
6cc0: 0a 0a 28 64 65 66 69 6e 65 20 28 74 65 73 74 73 ..(define (tests
6cd0: 3a 67 65 74 2d 72 65 73 74 2d 64 61 74 61 20 72 :get-rest-data r
6ce0: 75 6e 73 20 68 65 61 64 65 72 20 6e 75 6d 6b 65 uns header numke
6cf0: 79 73 29 0a 20 20 20 28 6c 65 74 20 28 28 72 65 ys). (let ((re
6d00: 73 68 20 28 6d 61 6b 65 2d 68 61 73 68 2d 74 61 sh (make-hash-ta
6d10: 62 6c 65 29 29 29 0a 20 20 20 28 66 6f 72 2d 65 ble))). (for-e
6d20: 61 63 68 0a 20 20 20 20 20 28 6c 61 6d 62 64 61 ach. (lambda
6d30: 20 28 72 75 6e 29 0a 20 20 20 20 20 20 20 20 28 (run). (
6d40: 6c 65 74 2a 20 28 28 72 75 6e 2d 69 64 20 28 64 let* ((run-id (d
6d50: 62 3a 67 65 74 2d 76 61 6c 75 65 2d 62 79 2d 68 b:get-value-by-h
6d60: 65 61 64 65 72 20 72 75 6e 20 68 65 61 64 65 72 eader run header
6d70: 20 22 69 64 22 29 29 0a 20 20 20 20 20 20 20 20 "id")).
6d80: 20 20 20 20 20 20 20 28 72 75 6e 2d 64 69 72 20 (run-dir
6d90: 20 20 20 20 20 28 74 65 73 74 73 3a 72 75 6e 2d (tests:run-
6da0: 72 65 63 6f 72 64 2d 3e 74 65 73 74 2d 70 61 74 record->test-pat
6db0: 68 20 72 75 6e 20 6e 75 6d 6b 65 79 73 29 29 0a h run numkeys)).
6dc0: 09 20 20 20 20 20 20 20 28 74 65 73 74 2d 64 61 . (test-da
6dd0: 74 61 20 20 20 20 28 72 6d 74 3a 67 65 74 2d 74 ta (rmt:get-t
6de0: 65 73 74 73 2d 66 6f 72 2d 72 75 6e 0a 09 09 09 ests-for-run....
6df0: 09 20 20 20 72 75 6e 2d 69 64 0a 20 20 20 20 20 . run-id.
6e00: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
6e10: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 22 25 "%
6e20: 22 20 20 20 20 20 20 20 3b 3b 20 74 65 73 74 6e " ;; testn
6e30: 61 6d 65 70 61 74 74 0a 09 09 09 09 20 20 20 27 amepatt..... '
6e40: 28 29 20 20 20 20 20 20 20 20 3b 3b 20 73 74 61 () ;; sta
6e50: 74 65 73 0a 09 09 09 09 20 20 20 27 28 29 20 20 tes..... '()
6e60: 20 20 20 20 20 20 3b 3b 20 73 74 61 74 75 73 65 ;; statuse
6e70: 73 0a 09 09 09 09 20 20 20 23 66 20 20 20 20 20 s..... #f
6e80: 20 20 20 20 3b 3b 20 6f 66 66 73 65 74 0a 09 09 ;; offset...
6e90: 09 09 20 20 20 23 66 20 20 20 20 20 20 20 20 20 .. #f
6ea0: 3b 3b 20 6e 75 6d 2d 74 6f 2d 67 65 74 0a 09 09 ;; num-to-get...
6eb0: 09 09 20 20 20 23 66 20 20 20 20 20 20 20 20 20 .. #f
6ec0: 3b 3b 20 68 69 64 65 2f 6e 6f 74 2d 68 69 64 65 ;; hide/not-hide
6ed0: 0a 09 09 09 09 20 20 20 23 66 20 20 20 20 20 20 ..... #f
6ee0: 20 20 20 3b 3b 20 73 6f 72 74 2d 62 79 0a 09 09 ;; sort-by...
6ef0: 09 09 20 20 20 23 66 20 20 20 20 20 20 20 20 20 .. #f
6f00: 3b 3b 20 73 6f 72 74 2d 6f 72 64 65 72 0a 09 09 ;; sort-order...
6f10: 09 09 20 20 20 23 66 20 20 20 20 20 20 20 20 20 .. #f
6f20: 3b 3b 20 27 73 68 6f 72 74 6c 69 73 74 20 20 20 ;; 'shortlist
6f30: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
6f40: 20 20 20 20 20 20 20 20 3b 3b 20 71 72 79 74 79 ;; qryty
6f50: 70 65 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 pe.
6f60: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
6f70: 20 20 20 20 20 20 30 20 20 20 20 20 20 20 20 20 0
6f80: 3b 3b 20 6c 61 73 74 20 75 70 64 61 74 65 0a 09 ;; last update..
6f90: 09 09 09 20 20 20 23 66 29 29 29 0a 20 20 20 20 ... #f))).
6fa0: 20 20 20 20 20 20 20 20 0a 20 20 20 20 20 20 20 .
6fb0: 20 20 20 20 20 28 6d 61 70 20 28 6c 61 6d 62 64 (map (lambd
6fc0: 61 20 28 74 65 73 74 29 0a 20 20 20 20 20 20 20 a (test).
6fd0: 20 20 20 20 20 20 20 20 20 20 28 6c 65 74 2a 20 (let*
6fe0: 28 28 74 65 73 74 2d 6e 61 6d 65 20 28 76 65 63 ((test-name (vec
6ff0: 74 6f 72 2d 72 65 66 20 74 65 73 74 20 32 29 29 tor-ref test 2))
7000: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
7010: 20 20 20 20 20 20 20 20 20 28 74 65 73 74 2d 68 (test-h
7020: 74 6d 6c 2d 70 61 74 68 20 28 63 6f 6e 63 20 28 tml-path (conc (
7030: 76 65 63 74 6f 72 2d 72 65 66 20 74 65 73 74 20 vector-ref test
7040: 31 30 29 20 22 2f 22 20 28 76 65 63 74 6f 72 2d 10) "/" (vector-
7050: 72 65 66 20 74 65 73 74 20 31 33 29 29 29 0a 20 ref test 13))).
7060: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7070: 20 20 20 20 20 20 20 28 74 65 73 74 2d 69 74 65 (test-ite
7080: 6d 20 28 63 6f 6e 63 20 74 65 73 74 2d 6e 61 6d m (conc test-nam
7090: 65 20 22 3a 22 20 28 76 65 63 74 6f 72 2d 72 65 e ":" (vector-re
70a0: 66 20 74 65 73 74 20 31 31 29 29 29 0a 20 20 20 f test 11))).
70b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
70c0: 20 20 20 20 20 28 74 65 73 74 2d 73 74 61 74 75 (test-statu
70d0: 73 20 28 76 65 63 74 6f 72 2d 72 65 66 20 74 65 s (vector-ref te
70e0: 73 74 20 34 29 29 29 0a 20 20 20 20 20 20 20 20 st 4))).
70f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7100: 20 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
7110: 20 20 28 69 66 20 28 6e 6f 74 20 28 68 61 73 68 (if (not (hash
7120: 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 -table-ref/defau
7130: 6c 74 20 72 65 73 68 20 74 65 73 74 2d 6e 61 6d lt resh test-nam
7140: 65 20 20 23 66 29 29 0a 20 20 20 20 20 20 20 20 e #f)).
7150: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 68 (h
7160: 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 72 ash-table-set! r
7170: 65 73 68 20 74 65 73 74 2d 6e 61 6d 65 20 20 20 esh test-name
7180: 28 6d 61 6b 65 2d 68 61 73 68 2d 74 61 62 6c 65 (make-hash-table
7190: 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 ))).
71a0: 20 20 20 20 28 69 66 20 28 6e 6f 74 20 28 68 61 (if (not (ha
71b0: 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 sh-table-ref/def
71c0: 61 75 6c 74 20 28 68 61 73 68 2d 74 61 62 6c 65 ault (hash-table
71d0: 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 72 65 73 -ref/default res
71e0: 68 20 74 65 73 74 2d 6e 61 6d 65 20 20 23 66 29 h test-name #f)
71f0: 20 20 74 65 73 74 2d 69 74 65 6d 20 20 23 66 29 test-item #f)
7200: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
7210: 20 20 20 20 20 20 20 20 20 28 68 61 73 68 2d 74 (hash-t
7220: 61 62 6c 65 2d 73 65 74 21 20 28 68 61 73 68 2d able-set! (hash-
7230: 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c table-ref/defaul
7240: 74 20 72 65 73 68 20 74 65 73 74 2d 6e 61 6d 65 t resh test-name
7250: 20 20 23 66 29 20 74 65 73 74 2d 69 74 65 6d 20 #f) test-item
7260: 20 20 28 6d 61 6b 65 2d 68 61 73 68 2d 74 61 62 (make-hash-tab
7270: 6c 65 29 29 29 20 0a 20 20 20 20 20 20 20 20 20 le))) .
7280: 20 20 20 20 20 20 28 68 61 73 68 2d 74 61 62 6c (hash-tabl
7290: 65 2d 73 65 74 21 20 20 28 68 61 73 68 2d 74 61 e-set! (hash-ta
72a0: 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 ble-ref/default
72b0: 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f (hash-table-ref/
72c0: 64 65 66 61 75 6c 74 20 72 65 73 68 20 74 65 73 default resh tes
72d0: 74 2d 6e 61 6d 65 20 20 23 66 29 20 74 65 73 74 t-name #f) test
72e0: 2d 69 74 65 6d 20 23 66 29 20 72 75 6e 2d 69 64 -item #f) run-id
72f0: 20 28 6c 69 73 74 20 74 65 73 74 2d 73 74 61 74 (list test-stat
7300: 75 73 20 74 65 73 74 2d 68 74 6d 6c 2d 70 61 74 us test-html-pat
7310: 68 29 29 29 29 20 0a 20 20 20 20 20 20 20 20 74 h)))) . t
7320: 65 73 74 2d 64 61 74 61 29 29 29 0a 20 20 20 20 est-data))).
7330: 20 20 72 75 6e 73 29 0a 20 20 20 72 65 73 68 29 runs). resh)
7340: 29 0a 0a 3b 3b 20 28 74 65 73 74 73 3a 63 72 65 )..;; (tests:cre
7350: 61 74 65 2d 68 74 6d 6c 2d 74 72 65 65 20 22 74 ate-html-tree "t
7360: 65 73 74 2d 69 6e 64 65 78 2e 68 74 6d 6c 22 29 est-index.html")
7370: 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 74 65 73 .;;.(define (tes
7380: 74 73 3a 63 72 65 61 74 65 2d 68 74 6d 6c 2d 74 ts:create-html-t
7390: 72 65 65 20 6f 75 74 66 29 0a 20 20 20 28 6c 65 ree outf). (le
73a0: 74 2a 20 28 28 6c 6f 63 6b 66 69 6c 65 20 20 28 t* ((lockfile (
73b0: 63 6f 6e 63 20 6f 75 74 66 20 22 2e 6c 6f 63 6b conc outf ".lock
73c0: 22 29 29 0a 09 20 28 72 75 6e 73 2d 74 6f 2d 70 ")).. (runs-to-p
73d0: 72 6f 63 65 73 73 20 27 28 29 29 0a 20 20 20 20 rocess '()).
73e0: 20 20 20 20 20 28 6c 69 6e 6b 74 72 65 65 20 20 (linktree
73f0: 28 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 6c 69 6e 6b (common:get-link
7400: 74 72 65 65 29 29 0a 20 20 20 20 20 20 20 20 20 tree)).
7410: 20 28 61 72 65 61 2d 6e 61 6d 65 20 28 63 6f 6d (area-name (com
7420: 6d 6f 6e 3a 67 65 74 2d 74 65 73 74 73 75 69 74 mon:get-testsuit
7430: 65 2d 6e 61 6d 65 29 29 0a 09 20 20 28 6b 65 79 e-name)).. (key
7440: 73 20 20 20 20 20 20 28 72 6d 74 3a 67 65 74 2d s (rmt:get-
7450: 6b 65 79 73 29 29 0a 09 20 20 28 6e 75 6d 6b 65 keys)).. (numke
7460: 79 73 20 20 20 28 6c 65 6e 67 74 68 20 6b 65 79 ys (length key
7470: 73 29 29 0a 20 20 20 20 20 20 20 20 20 28 74 6f s)). (to
7480: 74 61 6c 2d 72 75 6e 73 20 20 28 72 6d 74 3a 67 tal-runs (rmt:g
7490: 65 74 2d 6e 75 6d 2d 72 75 6e 73 20 22 25 22 29 et-num-runs "%")
74a0: 29 0a 20 20 20 20 20 20 20 20 20 28 70 67 2d 73 ). (pg-s
74b0: 69 7a 65 20 31 30 29 20 20 20 29 0a 20 20 20 20 ize 10) ).
74c0: 28 69 66 20 28 63 6f 6d 6d 6f 6e 3a 73 69 6d 70 (if (common:simp
74d0: 6c 65 2d 66 69 6c 65 2d 6c 6f 63 6b 20 6c 6f 63 le-file-lock loc
74e0: 6b 66 69 6c 65 29 0a 20 20 20 20 20 20 20 20 28 kfile). (
74f0: 62 65 67 69 6e 0a 20 20 20 20 20 20 20 20 20 28 begin. (
7500: 70 72 69 6e 74 20 74 6f 74 61 6c 2d 72 75 6e 73 print total-runs
7510: 29 20 20 20 20 0a 20 20 20 20 20 20 20 20 28 6c ) . (l
7520: 65 74 20 6c 6f 6f 70 20 28 28 70 61 67 65 20 30 et loop ((page 0
7530: 29 29 0a 09 28 6c 65 74 2a 20 28 28 6f 75 70 20 ))..(let* ((oup
7540: 20 20 20 20 20 20 28 6f 70 65 6e 2d 6f 75 74 70 (open-outp
7550: 75 74 2d 66 69 6c 65 20 28 6f 72 20 6f 75 74 66 ut-file (or outf
7560: 20 28 63 6f 6e 63 20 6c 69 6e 6b 74 72 65 65 20 (conc linktree
7570: 22 2f 70 61 67 65 22 20 70 61 67 65 20 22 2e 68 "/page" page ".h
7580: 74 6d 6c 22 29 29 29 29 0a 20 20 20 20 20 20 20 tml")))).
7590: 20 20 20 20 20 20 20 20 28 73 74 61 72 74 20 28 (start (
75a0: 2a 20 70 61 67 65 20 70 67 2d 73 69 7a 65 29 29 * page pg-size))
75b0: 20 0a 09 20 20 20 20 20 20 20 28 72 75 6e 73 64 .. (runsd
75c0: 61 74 20 20 20 28 72 6d 74 3a 67 65 74 2d 72 75 at (rmt:get-ru
75d0: 6e 73 20 22 25 22 20 70 67 2d 73 69 7a 65 20 73 ns "%" pg-size s
75e0: 74 61 72 74 20 28 6d 61 70 20 28 6c 61 6d 62 64 tart (map (lambd
75f0: 61 20 28 78 29 28 6c 69 73 74 20 78 20 22 25 22 a (x)(list x "%"
7600: 29 29 20 6b 65 79 73 29 29 29 0a 09 20 20 20 20 )) keys)))..
7610: 20 20 20 28 68 65 61 64 65 72 20 20 20 20 28 76 (header (v
7620: 65 63 74 6f 72 2d 72 65 66 20 72 75 6e 73 64 61 ector-ref runsda
7630: 74 20 30 29 29 0a 09 20 20 20 20 20 20 20 28 72 t 0)).. (r
7640: 75 6e 73 20 20 20 20 20 20 28 76 65 63 74 6f 72 uns (vector
7650: 2d 72 65 66 20 72 75 6e 73 64 61 74 20 31 29 29 -ref runsdat 1))
7660: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
7670: 28 63 74 72 20 30 29 0a 20 20 20 20 20 20 20 20 (ctr 0).
7680: 20 20 20 20 20 20 20 28 74 65 73 74 2d 72 75 6e (test-run
7690: 73 2d 68 61 73 68 20 28 74 65 73 74 73 3a 67 65 s-hash (tests:ge
76a0: 74 2d 72 65 73 74 2d 64 61 74 61 20 72 75 6e 73 t-rest-data runs
76b0: 20 68 65 61 64 65 72 20 6e 75 6d 6b 65 79 73 29 header numkeys)
76c0: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
76d0: 20 28 74 65 73 74 2d 6c 69 73 74 20 28 68 61 73 (test-list (has
76e0: 68 2d 74 61 62 6c 65 2d 6b 65 79 73 20 74 65 73 h-table-keys tes
76f0: 74 2d 72 75 6e 73 2d 68 61 73 68 29 29 0a 20 20 t-runs-hash)).
7700: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 67 65 (ge
7710: 74 2d 70 72 65 76 2d 6c 69 6e 6b 73 20 28 6c 61 t-prev-links (la
7720: 6d 62 64 61 20 28 70 61 67 65 20 6c 69 6e 6b 74 mbda (page linkt
7730: 72 65 65 20 29 20 20 20 0a 20 20 20 20 20 20 20 ree ) .
7740: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7750: 20 20 20 20 20 28 6c 65 74 2a 20 28 28 6c 69 6e (let* ((lin
7760: 6b 20 20 28 69 66 20 28 6e 6f 74 20 28 65 71 3f k (if (not (eq?
7770: 20 70 61 67 65 20 30 29 29 0a 20 20 20 20 20 20 page 0)).
7780: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7790: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
77a0: 20 20 20 20 20 20 28 73 3a 61 20 22 26 6c 74 3b (s:a "<
77b0: 26 6c 74 3b 70 72 65 76 22 20 27 68 72 65 66 20 <prev" 'href
77c0: 28 63 6f 6e 63 20 20 6c 69 6e 6b 74 72 65 65 20 (conc linktree
77d0: 22 2f 70 61 67 65 22 20 28 2d 20 70 61 67 65 20 "/page" (- page
77e0: 31 29 20 22 2e 68 74 6d 6c 22 29 29 0a 20 20 20 1) ".html")).
77f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7800: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7810: 20 20 20 20 20 20 20 20 20 28 73 3a 61 20 22 22 (s:a ""
7820: 20 27 68 72 65 66 20 28 63 6f 6e 63 20 20 6c 69 'href (conc li
7830: 6e 6b 74 72 65 65 20 22 2f 70 61 67 65 22 20 20 nktree "/page"
7840: 70 61 67 65 20 22 2e 68 74 6d 6c 22 29 29 29 29 page ".html"))))
7850: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
7860: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7870: 20 6c 69 6e 6b 29 29 29 0a 20 20 20 20 20 20 20 link))).
7880: 20 20 20 20 20 20 20 20 20 28 67 65 74 2d 6e 65 (get-ne
7890: 78 74 2d 6c 69 6e 6b 73 20 28 6c 61 6d 62 64 61 xt-links (lambda
78a0: 20 28 70 61 67 65 20 6c 69 6e 6b 74 72 65 65 20 (page linktree
78b0: 74 6f 74 61 6c 2d 72 75 6e 73 29 20 20 20 0a 20 total-runs) .
78c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
78d0: 20 20 20 20 20 20 20 20 20 20 20 28 6c 65 74 2a (let*
78e0: 20 28 28 6c 69 6e 6b 20 20 28 69 66 20 28 3e 20 ((link (if (>
78f0: 74 6f 74 61 6c 2d 72 75 6e 73 20 28 2b 20 31 20 total-runs (+ 1
7900: 28 2a 20 70 61 67 65 20 70 67 2d 73 69 7a 65 29 (* page pg-size)
7910: 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 )).
7920: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7930: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
7940: 73 3a 61 20 22 6e 65 78 74 26 67 74 3b 26 67 74 s:a "next>>
7950: 3b 22 20 27 68 72 65 66 20 28 63 6f 6e 63 20 20 ;" 'href (conc
7960: 6c 69 6e 6b 74 72 65 65 20 22 2f 70 61 67 65 22 linktree "/page"
7970: 20 20 28 2b 20 70 61 67 65 20 31 29 20 22 2e 68 (+ page 1) ".h
7980: 74 6d 6c 22 29 29 0a 20 20 20 20 20 20 20 20 20 tml")).
7990: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
79a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
79b0: 20 20 20 20 28 73 3a 61 20 22 22 20 27 68 72 65 (s:a "" 'hre
79c0: 66 20 28 63 6f 6e 63 20 20 6c 69 6e 6b 74 72 65 f (conc linktre
79d0: 65 20 22 2f 70 61 67 65 22 20 70 61 67 65 20 20 e "/page" page
79e0: 22 2e 68 74 6d 6c 22 29 29 29 29 29 0a 20 20 20 ".html"))))).
79f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7a00: 20 20 20 20 20 20 20 20 20 20 20 20 6c 69 6e 6b link
7a10: 29 29 29 29 0a 09 20 20 28 73 3a 6f 75 74 70 75 )))).. (s:outpu
7a20: 74 2d 6e 65 77 0a 09 20 20 20 6f 75 70 0a 09 20 t-new.. oup..
7a30: 20 20 28 73 3a 68 74 6d 6c 20 74 65 73 74 73 3a (s:html tests:
7a40: 63 73 73 2d 6a 73 63 72 69 70 74 2d 62 6c 6f 63 css-jscript-bloc
7a50: 6b 0a 09 09 20 20 20 28 73 3a 74 69 74 6c 65 20 k... (s:title
7a60: 22 53 75 6d 6d 61 72 79 20 66 6f 72 20 22 20 61 "Summary for " a
7a70: 72 65 61 2d 6e 61 6d 65 29 0a 09 09 20 20 20 28 rea-name)... (
7a80: 73 3a 62 6f 64 79 20 27 6f 6e 6c 6f 61 64 20 22 s:body 'onload "
7a90: 61 64 64 45 76 65 6e 74 73 28 29 3b 22 0a 20 20 addEvents();".
7aa0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7ab0: 20 20 20 20 20 20 20 20 28 67 65 74 2d 70 72 65 (get-pre
7ac0: 76 2d 6c 69 6e 6b 73 20 70 61 67 65 20 6c 69 6e v-links page lin
7ad0: 6b 74 72 65 65 29 0a 20 20 20 20 20 20 20 20 20 ktree).
7ae0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7af0: 20 28 67 65 74 2d 6e 65 78 74 2d 6c 69 6e 6b 73 (get-next-links
7b00: 20 70 61 67 65 20 6c 69 6e 6b 74 72 65 65 20 74 page linktree t
7b10: 6f 74 61 6c 2d 72 75 6e 73 29 0a 20 20 20 20 20 otal-runs).
7b20: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7b30: 20 20 20 20 20 20 0a 09 09 09 20 20 20 28 73 3a .... (s:
7b40: 68 31 20 22 53 75 6d 6d 61 72 79 20 66 6f 72 20 h1 "Summary for
7b50: 22 20 61 72 65 61 2d 6e 61 6d 65 29 0a 20 20 20 " area-name).
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 28 73 3a 68 33 20 22 46 (s:h3 "F
7b80: 69 6c 74 65 72 22 20 29 0a 20 20 20 20 20 20 20 ilter" ).
7b90: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7ba0: 20 20 20 20 28 73 3a 69 6e 70 75 74 20 27 74 79 (s:input 'ty
7bb0: 70 65 20 22 74 65 78 74 22 20 20 27 6e 61 6d 65 pe "text" 'name
7bc0: 20 22 74 65 73 74 6e 61 6d 65 22 20 27 69 64 20 "testname" 'id
7bd0: 22 74 65 73 74 6e 61 6d 65 22 20 27 6c 65 6e 67 "testname" 'leng
7be0: 74 68 20 22 33 30 22 20 27 6f 6e 6b 65 79 75 70 th "30" 'onkeyup
7bf0: 20 22 66 69 6c 74 65 72 73 6f 6d 65 28 29 22 29 "filtersome()")
7c00: 0a 20 20 0a 09 09 09 20 20 20 3b 3b 20 74 6f 70 . .... ;; top
7c10: 20 6c 69 73 74 0a 09 09 09 20 20 20 28 73 3a 74 list.... (s:t
7c20: 61 62 6c 65 20 27 69 64 20 22 4c 69 6e 6b 65 64 able 'id "Linked
7c30: 4c 69 73 74 31 22 20 27 62 6f 72 64 65 72 20 22 List1" 'border "
7c40: 31 22 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 1".
7c50: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
7c60: 6d 61 70 20 28 6c 61 6d 62 64 61 20 28 6b 65 79 map (lambda (key
7c70: 29 0a 09 09 09 09 20 28 6c 65 74 2a 20 28 28 72 )..... (let* ((r
7c80: 65 73 20 28 73 3a 74 72 20 27 63 6c 61 73 73 20 es (s:tr 'class
7c90: 22 73 6f 6d 65 74 68 69 6e 67 22 20 0a 09 09 09 "something" ....
7ca0: 09 20 20 28 73 3a 74 68 20 6b 65 79 20 29 0a 20 . (s:th key ).
7cb0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7cc0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7cd0: 20 20 28 6d 61 70 20 28 6c 61 6d 62 64 61 20 28 (map (lambda (
7ce0: 72 75 6e 29 0a 20 20 20 20 20 20 20 20 20 20 20 run).
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 28 73 3a 74 68 20 20 28 (s:th (
7d10: 76 65 63 74 6f 72 2d 72 65 66 20 72 75 6e 20 63 vector-ref run c
7d20: 74 72 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 tr))).
7d30: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7d40: 20 20 20 20 20 20 20 20 72 75 6e 73 29 29 29 29 runs))))
7d50: 0a 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 20 20 28 73 (s
7d70: 65 74 21 20 63 74 72 20 28 2b 20 63 74 72 20 31 et! ctr (+ ctr 1
7d80: 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 )).
7d90: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7da0: 20 20 72 65 73 29 29 0a 20 20 20 20 20 20 20 20 res)).
7db0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7dc0: 20 20 20 20 20 20 20 6b 65 79 73 29 0a 20 20 20 keys).
7dd0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7de0: 20 20 20 20 20 20 20 20 20 20 20 20 28 73 3a 74 (s:t
7df0: 72 0a 09 09 09 09 20 28 73 3a 74 68 20 22 52 75 r..... (s:th "Ru
7e00: 6e 20 4e 61 6d 65 22 29 0a 20 20 20 20 20 20 20 n Name").
7e10: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7e20: 20 20 20 20 20 20 20 20 20 20 20 28 6d 61 70 20 (map
7e30: 28 6c 61 6d 62 64 61 20 28 72 75 6e 29 0a 20 20 (lambda (run).
7e40: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7e50: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7e60: 20 28 73 3a 74 68 20 20 28 76 65 63 74 6f 72 2d (s:th (vector-
7e70: 72 65 66 20 72 75 6e 20 33 29 29 29 0a 20 20 20 ref run 3))).
7e80: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7e90: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 72 r
7ea0: 75 6e 73 29 29 0a 20 20 20 20 20 20 20 20 20 20 uns)).
7eb0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7ec0: 20 20 20 20 0a 20 20 20 20 20 20 20 20 20 20 20 .
7ed0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7ee0: 20 20 20 20 28 6d 61 70 20 28 6c 61 6d 62 64 61 (map (lambda
7ef0: 20 28 74 65 73 74 2d 6e 61 6d 65 29 0a 20 20 20 (test-name).
7f00: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7f10: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 6c (l
7f20: 65 74 2a 20 28 28 69 74 65 6d 2d 68 61 73 68 20 et* ((item-hash
7f30: 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f (hash-table-ref/
7f40: 64 65 66 61 75 6c 74 20 74 65 73 74 2d 72 75 6e default test-run
7f50: 73 2d 68 61 73 68 20 74 65 73 74 2d 6e 61 6d 65 s-hash test-name
7f60: 20 20 23 66 29 29 0a 20 20 20 20 20 20 20 20 20 #f)).
7f70: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7f80: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7f90: 28 69 74 65 6d 2d 6b 65 79 73 20 28 73 6f 72 74 (item-keys (sort
7fa0: 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 6b 65 79 (hash-table-key
7fb0: 73 20 69 74 65 6d 2d 68 61 73 68 29 20 73 74 72 s item-hash) str
7fc0: 69 6e 67 3c 3d 3f 29 29 29 20 0a 20 20 20 20 20 ing<=?))) .
7fd0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7fe0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7ff0: 20 20 20 20 20 28 6d 61 70 20 28 6c 61 6d 62 64 (map (lambd
8000: 61 20 28 69 74 65 6d 2d 6e 61 6d 65 29 20 20 0a a (item-name) .
8010: 20 20 09 09 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 28 6c 65 74 2a 20 28 28 72 65 73 20 28 73 3a (let* ((res (s:
8040: 74 72 20 20 27 63 6c 61 73 73 20 69 74 65 6d 2d tr 'class item-
8050: 6e 61 6d 65 0a 09 09 09 09 20 20 20 20 20 20 20 name.....
8060: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8070: 20 20 28 73 3a 74 64 20 20 69 74 65 6d 2d 6e 61 (s:td item-na
8080: 6d 65 20 27 63 6c 61 73 73 20 22 74 65 73 74 22 me 'class "test"
8090: 20 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
80a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
80b0: 20 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 6d (m
80d0: 61 70 20 28 6c 61 6d 62 64 61 20 28 72 75 6e 29 ap (lambda (run)
80e0: 0a 20 20 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 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8110: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8120: 28 6c 65 74 2a 20 28 28 72 75 6e 2d 74 65 73 74 (let* ((run-test
8130: 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 (hash-table-ref
8140: 2f 64 65 66 61 75 6c 74 20 69 74 65 6d 2d 68 61 /default item-ha
8150: 73 68 20 69 74 65 6d 2d 6e 61 6d 65 20 20 23 66 sh item-name #f
8160: 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 )).
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 20 20 20 20 20
8190: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
81a0: 20 20 20 20 20 20 20 20 20 28 72 75 6e 2d 69 64 (run-id
81b0: 20 28 64 62 3a 67 65 74 2d 76 61 6c 75 65 2d 62 (db:get-value-b
81c0: 79 2d 68 65 61 64 65 72 20 72 75 6e 20 68 65 61 y-header run hea
81d0: 64 65 72 20 22 69 64 22 29 29 0a 20 20 20 20 20 der "id")).
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 20
8200: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8210: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8220: 20 28 72 65 73 75 6c 74 20 28 68 61 73 68 2d 74 (result (hash-t
8230: 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 able-ref/default
8240: 20 72 75 6e 2d 74 65 73 74 20 72 75 6e 2d 69 64 run-test run-id
8250: 20 22 6e 2f 61 22 29 29 0a 20 20 20 20 20 20 20 "n/a")).
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 20 20
8280: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8290: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
82a0: 73 74 61 74 75 73 20 28 69 66 20 28 73 74 72 69 status (if (stri
82b0: 6e 67 3f 20 72 65 73 75 6c 74 29 0a 20 20 20 20 ng? result).
82c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
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: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8300: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 62 65 (be
8310: 67 69 6e 20 0a 20 20 20 20 20 20 20 20 20 20 20 gin .
8320: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
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 20 20 20 20 20 20 20 20 20 20 20
8360: 20 20 20 20 20 20 20 3b 20 28 70 72 69 6e 74 20 ; (print
8370: 22 73 74 72 69 6e 67 22 20 72 65 73 75 6c 74 29 "string" result)
8380: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
8390: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
83a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
83b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
83c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
83d0: 20 20 20 20 20 20 72 65 73 75 6c 74 29 0a 20 20 result).
83e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
83f0: 20 20 20 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 20 28 (
8430: 62 65 67 69 6e 20 0a 20 20 20 20 20 20 20 20 20 begin .
8440: 20 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: 20 20 20 20 20 20 20 20 20 20 3b 20 20 28 70 72 ; (pr
8490: 69 6e 74 20 22 6e 6f 74 20 73 74 72 69 6e 67 22 int "not string"
84a0: 20 72 65 73 75 6c 74 20 29 0a 20 20 20 20 20 20 result ).
84b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
84c0: 20 20 20 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 28 63 61 72 20 (car
8500: 72 65 73 75 6c 74 29 29 29 29 29 0a 20 20 20 20 result))))).
8510: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8520: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8530: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8540: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8550: 20 20 20 28 73 3a 74 64 20 20 73 74 61 74 75 73 (s:td status
8560: 20 27 63 6c 61 73 73 20 73 74 61 74 75 73 29 29 'class status))
8570: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
8580: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8590: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
85a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
85b0: 20 20 72 75 6e 73 29 29 29 29 0a 20 20 20 20 20 runs)))).
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 72 65 73 29 29 0a 20 20 20 20 20 20 20 res)).
8600: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8610: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8620: 20 20 20 20 20 20 20 20 20 20 20 20 69 74 65 6d item
8630: 2d 6b 65 79 73 29 29 29 0a 20 20 20 20 20 20 20 -keys))).
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 74 65 73 74 2d 6c 69 73 test-lis
8660: 74 29 29 29 29 29 0a 20 20 20 20 20 20 20 20 20 t))))).
8670: 20 28 63 6c 6f 73 65 2d 6f 75 74 70 75 74 2d 70 (close-output-p
8680: 6f 72 74 20 6f 75 70 29 0a 20 20 20 20 20 20 20 ort oup).
8690: 20 20 3b 20 28 73 65 74 21 20 70 61 67 65 20 28 ; (set! page (
86a0: 2b 20 31 20 70 61 67 65 29 29 0a 20 20 20 20 20 + 1 page)).
86b0: 20 20 20 20 20 28 69 66 20 28 3e 20 74 6f 74 61 (if (> tota
86c0: 6c 2d 72 75 6e 73 20 28 2a 20 28 2b 20 31 20 70 l-runs (* (+ 1 p
86d0: 61 67 65 29 20 70 67 2d 73 69 7a 65 29 29 0a 20 age) pg-size)).
86e0: 20 20 20 20 20 20 20 20 20 20 28 6c 6f 6f 70 20 (loop
86f0: 28 2b 20 31 20 20 70 61 67 65 29 29 29 29 29 0a (+ 1 page))))).
8700: 09 20 20 28 63 6f 6d 6d 6f 6e 3a 73 69 6d 70 6c . (common:simpl
8710: 65 2d 66 69 6c 65 2d 72 65 6c 65 61 73 65 2d 6c e-file-release-l
8720: 6f 63 6b 20 6c 6f 63 6b 66 69 6c 65 29 29 0a 09 ock lockfile))..
8730: 20 20 20 20 20 20 20 20 20 20 20 20 0a 09 23 66 ..#f
8740: 29 29 29 0a 0a 0a 0a 0a 0a 0a 28 64 65 66 69 6e ))).......(defin
8750: 65 20 28 74 65 73 74 73 3a 63 72 65 61 74 65 2d e (tests:create-
8760: 68 74 6d 6c 2d 74 72 65 65 2d 6f 6c 64 20 6f 75 html-tree-old ou
8770: 74 66 29 0a 20 20 20 28 6c 65 74 2a 20 28 28 6c tf). (let* ((l
8780: 6f 63 6b 66 69 6c 65 20 20 28 63 6f 6e 63 20 6f ockfile (conc o
8790: 75 74 66 20 22 2e 6c 6f 63 6b 22 29 29 0a 09 20 utf ".lock"))..
87a0: 28 72 75 6e 73 2d 74 6f 2d 70 72 6f 63 65 73 73 (runs-to-process
87b0: 20 27 28 29 29 29 0a 20 20 20 20 28 69 66 20 28 '())). (if (
87c0: 63 6f 6d 6d 6f 6e 3a 73 69 6d 70 6c 65 2d 66 69 common:simple-fi
87d0: 6c 65 2d 6c 6f 63 6b 20 6c 6f 63 6b 66 69 6c 65 le-lock lockfile
87e0: 29 0a 09 28 6c 65 74 2a 20 28 28 6c 69 6e 6b 74 )..(let* ((linkt
87f0: 72 65 65 20 20 28 63 6f 6d 6d 6f 6e 3a 67 65 74 ree (common:get
8800: 2d 6c 69 6e 6b 74 72 65 65 29 29 0a 09 20 20 20 -linktree))..
8810: 20 20 20 20 28 6f 75 70 20 20 20 20 20 20 20 28 (oup (
8820: 6f 70 65 6e 2d 6f 75 74 70 75 74 2d 66 69 6c 65 open-output-file
8830: 20 28 6f 72 20 6f 75 74 66 20 28 63 6f 6e 63 20 (or outf (conc
8840: 6c 69 6e 6b 74 72 65 65 20 22 2f 72 75 6e 73 2d linktree "/runs-
8850: 69 6e 64 65 78 2e 68 74 6d 6c 22 29 29 29 29 0a index.html")))).
8860: 09 20 20 20 20 20 20 20 28 61 72 65 61 2d 6e 61 . (area-na
8870: 6d 65 20 28 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 74 me (common:get-t
8880: 65 73 74 73 75 69 74 65 2d 6e 61 6d 65 29 29 0a estsuite-name)).
8890: 09 20 20 20 20 20 20 20 28 6b 65 79 73 20 20 20 . (keys
88a0: 20 20 20 28 72 6d 74 3a 67 65 74 2d 6b 65 79 73 (rmt:get-keys
88b0: 29 29 0a 09 20 20 20 20 20 20 20 28 6e 75 6d 6b )).. (numk
88c0: 65 79 73 20 20 20 28 6c 65 6e 67 74 68 20 6b 65 eys (length ke
88d0: 79 73 29 29 0a 09 20 20 20 20 20 20 20 28 72 75 ys)).. (ru
88e0: 6e 73 64 61 74 20 20 20 28 72 6d 74 3a 67 65 74 nsdat (rmt:get
88f0: 2d 72 75 6e 73 20 22 25 22 20 23 66 20 23 66 20 -runs "%" #f #f
8900: 28 6d 61 70 20 28 6c 61 6d 62 64 61 20 28 78 29 (map (lambda (x)
8910: 28 6c 69 73 74 20 78 20 22 25 22 29 29 20 6b 65 (list x "%")) ke
8920: 79 73 29 29 29 0a 09 20 20 20 20 20 20 20 28 68 ys))).. (h
8930: 65 61 64 65 72 20 20 20 20 28 76 65 63 74 6f 72 eader (vector
8940: 2d 72 65 66 20 72 75 6e 73 64 61 74 20 30 29 29 -ref runsdat 0))
8950: 0a 09 20 20 20 20 20 20 20 28 72 75 6e 73 20 20 .. (runs
8960: 20 20 20 20 28 76 65 63 74 6f 72 2d 72 65 66 20 (vector-ref
8970: 72 75 6e 73 64 61 74 20 31 29 29 0a 09 20 20 20 runsdat 1))..
8980: 20 20 20 20 28 72 75 6e 74 72 65 65 64 61 74 20 (runtreedat
8990: 28 6d 61 70 20 28 6c 61 6d 62 64 61 20 28 78 29 (map (lambda (x)
89a0: 0a 09 09 09 09 20 20 28 74 65 73 74 73 3a 72 75 ..... (tests:ru
89b0: 6e 2d 72 65 63 6f 72 64 2d 3e 74 65 73 74 2d 70 n-record->test-p
89c0: 61 74 68 20 78 20 6e 75 6d 6b 65 79 73 29 29 0a ath x numkeys)).
89d0: 09 09 09 09 72 75 6e 73 29 29 0a 09 20 20 20 20 ....runs))..
89e0: 20 20 20 28 72 75 6e 73 2d 68 74 72 65 65 20 28 (runs-htree (
89f0: 63 6f 6d 6d 6f 6e 3a 6c 69 73 74 2d 3e 68 74 72 common:list->htr
8a00: 65 65 20 72 75 6e 74 72 65 65 64 61 74 29 29 29 ee runtreedat)))
8a10: 0a 09 20 20 28 73 65 74 21 20 72 75 6e 73 2d 74 .. (set! runs-t
8a20: 6f 2d 70 72 6f 63 65 73 73 20 72 75 6e 73 29 0a o-process runs).
8a30: 09 20 20 28 73 3a 6f 75 74 70 75 74 2d 6e 65 77 . (s:output-new
8a40: 0a 09 20 20 20 6f 75 70 0a 09 20 20 20 28 73 3a .. oup.. (s:
8a50: 68 74 6d 6c 20 74 65 73 74 73 3a 63 73 73 2d 6a html tests:css-j
8a60: 73 63 72 69 70 74 2d 62 6c 6f 63 6b 0a 09 09 20 script-block...
8a70: 20 20 28 73 3a 74 69 74 6c 65 20 22 53 75 6d 6d (s:title "Summ
8a80: 61 72 79 20 66 6f 72 20 22 20 61 72 65 61 2d 6e ary for " area-n
8a90: 61 6d 65 29 0a 09 09 20 20 20 28 73 3a 62 6f 64 ame)... (s:bod
8aa0: 79 20 27 6f 6e 6c 6f 61 64 20 22 61 64 64 45 76 y 'onload "addEv
8ab0: 65 6e 74 73 28 29 3b 22 0a 09 09 09 20 20 20 28 ents();".... (
8ac0: 73 3a 68 31 20 22 53 75 6d 6d 61 72 79 20 66 6f s:h1 "Summary fo
8ad0: 72 20 22 20 61 72 65 61 2d 6e 61 6d 65 29 0a 09 r " area-name)..
8ae0: 09 09 20 20 20 3b 3b 20 74 6f 70 20 6c 69 73 74 .. ;; top list
8af0: 0a 09 09 09 20 20 20 28 73 3a 75 6c 20 27 69 64 .... (s:ul 'id
8b00: 20 22 4c 69 6e 6b 65 64 4c 69 73 74 31 22 20 27 "LinkedList1" '
8b10: 63 6c 61 73 73 20 22 4c 69 6e 6b 65 64 4c 69 73 class "LinkedLis
8b20: 74 22 0a 09 09 09 09 20 28 73 3a 6c 69 0a 09 09 t"..... (s:li...
8b30: 09 09 20 20 22 52 75 6e 73 22 0a 09 09 09 09 20 .. "Runs".....
8b40: 20 28 63 6f 6d 6d 6f 6e 3a 68 74 72 65 65 2d 3e (common:htree->
8b50: 68 74 6d 6c 20 72 75 6e 73 2d 68 74 72 65 65 0a html runs-htree.
8b60: 09 09 09 09 09 09 20 20 20 20 20 20 27 28 29 0a ...... '().
8b70: 09 09 09 09 09 09 20 20 20 20 20 20 28 6c 61 6d ...... (lam
8b80: 62 64 61 20 28 78 20 70 29 0a 09 09 09 09 09 09 bda (x p).......
8b90: 09 28 6c 65 74 2a 20 28 28 74 61 72 67 2d 70 61 .(let* ((targ-pa
8ba0: 74 68 20 28 73 74 72 69 6e 67 2d 69 6e 74 65 72 th (string-inter
8bb0: 73 70 65 72 73 65 20 70 20 22 2f 22 29 29 0a 20 sperse p "/")).
8bc0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8bd0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8be0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8bf0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 66 (f
8c00: 75 6c 6c 2d 70 61 74 68 20 28 63 6f 6e 63 20 6c ull-path (conc l
8c10: 69 6e 6b 74 72 65 65 20 22 2f 22 20 74 61 72 67 inktree "/" targ
8c20: 2d 70 61 74 68 29 29 0a 20 20 20 20 20 20 20 20 -path)).
8c30: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8c40: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8c50: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8c60: 20 20 20 20 20 20 20 28 72 75 6e 2d 6e 61 6d 65 (run-name
8c70: 20 20 28 63 61 72 20 28 72 65 76 65 72 73 65 20 (car (reverse
8c80: 70 29 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 p)))).
8c90: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8ca0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8cb0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8cc0: 28 69 66 20 28 61 6e 64 20 28 66 69 6c 65 2d 65 (if (and (file-e
8cd0: 78 69 73 74 73 3f 20 66 75 6c 6c 2d 70 61 74 68 xists? full-path
8ce0: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
8cf0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8d00: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8d10: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8d20: 20 20 20 20 20 28 64 69 72 65 63 74 6f 72 79 3f (directory?
8d30: 20 20 20 66 75 6c 6c 2d 70 61 74 68 29 0a 20 20 full-path).
8d40: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8d50: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8d60: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8d70: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8d80: 20 28 66 69 6c 65 2d 77 72 69 74 65 2d 61 63 63 (file-write-acc
8d90: 65 73 73 3f 20 66 75 6c 6c 2d 70 61 74 68 29 29 ess? full-path))
8da0: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
8db0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8dc0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8dd0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
8de0: 73 3a 61 20 72 75 6e 2d 6e 61 6d 65 20 27 68 72 s:a run-name 'hr
8df0: 65 66 20 28 63 6f 6e 63 20 74 61 72 67 2d 70 61 ef (conc targ-pa
8e00: 74 68 20 22 2f 72 75 6e 2d 73 75 6d 6d 61 72 79 th "/run-summary
8e10: 2e 68 74 6d 6c 22 29 29 0a 20 20 20 20 20 20 20 .html")).
8e20: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8e30: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8e40: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8e50: 20 20 20 20 20 20 20 28 62 65 67 69 6e 0a 20 20 (begin.
8e60: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8e70: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8e80: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8e90: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 64 (d
8ea0: 65 62 75 67 3a 70 72 69 6e 74 20 30 20 2a 64 65 ebug:print 0 *de
8eb0: 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 fault-log-port*
8ec0: 22 49 4e 46 4f 3a 20 43 61 6e 27 74 20 63 72 65 "INFO: Can't cre
8ed0: 61 74 65 20 22 20 74 61 72 67 2d 70 61 74 68 20 ate " targ-path
8ee0: 22 2f 72 75 6e 2d 73 75 6d 6d 61 72 79 2e 68 74 "/run-summary.ht
8ef0: 6d 6c 22 29 0a 20 20 20 20 20 20 20 20 20 20 20 ml").
8f00: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8f10: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8f20: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8f30: 20 20 20 20 20 28 63 6f 6e 63 20 72 75 6e 2d 6e (conc run-n
8f40: 61 6d 65 20 22 20 28 4e 6f 74 20 61 62 6c 65 20 ame " (Not able
8f50: 74 6f 20 63 72 65 61 74 65 20 73 75 6d 6d 61 72 to create summar
8f60: 79 20 61 74 20 22 20 74 61 72 67 2d 70 61 74 68 y at " targ-path
8f70: 20 22 29 22 29 29 29 29 29 29 29 29 29 29 29 0a ")"))))))))))).
8f80: 20 20 20 20 20 20 20 20 20 20 28 63 6c 6f 73 65 (close
8f90: 2d 6f 75 74 70 75 74 2d 70 6f 72 74 20 6f 75 70 -output-port oup
8fa0: 29 0a 09 20 20 28 63 6f 6d 6d 6f 6e 3a 73 69 6d ).. (common:sim
8fb0: 70 6c 65 2d 66 69 6c 65 2d 72 65 6c 65 61 73 65 ple-file-release
8fc0: 2d 6c 6f 63 6b 20 6c 6f 63 6b 66 69 6c 65 29 0a -lock lockfile).
8fd0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 0a .
8fe0: 09 20 20 28 66 6f 72 2d 65 61 63 68 0a 09 20 20 . (for-each..
8ff0: 20 28 6c 61 6d 62 64 61 20 28 72 75 6e 29 0a 09 (lambda (run)..
9000: 20 20 20 20 20 28 6c 65 74 2a 20 28 28 74 65 73 (let* ((tes
9010: 74 2d 73 75 62 70 61 74 68 20 28 74 65 73 74 73 t-subpath (tests
9020: 3a 72 75 6e 2d 72 65 63 6f 72 64 2d 3e 74 65 73 :run-record->tes
9030: 74 2d 70 61 74 68 20 72 75 6e 20 6e 75 6d 6b 65 t-path run numke
9040: 79 73 29 29 0a 09 09 20 20 20 20 28 72 75 6e 2d ys))... (run-
9050: 69 64 20 20 20 20 20 20 20 28 64 62 3a 67 65 74 id (db:get
9060: 2d 76 61 6c 75 65 2d 62 79 2d 68 65 61 64 65 72 -value-by-header
9070: 20 72 75 6e 20 68 65 61 64 65 72 20 22 69 64 22 run header "id"
9080: 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 )).
9090: 20 20 20 20 20 20 20 28 72 75 6e 2d 64 69 72 20 (run-dir
90a0: 20 20 20 20 20 28 74 65 73 74 73 3a 72 75 6e 2d (tests:run-
90b0: 72 65 63 6f 72 64 2d 3e 74 65 73 74 2d 70 61 74 record->test-pat
90c0: 68 20 72 75 6e 20 6e 75 6d 6b 65 79 73 29 29 0a h run numkeys)).
90d0: 09 09 20 20 20 20 28 74 65 73 74 2d 64 61 74 73 .. (test-dats
90e0: 20 20 20 20 28 72 6d 74 3a 67 65 74 2d 74 65 73 (rmt:get-tes
90f0: 74 73 2d 66 6f 72 2d 72 75 6e 0a 09 09 09 09 20 ts-for-run.....
9100: 20 20 72 75 6e 2d 69 64 0a 20 20 20 20 20 20 20 run-id.
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 22 25 2f 22 "%/"
9130: 20 20 20 20 20 20 20 3b 3b 20 74 65 73 74 6e 61 ;; testna
9140: 6d 65 70 61 74 74 0a 09 09 09 09 20 20 20 27 28 mepatt..... '(
9150: 29 20 20 20 20 20 20 20 20 3b 3b 20 73 74 61 74 ) ;; stat
9160: 65 73 0a 09 09 09 09 20 20 20 27 28 29 20 20 20 es..... '()
9170: 20 20 20 20 20 3b 3b 20 73 74 61 74 75 73 65 73 ;; statuses
9180: 0a 09 09 09 09 20 20 20 23 66 20 20 20 20 20 20 ..... #f
9190: 20 20 20 3b 3b 20 6f 66 66 73 65 74 0a 09 09 09 ;; offset....
91a0: 09 20 20 20 23 66 20 20 20 20 20 20 20 20 20 3b . #f ;
91b0: 3b 20 6e 75 6d 2d 74 6f 2d 67 65 74 0a 09 09 09 ; num-to-get....
91c0: 09 20 20 20 23 66 20 20 20 20 20 20 20 20 20 3b . #f ;
91d0: 3b 20 68 69 64 65 2f 6e 6f 74 2d 68 69 64 65 0a ; hide/not-hide.
91e0: 09 09 09 09 20 20 20 23 66 20 20 20 20 20 20 20 .... #f
91f0: 20 20 3b 3b 20 73 6f 72 74 2d 62 79 0a 09 09 09 ;; sort-by....
9200: 09 20 20 20 23 66 20 20 20 20 20 20 20 20 20 3b . #f ;
9210: 3b 20 73 6f 72 74 2d 6f 72 64 65 72 0a 09 09 09 ; sort-order....
9220: 09 20 20 20 23 66 20 20 20 20 20 20 20 20 20 3b . #f ;
9230: 3b 20 27 73 68 6f 72 74 6c 69 73 74 20 20 20 20 ; 'shortlist
9240: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9250: 20 20 20 20 20 20 20 3b 3b 20 71 72 79 74 79 70 ;; qrytyp
9260: 65 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 e.
9270: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9280: 20 20 20 20 20 30 20 20 20 20 20 20 20 20 20 3b 0 ;
9290: 3b 20 6c 61 73 74 20 75 70 64 61 74 65 0a 09 09 ; last update...
92a0: 09 09 20 20 20 23 66 29 29 0a 20 20 20 20 20 20 .. #f)).
92b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 74 (t
92c0: 65 73 74 73 2d 74 72 65 65 2d 64 61 74 20 28 6d ests-tree-dat (m
92d0: 61 70 20 28 6c 61 6d 62 64 61 20 28 74 65 73 74 ap (lambda (test
92e0: 2d 64 61 74 29 0a 20 20 20 20 20 20 20 20 20 20 -dat).
92f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9300: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 3b ;
9310: 3b 20 28 74 65 73 74 73 3a 72 75 6e 2d 72 65 63 ; (tests:run-rec
9320: 6f 72 64 2d 3e 74 65 73 74 2d 70 61 74 68 20 78 ord->test-path x
9330: 20 6e 75 6d 6b 65 79 73 29 29 0a 20 20 20 20 20 numkeys)).
9340: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9350: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9360: 20 20 20 20 28 6c 65 74 2a 20 28 28 74 65 73 74 (let* ((test
9370: 2d 6e 61 6d 65 20 20 28 64 62 3a 74 65 73 74 2d -name (db:test-
9380: 67 65 74 2d 74 65 73 74 6e 61 6d 65 20 74 65 73 get-testname tes
9390: 74 2d 64 61 74 29 29 0a 20 20 20 20 20 20 20 20 t-dat)).
93a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
93b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
93c0: 20 20 20 20 20 20 20 20 28 69 74 65 6d 2d 70 61 (item-pa
93d0: 74 68 20 20 28 64 62 3a 74 65 73 74 2d 67 65 74 th (db:test-get
93e0: 2d 69 74 65 6d 2d 70 61 74 68 20 74 65 73 74 2d -item-path test-
93f0: 64 61 74 29 29 0a 20 20 20 20 20 20 20 20 20 20 dat)).
9400: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9410: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9420: 20 20 20 20 20 20 28 66 75 6c 6c 2d 6e 61 6d 65 (full-name
9430: 20 20 28 64 62 3a 74 65 73 74 2d 6d 61 6b 65 2d (db:test-make-
9440: 66 75 6c 6c 2d 6e 61 6d 65 20 74 65 73 74 2d 6e full-name test-n
9450: 61 6d 65 20 69 74 65 6d 2d 70 61 74 68 29 29 0a ame item-path)).
9460: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
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: 28 70 61 74 68 2d 70 61 72 74 73 20 28 73 74 72 (path-parts (str
94a0: 69 6e 67 2d 73 70 6c 69 74 20 66 75 6c 6c 2d 6e ing-split full-n
94b0: 61 6d 65 29 29 29 0a 20 20 20 20 20 20 20 20 20 ame))).
94c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
94d0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
94e0: 20 20 70 61 74 68 2d 70 61 72 74 73 29 29 0a 20 path-parts)).
94f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9500: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9510: 20 20 20 20 20 20 74 65 73 74 2d 64 61 74 73 29 test-dats)
9520: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
9530: 20 20 20 20 20 20 28 74 65 73 74 73 2d 68 74 72 (tests-htr
9540: 65 65 20 28 63 6f 6d 6d 6f 6e 3a 6c 69 73 74 2d ee (common:list-
9550: 3e 68 74 72 65 65 20 74 65 73 74 73 2d 74 72 65 >htree tests-tre
9560: 65 2d 64 61 74 29 29 0a 20 20 20 20 20 20 20 20 e-dat)).
9570: 20 20 20 20 20 20 20 20 20 20 20 20 28 68 74 6d (htm
9580: 6c 2d 64 69 72 20 20 20 20 28 63 6f 6e 63 20 6c l-dir (conc l
9590: 69 6e 6b 74 72 65 65 20 22 2f 22 20 28 73 74 72 inktree "/" (str
95a0: 69 6e 67 2d 69 6e 74 65 72 73 70 65 72 73 65 20 ing-intersperse
95b0: 72 75 6e 2d 64 69 72 20 22 2f 22 29 29 29 0a 20 run-dir "/"))).
95c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
95d0: 20 20 20 28 68 74 6d 6c 2d 70 61 74 68 20 20 20 (html-path
95e0: 28 63 6f 6e 63 20 68 74 6d 6c 2d 64 69 72 20 22 (conc html-dir "
95f0: 2f 72 75 6e 2d 73 75 6d 6d 61 72 79 2e 68 74 6d /run-summary.htm
9600: 6c 22 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 l")).
9610: 20 20 20 20 20 20 20 20 20 28 6f 75 70 20 20 20 (oup
9620: 20 20 20 20 20 20 28 69 66 20 28 61 6e 64 20 28 (if (and (
9630: 66 69 6c 65 2d 65 78 69 73 74 73 3f 20 68 74 6d file-exists? htm
9640: 6c 2d 64 69 72 29 0a 20 20 20 20 20 20 20 20 20 l-dir).
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 28 64 69 72 65 63 74 6f 72 79 3f 20 20 20 68 (directory? h
9680: 74 6d 6c 2d 64 69 72 29 0a 20 20 20 20 20 20 20 tml-dir).
9690: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
96a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
96b0: 20 20 20 28 66 69 6c 65 2d 77 72 69 74 65 2d 61 (file-write-a
96c0: 63 63 65 73 73 3f 20 68 74 6d 6c 2d 64 69 72 29 ccess? html-dir)
96d0: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
96e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
96f0: 20 20 20 20 20 20 20 28 6f 70 65 6e 2d 6f 75 74 (open-out
9700: 70 75 74 2d 66 69 6c 65 20 20 68 74 6d 6c 2d 70 put-file html-p
9710: 61 74 68 29 0a 20 20 20 20 20 20 20 20 20 20 20 ath).
9720: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9730: 20 20 20 20 20 20 20 20 20 20 23 66 29 29 29 0a #f))).
9740: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 3b ;
9750: 3b 20 28 70 72 69 6e 74 20 22 72 75 6e 2d 64 69 ; (print "run-di
9760: 72 3a 20 22 20 72 75 6e 2d 64 69 72 20 22 2c 20 r: " run-dir ",
9770: 74 65 73 74 73 2d 74 72 65 65 2d 64 61 74 3a 20 tests-tree-dat:
9780: 22 20 74 65 73 74 73 2d 74 72 65 65 2d 64 61 74 " tests-tree-dat
9790: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
97a0: 20 28 69 66 20 6f 75 70 0a 20 20 20 20 20 20 20 (if oup.
97b0: 20 20 20 20 20 20 20 20 20 20 20 20 28 62 65 67 (beg
97c0: 69 6e 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 in.
97d0: 20 20 20 20 20 20 20 20 28 73 3a 6f 75 74 70 75 (s:outpu
97e0: 74 2d 6e 65 77 0a 20 20 20 20 20 20 20 20 20 20 t-new.
97f0: 20 20 20 20 20 20 20 20 20 20 20 20 6f 75 70 0a oup.
9800: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9810: 20 20 20 20 20 20 28 73 3a 68 74 6d 6c 20 74 65 (s:html te
9820: 73 74 73 3a 63 73 73 2d 6a 73 63 72 69 70 74 2d sts:css-jscript-
9830: 62 6c 6f 63 6b 0a 20 20 20 20 20 20 20 20 20 20 block.
9840: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9850: 20 20 20 20 28 73 3a 74 69 74 6c 65 20 22 53 75 (s:title "Su
9860: 6d 6d 61 72 79 20 66 6f 72 20 22 20 61 72 65 61 mmary for " area
9870: 2d 6e 61 6d 65 29 0a 20 20 20 20 20 20 20 20 20 -name).
9880: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9890: 20 20 20 20 20 28 73 3a 62 6f 64 79 20 27 6f 6e (s:body 'on
98a0: 6c 6f 61 64 20 22 61 64 64 45 76 65 6e 74 73 28 load "addEvents(
98b0: 29 3b 22 0a 20 20 20 20 20 20 20 20 20 20 20 20 );".
98c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
98d0: 20 20 20 20 20 20 20 20 20 20 28 73 3a 68 31 20 (s:h1
98e0: 22 53 75 6d 6d 61 72 79 20 66 6f 72 20 22 20 28 "Summary for " (
98f0: 73 74 72 69 6e 67 2d 69 6e 74 65 72 73 70 65 72 string-intersper
9900: 73 65 20 72 75 6e 2d 64 69 72 20 22 2f 22 29 29 se run-dir "/"))
9910: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
9920: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9930: 20 20 20 20 20 20 20 3b 3b 20 74 6f 70 20 6c 69 ;; top li
9940: 73 74 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 st.
9950: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9960: 20 20 20 20 20 20 20 20 20 28 73 3a 75 6c 20 27 (s:ul '
9970: 69 64 20 22 4c 69 6e 6b 65 64 4c 69 73 74 31 22 id "LinkedList1"
9980: 20 27 63 6c 61 73 73 20 22 4c 69 6e 6b 65 64 4c 'class "LinkedL
9990: 69 73 74 22 0a 20 20 20 20 20 20 20 20 20 20 20 ist".
99a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
99b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
99c0: 20 28 73 3a 6c 69 0a 20 20 20 20 20 20 20 20 20 (s:li.
99d0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
99e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
99f0: 20 20 20 20 22 54 65 73 74 73 22 0a 20 20 20 20 "Tests".
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 20 20 20 20 20 20 20 20 28 63 6f 6d 6d 6f 6e (common
9a30: 3a 68 74 72 65 65 2d 3e 68 74 6d 6c 20 74 65 73 :htree->html tes
9a40: 74 73 2d 68 74 72 65 65 0a 20 20 20 20 20 20 20 ts-htree.
9a50: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9a60: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9a70: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9a80: 20 20 20 20 20 20 20 20 20 20 27 28 29 0a 20 20 '().
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 20 20 20 20 20 20 20 20
9ab0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9ac0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
9ad0: 6c 61 6d 62 64 61 20 28 78 20 70 29 0a 20 20 20 lambda (x p).
9ae0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9af0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9b00: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9b10: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9b20: 28 6c 65 74 2a 20 28 28 74 61 72 67 2d 70 61 74 (let* ((targ-pat
9b30: 68 20 28 73 74 72 69 6e 67 2d 69 6e 74 65 72 73 h (string-inters
9b40: 70 65 72 73 65 20 70 20 22 2f 22 29 29 0a 20 20 perse p "/")).
9b50: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9b60: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9b70: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9b80: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9b90: 20 20 20 20 20 20 20 20 28 74 65 73 74 2d 6e 61 (test-na
9ba0: 6d 65 20 28 63 61 72 20 70 29 29 0a 20 20 20 20 me (car p)).
9bb0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9bc0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9bd0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9be0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9bf0: 20 20 20 20 20 20 28 69 74 65 6d 2d 70 61 74 68 (item-path
9c00: 20 3b 3b 20 28 69 66 20 28 3e 20 28 6c 65 6e 67 ;; (if (> (leng
9c10: 74 68 20 70 29 20 32 29 20 3b 3b 20 74 65 73 74 th p) 2) ;; test
9c20: 2d 6e 61 6d 65 20 2b 20 72 75 6e 2d 6e 61 6d 65 -name + run-name
9c30: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
9c40: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9c50: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9c60: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9c70: 20 20 20 20 20 20 20 20 20 20 20 20 28 73 74 72 (str
9c80: 69 6e 67 2d 69 6e 74 65 72 73 70 65 72 73 65 20 ing-intersperse
9c90: 70 20 22 2f 22 29 29 0a 20 20 20 20 20 20 20 20 p "/")).
9ca0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9cb0: 20 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 20 20 20 20 20 20 20 20 20
9ce0: 20 20 28 66 75 6c 6c 2d 74 61 72 67 20 28 63 6f (full-targ (co
9cf0: 6e 63 20 68 74 6d 6c 2d 64 69 72 20 22 2f 22 20 nc html-dir "/"
9d00: 74 61 72 67 2d 70 61 74 68 29 29 0a 20 20 20 20 targ-path)).
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 20
9d30: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9d40: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9d50: 20 20 20 20 20 20 28 73 74 64 2d 66 69 6c 65 20 (std-file
9d60: 20 28 63 6f 6e 63 20 66 75 6c 6c 2d 74 61 72 67 (conc full-targ
9d70: 20 22 2f 74 65 73 74 2d 73 75 6d 6d 61 72 79 2e "/test-summary.
9d80: 68 74 6d 6c 22 29 29 0a 20 20 20 20 20 20 20 20 html")).
9d90: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9da0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9db0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9dc0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9dd0: 20 20 28 61 6c 74 2d 66 69 6c 65 20 20 28 63 6f (alt-file (co
9de0: 6e 63 20 66 75 6c 6c 2d 74 61 72 67 20 22 2f 6d nc full-targ "/m
9df0: 65 67 61 74 65 73 74 2d 72 6f 6c 6c 75 70 2d 22 egatest-rollup-"
9e00: 20 74 65 73 74 2d 6e 61 6d 65 20 22 2e 68 74 6d test-name ".htm
9e10: 6c 22 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 l")).
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 20 20 20
9e40: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9e50: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
9e60: 68 74 6d 6c 2d 66 69 6c 65 20 28 69 66 20 28 66 html-file (if (f
9e70: 69 6c 65 2d 65 78 69 73 74 73 3f 20 61 6c 74 2d ile-exists? alt-
9e80: 66 69 6c 65 29 0a 20 20 20 20 20 20 20 20 20 20 file).
9e90: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9ea0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9eb0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
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 61 a
9ee0: 6c 74 2d 66 69 6c 65 0a 20 20 20 20 20 20 20 20 lt-file.
9ef0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9f00: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9f10: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
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 73 74 64 2d 66 69 6c 65 29 29 0a 20 20 20 20 std-file)).
9f50: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9f60: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9f70: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9f80: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9f90: 20 20 20 20 20 20 28 72 75 6e 2d 6e 61 6d 65 20 (run-name
9fa0: 20 28 63 61 72 20 28 72 65 76 65 72 73 65 20 70 (car (reverse p
9fb0: 29 29 29 29 0a 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 20 20 20 20 20 20
9ff0: 20 20 20 20 20 20 20 20 20 20 28 69 66 20 28 61 (if (a
a000: 6e 64 20 28 6e 6f 74 20 28 66 69 6c 65 2d 65 78 nd (not (file-ex
a010: 69 73 74 73 3f 20 66 75 6c 6c 2d 74 61 72 67 29 ists? full-targ)
a020: 29 0a 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: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
a060: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
a070: 28 64 69 72 65 63 74 6f 72 79 3f 20 66 75 6c 6c (directory? full
a080: 2d 74 61 72 67 29 0a 20 20 20 20 20 20 20 20 20 -targ).
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 20 20 20 20 20 20 20 20 20 20 20 20
a0d0: 20 20 20 20 20 28 66 69 6c 65 2d 77 72 69 74 65 (file-write
a0e0: 2d 61 63 63 65 73 73 3f 20 66 75 6c 6c 2d 74 61 -access? full-ta
a0f0: 72 67 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 rg)).
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 28 74 (t
a140: 65 73 74 73 3a 73 75 6d 6d 61 72 69 7a 65 2d 74 ests:summarize-t
a150: 65 73 74 20 0a 20 20 20 20 20 20 20 20 20 20 20 est .
a160: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
a170: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
a180: 20 20 20 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 72 r
a1a0: 75 6e 2d 69 64 20 0a 20 20 20 20 20 20 20 20 20 un-id .
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 20 20 20
a1d0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
a1e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
a1f0: 20 28 72 6d 74 3a 67 65 74 2d 74 65 73 74 2d 69 (rmt:get-test-i
a200: 64 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 6e 61 d run-id test-na
a210: 6d 65 20 69 74 65 6d 2d 70 61 74 68 29 29 29 0a me item-path))).
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 20 20 20 20 20 20 20 20 20 20 20 20
a260: 20 20 20 20 20 28 69 66 20 28 66 69 6c 65 2d 65 (if (file-e
a270: 78 69 73 74 73 3f 20 66 75 6c 6c 2d 74 61 72 67 xists? full-targ
a280: 29 0a 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 20 20 20 20 20 20 20 20 20 20
a2c0: 20 20 20 20 20 20 20 20 20 20 20 28 73 3a 61 20 (s:a
a2d0: 72 75 6e 2d 6e 61 6d 65 20 27 68 72 65 66 20 68 run-name 'href h
a2e0: 74 6d 6c 2d 66 69 6c 65 29 0a 20 20 20 20 20 20 tml-file).
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 20 20 20 20 20
a310: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
a320: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
a330: 20 20 20 28 62 65 67 69 6e 0a 20 20 20 20 20 20 (begin.
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 20
a370: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
a380: 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e (debug:prin
a390: 74 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 t 0 *default-log
a3a0: 2d 70 6f 72 74 2a 20 22 45 52 52 4f 52 3a 20 63 -port* "ERROR: c
a3b0: 61 6e 27 74 20 61 63 63 65 73 73 20 22 20 66 75 an't access " fu
a3c0: 6c 6c 2d 74 61 72 67 29 0a 20 20 20 20 20 20 20 ll-targ).
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 20 20 20 20
a3f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
a400: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
a410: 20 20 20 20 28 63 6f 6e 63 20 22 4e 6f 20 73 75 (conc "No su
a420: 6d 6d 61 72 79 20 66 6f 72 20 22 20 72 75 6e 2d mmary for " run-
a430: 6e 61 6d 65 29 29 29 29 29 0a 20 20 20 20 20 20 name))))).
a440: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
a450: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
a460: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
a470: 20 20 20 20 20 20 20 20 20 20 20 29 29 29 29 29 )))))
a480: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
a490: 20 20 20 20 20 20 20 28 63 6c 6f 73 65 2d 6f 75 (close-ou
a4a0: 74 70 75 74 2d 70 6f 72 74 20 6f 75 70 29 29 29 tput-port oup)))
a4b0: 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 72 75 )). ru
a4c0: 6e 73 29 0a 20 20 20 20 20 20 20 20 20 20 23 74 ns). #t
a4d0: 29 0a 09 23 66 29 29 29 0a 0a 0a 0a 0a 0a 0a 0a )..#f)))........
a4e0: 3b 3b 20 43 48 45 43 4b 20 2d 20 57 41 53 20 54 ;; CHECK - WAS T
a4f0: 48 49 53 20 41 44 44 45 44 20 4f 52 20 52 45 4d HIS ADDED OR REM
a500: 4f 56 45 44 3f 20 4d 41 4e 55 41 4c 20 4d 45 52 OVED? MANUAL MER
a510: 47 45 20 57 49 54 48 20 41 50 49 20 53 54 55 46 GE WITH API STUF
a520: 46 21 21 21 0a 3b 3b 0a 3b 3b 20 67 65 74 20 61 F!!!.;;.;; get a
a530: 20 70 72 65 74 74 79 20 74 61 62 6c 65 20 74 6f pretty table to
a540: 20 73 75 6d 6d 61 72 69 7a 65 20 73 74 65 70 73 summarize steps
a550: 0a 3b 3b 0a 3b 3b 20 28 64 65 66 69 6e 65 20 28 .;;.;; (define (
a560: 64 63 6f 6d 6d 6f 6e 3a 70 72 6f 63 65 73 73 2d dcommon:process-
a570: 73 74 65 70 73 2d 74 61 62 6c 65 20 73 74 65 70 steps-table step
a580: 73 29 3b 3b 20 64 62 20 74 65 73 74 2d 69 64 20 s);; db test-id
a590: 23 21 6b 65 79 20 28 77 6f 72 6b 2d 61 72 65 61 #!key (work-area
a5a0: 20 23 66 29 29 0a 28 64 65 66 69 6e 65 20 28 74 #f)).(define (t
a5b0: 65 73 74 73 3a 70 72 6f 63 65 73 73 2d 73 74 65 ests:process-ste
a5c0: 70 73 2d 74 61 62 6c 65 20 73 74 65 70 73 29 3b ps-table steps);
a5d0: 3b 20 64 62 20 74 65 73 74 2d 69 64 20 23 21 6b ; db test-id #!k
a5e0: 65 79 20 28 77 6f 72 6b 2d 61 72 65 61 20 23 66 ey (work-area #f
a5f0: 29 29 0a 3b 3b 20 20 28 6c 65 74 20 28 28 73 74 )).;; (let ((st
a600: 65 70 73 20 20 20 28 64 62 3a 67 65 74 2d 73 74 eps (db:get-st
a610: 65 70 73 2d 66 6f 72 2d 74 65 73 74 20 64 62 20 eps-for-test db
a620: 74 65 73 74 2d 69 64 20 77 6f 72 6b 2d 61 72 65 test-id work-are
a630: 61 3a 20 77 6f 72 6b 2d 61 72 65 61 29 29 29 0a a: work-area))).
a640: 20 20 20 20 3b 3b 20 6f 72 67 61 6e 69 73 65 20 ;; organise
a650: 74 68 65 20 73 74 65 70 73 20 66 6f 72 20 62 65 the steps for be
a660: 74 74 65 72 20 72 65 61 64 61 62 69 6c 69 74 79 tter readability
a670: 0a 20 20 20 20 28 6c 65 74 20 28 28 72 65 73 20 . (let ((res
a680: 28 6d 61 6b 65 2d 68 61 73 68 2d 74 61 62 6c 65 (make-hash-table
a690: 29 29 29 0a 20 20 20 20 20 20 28 66 6f 72 2d 65 ))). (for-e
a6a0: 61 63 68 20 0a 20 20 20 20 20 20 20 28 6c 61 6d ach . (lam
a6b0: 62 64 61 20 28 73 74 65 70 29 0a 09 20 28 64 65 bda (step).. (de
a6c0: 62 75 67 3a 70 72 69 6e 74 20 36 20 2a 64 65 66 bug:print 6 *def
a6d0: 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 ault-log-port* "
a6e0: 73 74 65 70 3d 22 20 73 74 65 70 29 0a 09 20 28 step=" step).. (
a6f0: 6c 65 74 20 28 28 72 65 63 6f 72 64 20 28 68 61 let ((record (ha
a700: 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 sh-table-ref/def
a710: 61 75 6c 74 20 0a 09 09 09 72 65 73 20 0a 09 09 ault ....res ...
a720: 09 28 74 64 62 3a 73 74 65 70 2d 67 65 74 2d 73 .(tdb:step-get-s
a730: 74 65 70 6e 61 6d 65 20 73 74 65 70 29 0a 09 09 tepname step)...
a740: 09 3b 3b 20 20 20 20 20 20 20 20 20 20 20 30 20 .;; 0
a750: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
a760: 20 20 20 20 20 31 20 20 20 20 32 20 20 20 20 33 1 2 3
a770: 20 20 20 20 20 20 20 34 20 20 20 20 20 20 20 20 4
a780: 20 35 20 20 20 20 20 20 20 36 20 20 20 20 20 20 5 6
a790: 20 37 0a 09 09 09 3b 3b 20 20 20 20 20 20 20 20 7....;;
a7a0: 73 74 65 70 6e 61 6d 65 20 20 20 20 20 20 20 20 stepname
a7b0: 20 20 20 20 20 20 20 20 73 74 61 72 74 20 65 6e start en
a7c0: 64 20 73 74 61 74 75 73 20 44 75 72 61 74 69 6f d status Duratio
a7d0: 6e 20 20 4c 6f 67 66 69 6c 65 20 43 6f 6d 6d 65 n Logfile Comme
a7e0: 6e 74 20 20 66 69 72 73 74 2d 69 64 0a 09 09 09 nt first-id....
a7f0: 28 76 65 63 74 6f 72 20 28 74 64 62 3a 73 74 65 (vector (tdb:ste
a800: 70 2d 67 65 74 2d 73 74 65 70 6e 61 6d 65 20 73 p-get-stepname s
a810: 74 65 70 29 20 22 22 20 20 20 22 22 20 22 22 20 tep) "" "" ""
a820: 20 20 20 20 22 22 20 20 20 20 20 20 20 20 22 22 "" ""
a830: 20 20 20 20 20 22 22 20 20 20 20 20 20 20 23 66 "" #f
a840: 29 29 29 29 0a 09 20 20 20 28 64 65 62 75 67 3a )))).. (debug:
a850: 70 72 69 6e 74 20 36 20 2a 64 65 66 61 75 6c 74 print 6 *default
a860: 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 72 65 63 6f -log-port* "reco
a870: 72 64 28 62 65 66 6f 72 65 29 20 3d 20 22 20 72 rd(before) = " r
a880: 65 63 6f 72 64 20 0a 09 09 09 22 5c 6e 69 64 3a ecord ...."\nid:
a890: 20 20 20 20 20 20 20 22 20 28 74 64 62 3a 73 74 " (tdb:st
a8a0: 65 70 2d 67 65 74 2d 69 64 20 73 74 65 70 29 0a ep-get-id step).
a8b0: 09 09 09 22 5c 6e 73 74 65 70 6e 61 6d 65 3a 20 ..."\nstepname:
a8c0: 22 20 28 74 64 62 3a 73 74 65 70 2d 67 65 74 2d " (tdb:step-get-
a8d0: 73 74 65 70 6e 61 6d 65 20 73 74 65 70 29 0a 09 stepname step)..
a8e0: 09 09 22 5c 6e 73 74 61 74 65 3a 20 20 20 20 22 .."\nstate: "
a8f0: 20 28 74 64 62 3a 73 74 65 70 2d 67 65 74 2d 73 (tdb:step-get-s
a900: 74 61 74 65 20 73 74 65 70 29 0a 09 09 09 22 5c tate step)...."\
a910: 6e 73 74 61 74 75 73 3a 20 20 20 22 20 28 74 64 nstatus: " (td
a920: 62 3a 73 74 65 70 2d 67 65 74 2d 73 74 61 74 75 b:step-get-statu
a930: 73 20 73 74 65 70 29 0a 09 09 09 22 5c 6e 74 69 s step)...."\nti
a940: 6d 65 3a 20 20 20 20 20 22 20 28 74 64 62 3a 73 me: " (tdb:s
a950: 74 65 70 2d 67 65 74 2d 65 76 65 6e 74 5f 74 69 tep-get-event_ti
a960: 6d 65 20 73 74 65 70 29 29 0a 09 20 20 20 28 69 me step)).. (i
a970: 66 20 28 6e 6f 74 20 28 76 65 63 74 6f 72 2d 72 f (not (vector-r
a980: 65 66 20 72 65 63 6f 72 64 20 37 29 29 28 76 65 ef record 7))(ve
a990: 63 74 6f 72 2d 73 65 74 21 20 72 65 63 6f 72 64 ctor-set! record
a9a0: 20 37 20 28 74 64 62 3a 73 74 65 70 2d 67 65 74 7 (tdb:step-get
a9b0: 2d 69 64 20 73 74 65 70 29 29 29 20 3b 3b 20 64 -id step))) ;; d
a9c0: 6f 20 6e 6f 74 20 63 6c 6f 62 62 65 72 20 74 68 o not clobber th
a9d0: 65 20 69 64 20 69 66 20 70 72 65 76 69 6f 75 73 e id if previous
a9e0: 6c 79 20 73 65 74 0a 09 20 20 20 28 63 61 73 65 ly set.. (case
a9f0: 20 28 73 74 72 69 6e 67 2d 3e 73 79 6d 62 6f 6c (string->symbol
aa00: 20 28 74 64 62 3a 73 74 65 70 2d 67 65 74 2d 73 (tdb:step-get-s
aa10: 74 61 74 65 20 73 74 65 70 29 29 0a 09 20 20 20 tate step))..
aa20: 20 20 28 28 73 74 61 72 74 29 28 76 65 63 74 6f ((start)(vecto
aa30: 72 2d 73 65 74 21 20 72 65 63 6f 72 64 20 31 20 r-set! record 1
aa40: 28 74 64 62 3a 73 74 65 70 2d 67 65 74 2d 65 76 (tdb:step-get-ev
aa50: 65 6e 74 5f 74 69 6d 65 20 73 74 65 70 29 29 0a ent_time step)).
aa60: 09 20 20 20 20 20 20 28 76 65 63 74 6f 72 2d 73 . (vector-s
aa70: 65 74 21 20 72 65 63 6f 72 64 20 33 20 28 69 66 et! record 3 (if
aa80: 20 28 65 71 75 61 6c 3f 20 28 76 65 63 74 6f 72 (equal? (vector
aa90: 2d 72 65 66 20 72 65 63 6f 72 64 20 33 29 20 22 -ref record 3) "
aaa0: 22 29 0a 09 09 09 09 09 28 74 64 62 3a 73 74 65 ")......(tdb:ste
aab0: 70 2d 67 65 74 2d 73 74 61 74 75 73 20 73 74 65 p-get-status ste
aac0: 70 29 29 29 0a 09 20 20 20 20 20 20 28 69 66 20 p))).. (if
aad0: 28 3e 20 28 73 74 72 69 6e 67 2d 6c 65 6e 67 74 (> (string-lengt
aae0: 68 20 28 74 64 62 3a 73 74 65 70 2d 67 65 74 2d h (tdb:step-get-
aaf0: 6c 6f 67 66 69 6c 65 20 73 74 65 70 29 29 0a 09 logfile step))..
ab00: 09 20 20 20 20 20 30 29 0a 09 09 20 20 28 76 65 . 0)... (ve
ab10: 63 74 6f 72 2d 73 65 74 21 20 72 65 63 6f 72 64 ctor-set! record
ab20: 20 35 20 28 74 64 62 3a 73 74 65 70 2d 67 65 74 5 (tdb:step-get
ab30: 2d 6c 6f 67 66 69 6c 65 20 73 74 65 70 29 29 29 -logfile step)))
ab40: 29 0a 09 20 20 20 20 20 28 28 65 6e 64 29 20 20 ).. ((end)
ab50: 0a 09 20 20 20 20 20 20 28 76 65 63 74 6f 72 2d .. (vector-
ab60: 73 65 74 21 20 72 65 63 6f 72 64 20 32 20 28 61 set! record 2 (a
ab70: 6e 79 2d 3e 6e 75 6d 62 65 72 20 28 74 64 62 3a ny->number (tdb:
ab80: 73 74 65 70 2d 67 65 74 2d 65 76 65 6e 74 5f 74 step-get-event_t
ab90: 69 6d 65 20 73 74 65 70 29 29 29 0a 09 20 20 20 ime step)))..
aba0: 20 20 20 28 76 65 63 74 6f 72 2d 73 65 74 21 20 (vector-set!
abb0: 72 65 63 6f 72 64 20 33 20 28 74 64 62 3a 73 74 record 3 (tdb:st
abc0: 65 70 2d 67 65 74 2d 73 74 61 74 75 73 20 73 74 ep-get-status st
abd0: 65 70 29 29 0a 09 20 20 20 20 20 20 28 76 65 63 ep)).. (vec
abe0: 74 6f 72 2d 73 65 74 21 20 72 65 63 6f 72 64 20 tor-set! record
abf0: 34 20 28 6c 65 74 20 28 28 73 74 61 72 74 74 20 4 (let ((startt
ac00: 28 61 6e 79 2d 3e 6e 75 6d 62 65 72 20 28 76 65 (any->number (ve
ac10: 63 74 6f 72 2d 72 65 66 20 72 65 63 6f 72 64 20 ctor-ref record
ac20: 31 29 29 29 0a 09 09 09 09 09 20 20 28 65 6e 64 1)))...... (end
ac30: 74 20 20 20 28 61 6e 79 2d 3e 6e 75 6d 62 65 72 t (any->number
ac40: 20 28 76 65 63 74 6f 72 2d 72 65 66 20 72 65 63 (vector-ref rec
ac50: 6f 72 64 20 32 29 29 29 29 0a 09 09 09 09 20 20 ord 2)))).....
ac60: 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 (debug:print
ac70: 20 34 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 4 *default-log-
ac80: 70 6f 72 74 2a 20 22 72 65 63 6f 72 64 5b 31 5d port* "record[1]
ac90: 3d 22 20 28 76 65 63 74 6f 72 2d 72 65 66 20 72 =" (vector-ref r
aca0: 65 63 6f 72 64 20 31 29 20 0a 09 09 09 09 09 09 ecord 1) .......
acb0: 20 20 20 22 2c 20 73 74 61 72 74 74 3d 22 20 73 ", startt=" s
acc0: 74 61 72 74 74 20 22 2c 20 65 6e 64 74 3d 22 20 tartt ", endt="
acd0: 65 6e 64 74 0a 09 09 09 09 09 09 20 20 20 22 2c endt....... ",
ace0: 20 67 65 74 2d 73 74 61 74 75 73 3a 20 22 20 28 get-status: " (
acf0: 74 64 62 3a 73 74 65 70 2d 67 65 74 2d 73 74 61 tdb:step-get-sta
ad00: 74 75 73 20 73 74 65 70 29 29 0a 09 09 09 09 20 tus step)).....
ad10: 20 20 20 20 20 28 69 66 20 28 61 6e 64 20 28 6e (if (and (n
ad20: 75 6d 62 65 72 3f 20 73 74 61 72 74 74 29 28 6e umber? startt)(n
ad30: 75 6d 62 65 72 3f 20 65 6e 64 74 29 29 0a 09 09 umber? endt))...
ad40: 09 09 09 20 20 28 73 65 63 6f 6e 64 73 2d 3e 68 ... (seconds->h
ad50: 72 2d 6d 69 6e 2d 73 65 63 20 28 2d 20 65 6e 64 r-min-sec (- end
ad60: 74 20 73 74 61 72 74 74 29 29 20 22 2d 31 22 29 t startt)) "-1")
ad70: 29 29 0a 09 20 20 20 20 20 20 28 69 66 20 28 3e )).. (if (>
ad80: 20 28 73 74 72 69 6e 67 2d 6c 65 6e 67 74 68 20 (string-length
ad90: 28 74 64 62 3a 73 74 65 70 2d 67 65 74 2d 6c 6f (tdb:step-get-lo
ada0: 67 66 69 6c 65 20 73 74 65 70 29 29 0a 09 09 20 gfile step))...
adb0: 20 20 20 20 30 29 0a 09 09 20 20 28 76 65 63 74 0)... (vect
adc0: 6f 72 2d 73 65 74 21 20 72 65 63 6f 72 64 20 35 or-set! record 5
add0: 20 28 74 64 62 3a 73 74 65 70 2d 67 65 74 2d 6c (tdb:step-get-l
ade0: 6f 67 66 69 6c 65 20 73 74 65 70 29 29 29 0a 09 ogfile step)))..
adf0: 20 20 20 20 20 20 28 69 66 20 28 3e 20 28 73 74 (if (> (st
ae00: 72 69 6e 67 2d 6c 65 6e 67 74 68 20 28 74 64 62 ring-length (tdb
ae10: 3a 73 74 65 70 2d 67 65 74 2d 63 6f 6d 6d 65 6e :step-get-commen
ae20: 74 20 73 74 65 70 29 29 0a 09 09 20 20 20 20 20 t step))...
ae30: 30 29 0a 09 09 20 20 28 76 65 63 74 6f 72 2d 73 0)... (vector-s
ae40: 65 74 21 20 72 65 63 6f 72 64 20 36 20 28 74 64 et! record 6 (td
ae50: 62 3a 73 74 65 70 2d 67 65 74 2d 63 6f 6d 6d 65 b:step-get-comme
ae60: 6e 74 20 73 74 65 70 29 29 29 29 0a 09 20 20 20 nt step))))..
ae70: 20 20 28 65 6c 73 65 0a 09 20 20 20 20 20 20 28 (else.. (
ae80: 76 65 63 74 6f 72 2d 73 65 74 21 20 72 65 63 6f vector-set! reco
ae90: 72 64 20 32 20 28 74 64 62 3a 73 74 65 70 2d 67 rd 2 (tdb:step-g
aea0: 65 74 2d 73 74 61 74 65 20 73 74 65 70 29 29 0a et-state step)).
aeb0: 09 20 20 20 20 20 20 28 76 65 63 74 6f 72 2d 73 . (vector-s
aec0: 65 74 21 20 72 65 63 6f 72 64 20 33 20 28 74 64 et! record 3 (td
aed0: 62 3a 73 74 65 70 2d 67 65 74 2d 73 74 61 74 75 b:step-get-statu
aee0: 73 20 73 74 65 70 29 29 0a 09 20 20 20 20 20 20 s step))..
aef0: 28 76 65 63 74 6f 72 2d 73 65 74 21 20 72 65 63 (vector-set! rec
af00: 6f 72 64 20 34 20 28 74 64 62 3a 73 74 65 70 2d ord 4 (tdb:step-
af10: 67 65 74 2d 65 76 65 6e 74 5f 74 69 6d 65 20 73 get-event_time s
af20: 74 65 70 29 29 0a 09 20 20 20 20 20 20 28 76 65 tep)).. (ve
af30: 63 74 6f 72 2d 73 65 74 21 20 72 65 63 6f 72 64 ctor-set! record
af40: 20 36 20 28 74 64 62 3a 73 74 65 70 2d 67 65 74 6 (tdb:step-get
af50: 2d 63 6f 6d 6d 65 6e 74 20 73 74 65 70 29 29 29 -comment step)))
af60: 29 0a 09 20 20 20 28 68 61 73 68 2d 74 61 62 6c ).. (hash-tabl
af70: 65 2d 73 65 74 21 20 72 65 73 20 28 74 64 62 3a e-set! res (tdb:
af80: 73 74 65 70 2d 67 65 74 2d 73 74 65 70 6e 61 6d step-get-stepnam
af90: 65 20 73 74 65 70 29 20 72 65 63 6f 72 64 29 0a e step) record).
afa0: 09 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 . (debug:print
afb0: 20 36 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 6 *default-log-
afc0: 70 6f 72 74 2a 20 22 72 65 63 6f 72 64 28 61 66 port* "record(af
afd0: 74 65 72 29 20 20 3d 20 22 20 72 65 63 6f 72 64 ter) = " record
afe0: 20 0a 09 09 09 22 5c 6e 69 64 3a 20 20 20 20 20 ...."\nid:
aff0: 20 20 22 20 28 74 64 62 3a 73 74 65 70 2d 67 65 " (tdb:step-ge
b000: 74 2d 69 64 20 73 74 65 70 29 0a 09 09 09 22 5c t-id step)...."\
b010: 6e 73 74 65 70 6e 61 6d 65 3a 20 22 20 28 74 64 nstepname: " (td
b020: 62 3a 73 74 65 70 2d 67 65 74 2d 73 74 65 70 6e b:step-get-stepn
b030: 61 6d 65 20 73 74 65 70 29 0a 09 09 09 22 5c 6e ame step)...."\n
b040: 73 74 61 74 65 3a 20 20 20 20 22 20 28 74 64 62 state: " (tdb
b050: 3a 73 74 65 70 2d 67 65 74 2d 73 74 61 74 65 20 :step-get-state
b060: 73 74 65 70 29 0a 09 09 09 22 5c 6e 73 74 61 74 step)...."\nstat
b070: 75 73 3a 20 20 20 22 20 28 74 64 62 3a 73 74 65 us: " (tdb:ste
b080: 70 2d 67 65 74 2d 73 74 61 74 75 73 20 73 74 65 p-get-status ste
b090: 70 29 0a 09 09 09 22 5c 6e 74 69 6d 65 3a 20 20 p)...."\ntime:
b0a0: 20 20 20 22 20 28 74 64 62 3a 73 74 65 70 2d 67 " (tdb:step-g
b0b0: 65 74 2d 65 76 65 6e 74 5f 74 69 6d 65 20 73 74 et-event_time st
b0c0: 65 70 29 29 29 29 0a 20 20 20 20 20 20 20 3b 3b ep)))). ;;
b0d0: 20 28 65 6c 73 65 20 20 20 28 76 65 63 74 6f 72 (else (vector
b0e0: 2d 73 65 74 21 20 72 65 63 6f 72 64 20 31 20 28 -set! record 1 (
b0f0: 74 64 62 3a 73 74 65 70 2d 67 65 74 2d 65 76 65 tdb:step-get-eve
b100: 6e 74 5f 74 69 6d 65 20 73 74 65 70 29 29 29 0a nt_time step))).
b110: 20 20 20 20 20 20 20 28 73 6f 72 74 20 73 74 65 (sort ste
b120: 70 73 20 28 6c 61 6d 62 64 61 20 28 61 20 62 29 ps (lambda (a b)
b130: 0a 09 09 20 20 20 20 20 28 63 6f 6e 64 0a 09 09 ... (cond...
b140: 20 20 20 20 20 20 28 28 3c 20 20 20 28 74 64 62 ((< (tdb
b150: 3a 73 74 65 70 2d 67 65 74 2d 65 76 65 6e 74 5f :step-get-event_
b160: 74 69 6d 65 20 61 29 28 74 64 62 3a 73 74 65 70 time a)(tdb:step
b170: 2d 67 65 74 2d 65 76 65 6e 74 5f 74 69 6d 65 20 -get-event_time
b180: 62 29 29 20 23 74 29 0a 09 09 20 20 20 20 20 20 b)) #t)...
b190: 28 28 65 71 3f 20 28 74 64 62 3a 73 74 65 70 2d ((eq? (tdb:step-
b1a0: 67 65 74 2d 65 76 65 6e 74 5f 74 69 6d 65 20 61 get-event_time a
b1b0: 29 28 74 64 62 3a 73 74 65 70 2d 67 65 74 2d 65 )(tdb:step-get-e
b1c0: 76 65 6e 74 5f 74 69 6d 65 20 62 29 29 20 0a 09 vent_time b)) ..
b1d0: 09 20 20 20 20 20 20 20 28 3c 20 20 20 28 74 64 . (< (td
b1e0: 62 3a 73 74 65 70 2d 67 65 74 2d 69 64 20 61 29 b:step-get-id a)
b1f0: 20 20 20 20 20 20 20 20 28 74 64 62 3a 73 74 65 (tdb:ste
b200: 70 2d 67 65 74 2d 69 64 20 62 29 29 29 0a 09 09 p-get-id b)))...
b210: 20 20 20 20 20 20 28 65 6c 73 65 20 23 66 29 29 (else #f))
b220: 29 29 29 0a 20 20 20 20 20 20 72 65 73 29 29 0a ))). res)).
b230: 0a 3b 3b 20 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 .;; .;;.(define
b240: 28 74 65 73 74 73 3a 67 65 74 2d 63 6f 6d 70 72 (tests:get-compr
b250: 65 73 73 65 64 2d 73 74 65 70 73 20 72 75 6e 2d essed-steps run-
b260: 69 64 20 74 65 73 74 2d 69 64 29 0a 20 20 28 6c id test-id). (l
b270: 65 74 2a 20 28 28 73 74 65 70 73 2d 64 61 74 61 et* ((steps-data
b280: 20 20 28 72 6d 74 3a 67 65 74 2d 73 74 65 70 73 (rmt:get-steps
b290: 2d 66 6f 72 2d 74 65 73 74 20 72 75 6e 2d 69 64 -for-test run-id
b2a0: 20 74 65 73 74 2d 69 64 29 29 20 3b 3b 20 20 20 test-id)) ;;
b2b0: 20 20 20 30 20 20 20 20 20 20 20 31 20 20 20 20 0 1
b2c0: 32 20 20 20 20 33 20 20 20 20 20 20 20 34 20 20 2 3 4
b2d0: 20 20 20 20 20 35 20 20 20 20 20 20 20 36 20 20 5 6
b2e0: 20 20 20 20 37 20 20 20 20 20 20 20 0a 09 20 28 7 .. (
b2f0: 63 6f 6d 70 72 73 74 65 70 73 20 20 28 74 65 73 comprsteps (tes
b300: 74 73 3a 70 72 6f 63 65 73 73 2d 73 74 65 70 73 ts:process-steps
b310: 2d 74 61 62 6c 65 20 73 74 65 70 73 2d 64 61 74 -table steps-dat
b320: 61 29 29 29 20 3b 3b 20 23 3c 73 74 65 70 6e 61 a))) ;; #<stepna
b330: 6d 65 20 73 74 61 72 74 20 65 6e 64 20 73 74 61 me start end sta
b340: 74 75 73 20 44 75 72 61 74 69 6f 6e 20 4c 6f 67 tus Duration Log
b350: 66 69 6c 65 20 43 6f 6d 6d 65 6e 74 20 69 64 3e file Comment id>
b360: 0a 20 20 20 20 28 6d 61 70 20 28 6c 61 6d 62 64 . (map (lambd
b370: 61 20 28 78 29 0a 09 20 20 20 3b 3b 20 74 61 6b a (x).. ;; tak
b380: 65 20 61 64 76 61 6e 74 61 67 65 20 6f 66 20 74 e advantage of t
b390: 68 65 20 5c 6e 20 6f 6e 20 74 69 6d 65 2d 3e 73 he \n on time->s
b3a0: 74 72 69 6e 67 0a 09 20 20 20 28 76 65 63 74 6f tring.. (vecto
b3b0: 72 20 20 20 20 3b 3b 20 77 65 20 61 72 65 20 63 r ;; we are c
b3c0: 6f 6e 73 74 72 75 63 74 69 6e 67 20 62 61 73 69 onstructing basi
b3d0: 63 61 6c 6c 79 20 74 68 65 20 6f 72 69 67 69 6e cally the origin
b3e0: 61 6c 20 76 65 63 74 6f 72 20 62 75 74 20 63 6f al vector but co
b3f0: 6c 6c 61 70 73 69 6e 67 20 73 74 61 72 74 20 65 llapsing start e
b400: 6e 64 20 72 65 63 6f 72 64 73 0a 09 20 20 20 20 nd records..
b410: 28 76 65 63 74 6f 72 2d 72 65 66 20 78 20 30 29 (vector-ref x 0)
b420: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
b430: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 3b 3b ;;
b440: 20 69 64 20 20 20 20 20 20 20 20 30 0a 09 20 20 id 0..
b450: 20 20 28 6c 65 74 20 28 28 73 20 28 76 65 63 74 (let ((s (vect
b460: 6f 72 2d 72 65 66 20 78 20 31 29 29 29 0a 09 20 or-ref x 1)))..
b470: 20 20 20 20 20 28 69 66 20 28 6e 75 6d 62 65 72 (if (number
b480: 3f 20 73 29 28 73 65 63 6f 6e 64 73 2d 3e 74 69 ? s)(seconds->ti
b490: 6d 65 2d 73 74 72 69 6e 67 20 73 29 20 73 29 29 me-string s) s))
b4a0: 20 3b 3b 20 73 74 61 72 74 74 69 6d 65 20 31 0a ;; starttime 1.
b4b0: 09 20 20 20 20 28 6c 65 74 20 28 28 73 20 28 76 . (let ((s (v
b4c0: 65 63 74 6f 72 2d 72 65 66 20 78 20 32 29 29 29 ector-ref x 2)))
b4d0: 0a 09 20 20 20 20 20 20 28 69 66 20 28 6e 75 6d .. (if (num
b4e0: 62 65 72 3f 20 73 29 28 73 65 63 6f 6e 64 73 2d ber? s)(seconds-
b4f0: 3e 74 69 6d 65 2d 73 74 72 69 6e 67 20 73 29 20 >time-string s)
b500: 73 29 29 20 3b 3b 20 65 6e 64 74 69 6d 65 20 20 s)) ;; endtime
b510: 20 32 0a 09 20 20 20 20 28 76 65 63 74 6f 72 2d 2.. (vector-
b520: 72 65 66 20 78 20 33 29 20 20 20 20 20 20 20 20 ref x 3)
b530: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
b540: 20 20 20 20 20 20 3b 3b 20 73 74 61 74 75 73 20 ;; status
b550: 20 20 20 33 20 20 20 20 0a 09 20 20 20 20 28 76 3 .. (v
b560: 65 63 74 6f 72 2d 72 65 66 20 78 20 34 29 20 20 ector-ref x 4)
b570: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
b580: 20 20 20 20 20 20 20 20 20 20 20 20 3b 3b 20 64 ;; d
b590: 75 72 61 74 69 6f 6e 20 20 34 0a 09 20 20 20 20 uration 4..
b5a0: 28 76 65 63 74 6f 72 2d 72 65 66 20 78 20 35 29 (vector-ref x 5)
b5b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
b5c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 3b 3b ;;
b5d0: 20 6c 6f 67 66 69 6c 65 20 20 20 35 0a 09 20 20 logfile 5..
b5e0: 20 20 28 76 65 63 74 6f 72 2d 72 65 66 20 78 20 (vector-ref x
b5f0: 36 29 20 20 20 20 20 20 20 20 20 20 20 20 20 20 6)
b600: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
b610: 3b 3b 20 63 6f 6d 6d 65 6e 74 20 20 20 36 0a 09 ;; comment 6..
b620: 20 20 20 20 28 76 65 63 74 6f 72 2d 72 65 66 20 (vector-ref
b630: 78 20 37 29 29 29 20 20 20 20 20 20 20 20 20 20 x 7)))
b640: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
b650: 20 20 3b 3b 20 69 64 20 20 20 20 20 20 20 20 37 ;; id 7
b660: 0a 09 20 28 73 6f 72 74 20 28 68 61 73 68 2d 74 .. (sort (hash-t
b670: 61 62 6c 65 2d 76 61 6c 75 65 73 20 63 6f 6d 70 able-values comp
b680: 72 73 74 65 70 73 29 0a 09 20 20 20 20 20 20 20 rsteps)..
b690: 28 6c 61 6d 62 64 61 20 28 61 20 62 29 0a 09 09 (lambda (a b)...
b6a0: 20 28 6c 65 74 20 28 28 74 69 6d 65 2d 61 20 28 (let ((time-a (
b6b0: 76 65 63 74 6f 72 2d 72 65 66 20 61 20 31 29 29 vector-ref a 1))
b6c0: 0a 09 09 20 20 20 20 20 20 20 28 74 69 6d 65 2d ... (time-
b6d0: 62 20 28 76 65 63 74 6f 72 2d 72 65 66 20 62 20 b (vector-ref b
b6e0: 31 29 29 0a 09 09 20 20 20 20 20 20 20 28 69 64 1))... (id
b6f0: 2d 61 20 20 20 28 76 65 63 74 6f 72 2d 72 65 66 -a (vector-ref
b700: 20 61 20 37 29 29 0a 09 09 20 20 20 20 20 20 20 a 7))...
b710: 28 69 64 2d 62 20 20 20 28 76 65 63 74 6f 72 2d (id-b (vector-
b720: 72 65 66 20 62 20 37 29 29 29 0a 09 09 20 20 20 ref b 7)))...
b730: 28 69 66 20 28 61 6e 64 20 28 6e 75 6d 62 65 72 (if (and (number
b740: 3f 20 74 69 6d 65 2d 61 29 28 6e 75 6d 62 65 72 ? time-a)(number
b750: 3f 20 74 69 6d 65 2d 62 29 29 0a 09 09 20 20 20 ? time-b))...
b760: 20 20 20 20 28 69 66 20 28 3c 20 74 69 6d 65 2d (if (< time-
b770: 61 20 74 69 6d 65 2d 62 29 0a 09 09 09 20 20 20 a time-b)....
b780: 23 74 0a 09 09 09 20 20 20 28 69 66 20 28 65 71 #t.... (if (eq
b790: 3f 20 74 69 6d 65 2d 61 20 74 69 6d 65 2d 62 29 ? time-a time-b)
b7a0: 0a 09 09 09 20 20 20 20 20 20 20 28 3c 20 69 64 .... (< id
b7b0: 2d 61 20 69 64 2d 62 29 0a 09 09 09 20 20 20 20 -a id-b)....
b7c0: 20 20 20 3b 3b 20 28 73 74 72 69 6e 67 3c 3f 20 ;; (string<?
b7d0: 28 63 6f 6e 63 20 28 76 65 63 74 6f 72 2d 72 65 (conc (vector-re
b7e0: 66 20 61 20 32 29 29 0a 09 09 09 20 20 20 20 20 f a 2))....
b7f0: 20 20 3b 3b 09 20 20 20 20 28 63 6f 6e 63 20 28 ;;. (conc (
b800: 76 65 63 74 6f 72 2d 72 65 66 20 62 20 32 29 29 vector-ref b 2))
b810: 29 0a 09 09 09 20 20 20 20 20 20 20 23 66 29 29 ).... #f))
b820: 0a 09 09 20 20 20 20 20 20 20 28 73 74 72 69 6e ... (strin
b830: 67 3c 3f 20 28 63 6f 6e 63 20 74 69 6d 65 2d 61 g<? (conc time-a
b840: 29 28 63 6f 6e 63 20 74 69 6d 65 2d 62 29 29 29 )(conc time-b)))
b850: 29 29 29 29 29 29 0a 0a 0a 3b 3b 20 73 75 6d 6d ))))))...;; summ
b860: 61 72 69 7a 65 20 74 65 73 74 20 69 6e 20 74 6f arize test in to
b870: 20 61 20 66 69 6c 65 20 74 65 73 74 2d 73 75 6d a file test-sum
b880: 6d 61 72 79 2e 68 74 6d 6c 20 69 6e 20 74 68 65 mary.html in the
b890: 20 74 65 73 74 20 64 69 72 65 63 74 6f 72 79 0a test directory.
b8a0: 3b 3b 0a 28 64 65 66 69 6e 65 20 28 74 65 73 74 ;;.(define (test
b8b0: 73 3a 73 75 6d 6d 61 72 69 7a 65 2d 74 65 73 74 s:summarize-test
b8c0: 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 69 64 29 run-id test-id)
b8d0: 0a 20 20 28 6c 65 74 2a 20 28 28 74 65 73 74 2d . (let* ((test-
b8e0: 64 61 74 20 20 28 72 6d 74 3a 67 65 74 2d 74 65 dat (rmt:get-te
b8f0: 73 74 2d 69 6e 66 6f 2d 62 79 2d 69 64 20 72 75 st-info-by-id ru
b900: 6e 2d 69 64 20 74 65 73 74 2d 69 64 29 29 0a 09 n-id test-id))..
b910: 20 28 6f 75 74 2d 64 69 72 20 20 20 28 64 62 3a (out-dir (db:
b920: 74 65 73 74 2d 67 65 74 2d 72 75 6e 64 69 72 20 test-get-rundir
b930: 74 65 73 74 2d 64 61 74 29 29 0a 09 20 28 6f 75 test-dat)).. (ou
b940: 74 2d 66 69 6c 65 20 20 28 63 6f 6e 63 20 6f 75 t-file (conc ou
b950: 74 2d 64 69 72 20 22 2f 74 65 73 74 2d 73 75 6d t-dir "/test-sum
b960: 6d 61 72 79 2e 68 74 6d 6c 22 29 29 29 0a 20 20 mary.html"))).
b970: 20 20 3b 3b 20 66 69 72 73 74 20 76 65 72 69 66 ;; first verif
b980: 79 20 77 65 20 61 72 65 20 61 62 6c 65 20 74 6f y we are able to
b990: 20 77 72 69 74 65 20 74 68 65 20 6f 75 74 70 75 write the outpu
b9a0: 74 20 66 69 6c 65 0a 20 20 20 20 28 69 66 20 28 t file. (if (
b9b0: 6e 6f 74 20 28 66 69 6c 65 2d 77 72 69 74 65 2d not (file-write-
b9c0: 61 63 63 65 73 73 3f 20 6f 75 74 2d 64 69 72 29 access? out-dir)
b9d0: 29 0a 09 28 64 65 62 75 67 3a 70 72 69 6e 74 20 )..(debug:print
b9e0: 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 0 *default-log-p
b9f0: 6f 72 74 2a 20 22 45 52 52 4f 52 3a 20 63 61 6e ort* "ERROR: can
ba00: 6e 6f 74 20 77 72 69 74 65 20 74 65 73 74 2d 73 not write test-s
ba10: 75 6d 6d 61 72 79 2e 68 74 6d 6c 20 74 6f 20 22 ummary.html to "
ba20: 20 6f 75 74 2d 64 69 72 29 0a 09 28 6c 65 74 2a out-dir)..(let*
ba30: 20 28 3b 3b 20 28 73 74 65 70 73 2d 64 61 74 20 (;; (steps-dat
ba40: 28 72 6d 74 3a 67 65 74 2d 73 74 65 70 73 2d 66 (rmt:get-steps-f
ba50: 6f 72 2d 74 65 73 74 20 72 75 6e 2d 69 64 20 74 or-test run-id t
ba60: 65 73 74 2d 69 64 29 29 0a 09 20 20 20 20 20 20 est-id))..
ba70: 20 28 74 65 73 74 2d 6e 61 6d 65 20 28 64 62 3a (test-name (db:
ba80: 74 65 73 74 2d 67 65 74 2d 74 65 73 74 6e 61 6d test-get-testnam
ba90: 65 20 74 65 73 74 2d 64 61 74 29 29 0a 09 20 20 e test-dat))..
baa0: 20 20 20 20 20 28 69 74 65 6d 2d 70 61 74 68 20 (item-path
bab0: 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 69 74 65 (db:test-get-ite
bac0: 6d 2d 70 61 74 68 20 74 65 73 74 2d 64 61 74 29 m-path test-dat)
bad0: 29 0a 09 20 20 20 20 20 20 20 28 66 75 6c 6c 2d ).. (full-
bae0: 6e 61 6d 65 20 28 64 62 3a 74 65 73 74 2d 6d 61 name (db:test-ma
baf0: 6b 65 2d 66 75 6c 6c 2d 6e 61 6d 65 20 74 65 73 ke-full-name tes
bb00: 74 2d 6e 61 6d 65 20 69 74 65 6d 2d 70 61 74 68 t-name item-path
bb10: 29 29 0a 09 20 20 20 20 20 20 20 28 6f 75 70 20 )).. (oup
bb20: 20 20 20 20 20 20 28 6f 70 65 6e 2d 6f 75 74 70 (open-outp
bb30: 75 74 2d 66 69 6c 65 20 6f 75 74 2d 66 69 6c 65 ut-file out-file
bb40: 29 29 0a 09 20 20 20 20 20 20 20 28 73 74 61 74 )).. (stat
bb50: 75 73 20 20 20 20 28 64 62 3a 74 65 73 74 2d 67 us (db:test-g
bb60: 65 74 2d 73 74 61 74 75 73 20 20 20 74 65 73 74 et-status test
bb70: 2d 64 61 74 29 29 0a 09 20 20 20 20 20 20 20 28 -dat)).. (
bb80: 63 6f 6c 6f 72 20 20 20 20 20 28 63 6f 6d 6d 6f color (commo
bb90: 6e 3a 67 65 74 2d 63 6f 6c 6f 72 2d 66 72 6f 6d n:get-color-from
bba0: 2d 73 74 61 74 75 73 20 73 74 61 74 75 73 29 29 -status status))
bbb0: 0a 09 20 20 20 20 20 20 20 28 6c 6f 67 66 20 20 .. (logf
bbc0: 20 20 20 20 28 64 62 3a 74 65 73 74 2d 67 65 74 (db:test-get
bbd0: 2d 66 69 6e 61 6c 5f 6c 6f 67 66 20 74 65 73 74 -final_logf test
bbe0: 2d 64 61 74 29 29 0a 09 20 20 20 20 20 20 20 28 -dat)).. (
bbf0: 73 74 65 70 73 2d 64 61 74 20 28 74 65 73 74 73 steps-dat (tests
bc00: 3a 67 65 74 2d 63 6f 6d 70 72 65 73 73 65 64 2d :get-compressed-
bc10: 73 74 65 70 73 20 72 75 6e 2d 69 64 20 74 65 73 steps run-id tes
bc20: 74 2d 69 64 29 29 29 0a 09 20 20 3b 3b 20 28 64 t-id))).. ;; (d
bc30: 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 63 6f 6d 70 72 common:get-compr
bc40: 65 73 73 65 64 2d 73 74 65 70 73 20 23 66 20 31 essed-steps #f 1
bc50: 20 33 30 30 34 35 29 0a 09 20 20 3b 3b 20 28 23 30045).. ;; (#
bc60: 28 22 77 61 73 74 69 6e 67 5f 74 69 6d 65 22 20 ("wasting_time"
bc70: 22 32 33 3a 33 36 3a 31 33 22 20 22 32 33 3a 33 "23:36:13" "23:3
bc80: 36 3a 32 31 22 20 22 30 22 20 22 38 2e 30 73 22 6:21" "0" "8.0s"
bc90: 20 22 77 61 73 74 69 6e 67 5f 74 69 6d 65 2e 6c "wasting_time.l
bca0: 6f 67 22 29 29 0a 09 20 20 0a 09 20 20 28 73 3a og")).. .. (s:
bcb0: 6f 75 74 70 75 74 2d 6e 65 77 0a 09 20 20 20 6f output-new.. o
bcc0: 75 70 0a 09 20 20 20 28 73 3a 68 74 6d 6c 0a 09 up.. (s:html..
bcd0: 20 20 20 20 28 73 3a 74 69 74 6c 65 20 22 53 75 (s:title "Su
bce0: 6d 6d 61 72 79 20 66 6f 72 20 22 20 66 75 6c 6c mmary for " full
bcf0: 2d 6e 61 6d 65 29 0a 09 20 20 20 20 28 73 3a 62 -name).. (s:b
bd00: 6f 64 79 20 0a 09 20 20 20 20 20 28 73 3a 68 32 ody .. (s:h2
bd10: 20 22 53 75 6d 6d 61 72 79 20 66 6f 72 20 22 20 "Summary for "
bd20: 66 75 6c 6c 2d 6e 61 6d 65 29 0a 09 20 20 20 20 full-name)..
bd30: 20 28 73 3a 74 61 62 6c 65 20 27 63 65 6c 6c 73 (s:table 'cells
bd40: 70 61 63 69 6e 67 20 22 30 22 20 27 62 6f 72 64 pacing "0" 'bord
bd50: 65 72 20 22 31 22 0a 09 09 20 20 20 20 20 20 28 er "1"... (
bd60: 73 3a 74 72 20 28 73 3a 74 64 20 22 72 75 6e 20 s:tr (s:td "run
bd70: 69 64 22 29 20 20 20 28 73 3a 74 64 20 28 64 62 id") (s:td (db
bd80: 3a 74 65 73 74 2d 67 65 74 2d 72 75 6e 5f 69 64 :test-get-run_id
bd90: 20 20 20 74 65 73 74 2d 64 61 74 29 29 0a 09 09 test-dat))...
bda0: 09 20 20 20 20 28 73 3a 74 64 20 22 74 65 73 74 . (s:td "test
bdb0: 20 69 64 22 29 20 20 28 73 3a 74 64 20 28 64 62 id") (s:td (db
bdc0: 3a 74 65 73 74 2d 67 65 74 2d 69 64 20 20 20 20 :test-get-id
bdd0: 20 20 20 74 65 73 74 2d 64 61 74 29 29 29 0a 09 test-dat)))..
bde0: 09 20 20 20 20 20 20 28 73 3a 74 72 20 28 73 3a . (s:tr (s:
bdf0: 74 64 20 22 74 65 73 74 6e 61 6d 65 22 29 20 28 td "testname") (
be00: 73 3a 74 64 20 74 65 73 74 2d 6e 61 6d 65 29 0a s:td test-name).
be10: 09 09 09 20 20 20 20 28 73 3a 74 64 20 22 69 74 ... (s:td "it
be20: 65 6d 70 61 74 68 22 29 20 28 73 3a 74 64 20 69 empath") (s:td i
be30: 74 65 6d 2d 70 61 74 68 29 29 0a 09 09 20 20 20 tem-path))...
be40: 20 20 20 28 73 3a 74 72 20 28 73 3a 74 64 20 22 (s:tr (s:td "
be50: 73 74 61 74 65 22 29 20 20 20 20 28 73 3a 74 64 state") (s:td
be60: 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 73 74 (db:test-get-st
be70: 61 74 65 20 20 20 20 74 65 73 74 2d 64 61 74 29 ate test-dat)
be80: 29 0a 09 09 09 20 20 20 20 28 73 3a 74 64 20 22 ).... (s:td "
be90: 73 74 61 74 75 73 22 29 20 20 20 28 73 3a 74 64 status") (s:td
bea0: 20 28 73 3a 61 20 27 68 72 65 66 20 6c 6f 67 66 (s:a 'href logf
beb0: 20 28 73 3a 66 6f 6e 74 20 27 63 6f 6c 6f 72 20 (s:font 'color
bec0: 63 6f 6c 6f 72 20 73 74 61 74 75 73 29 29 29 29 color status))))
bed0: 0a 09 09 20 20 20 20 20 20 28 73 3a 74 72 20 28 ... (s:tr (
bee0: 73 3a 74 64 20 22 54 65 73 74 44 61 74 65 22 29 s:td "TestDate")
bef0: 20 28 73 3a 74 64 20 28 73 65 63 6f 6e 64 73 2d (s:td (seconds-
bf00: 3e 77 6f 72 6b 2d 77 65 65 6b 2f 64 61 79 2d 74 >work-week/day-t
bf10: 69 6d 65 20 0a 09 09 09 09 09 09 20 20 20 20 20 ime .......
bf20: 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 65 76 65 (db:test-get-eve
bf30: 6e 74 5f 74 69 6d 65 20 74 65 73 74 2d 64 61 74 nt_time test-dat
bf40: 29 29 29 0a 09 09 09 20 20 20 20 28 73 3a 74 64 ))).... (s:td
bf50: 20 22 44 75 72 61 74 69 6f 6e 22 29 20 28 73 3a "Duration") (s:
bf60: 74 64 20 28 73 65 63 6f 6e 64 73 2d 3e 68 72 2d td (seconds->hr-
bf70: 6d 69 6e 2d 73 65 63 20 28 64 62 3a 74 65 73 74 min-sec (db:test
bf80: 2d 67 65 74 2d 72 75 6e 5f 64 75 72 61 74 69 6f -get-run_duratio
bf90: 6e 20 74 65 73 74 2d 64 61 74 29 29 29 29 29 0a n test-dat))))).
bfa0: 09 20 20 20 20 20 28 73 3a 68 33 20 22 4c 6f 67 . (s:h3 "Log
bfb0: 20 66 69 6c 65 73 22 29 0a 09 20 20 20 20 20 28 files").. (
bfc0: 73 3a 74 61 62 6c 65 0a 09 20 20 20 20 20 20 27 s:table.. '
bfd0: 63 65 6c 6c 73 70 61 63 69 6e 67 20 22 30 22 20 cellspacing "0"
bfe0: 27 62 6f 72 64 65 72 20 22 31 22 0a 09 20 20 20 'border "1"..
bff0: 20 20 20 28 73 3a 74 72 20 28 73 3a 74 64 20 22 (s:tr (s:td "
c000: 46 69 6e 61 6c 20 6c 6f 67 22 29 28 73 3a 74 64 Final log")(s:td
c010: 20 28 73 3a 61 20 27 68 72 65 66 20 6c 6f 67 66 (s:a 'href logf
c020: 20 6c 6f 67 66 29 29 29 29 0a 09 20 20 20 20 20 logf))))..
c030: 28 73 3a 74 61 62 6c 65 0a 09 20 20 20 20 20 20 (s:table..
c040: 27 63 65 6c 6c 73 70 61 63 69 6e 67 20 22 30 22 'cellspacing "0"
c050: 20 27 62 6f 72 64 65 72 20 22 31 22 0a 09 20 20 'border "1"..
c060: 20 20 20 20 28 73 3a 74 72 20 28 73 3a 74 64 20 (s:tr (s:td
c070: 22 53 74 65 70 20 4e 61 6d 65 22 29 28 73 3a 74 "Step Name")(s:t
c080: 64 20 22 53 74 61 72 74 22 29 28 73 3a 74 64 20 d "Start")(s:td
c090: 22 45 6e 64 22 29 28 73 3a 74 64 20 22 53 74 61 "End")(s:td "Sta
c0a0: 74 75 73 22 29 28 73 3a 74 64 20 22 44 75 72 61 tus")(s:td "Dura
c0b0: 74 69 6f 6e 22 29 28 73 3a 74 64 20 22 4c 6f 67 tion")(s:td "Log
c0c0: 20 46 69 6c 65 22 29 29 0a 09 20 20 20 20 20 20 File"))..
c0d0: 28 6d 61 70 20 28 6c 61 6d 62 64 61 20 28 73 74 (map (lambda (st
c0e0: 65 70 2d 64 61 74 29 0a 09 09 20 20 20 20 20 28 ep-dat)... (
c0f0: 73 3a 74 72 20 28 73 3a 74 64 20 28 74 64 62 3a s:tr (s:td (tdb:
c100: 73 74 65 70 73 2d 74 61 62 6c 65 2d 67 65 74 2d steps-table-get-
c110: 73 74 65 70 6e 61 6d 65 20 73 74 65 70 2d 64 61 stepname step-da
c120: 74 29 29 0a 09 09 09 20 20 20 28 73 3a 74 64 20 t)).... (s:td
c130: 28 74 64 62 3a 73 74 65 70 73 2d 74 61 62 6c 65 (tdb:steps-table
c140: 2d 67 65 74 2d 73 74 61 72 74 20 20 20 20 73 74 -get-start st
c150: 65 70 2d 64 61 74 29 29 0a 09 09 09 20 20 20 28 ep-dat)).... (
c160: 73 3a 74 64 20 28 74 64 62 3a 73 74 65 70 73 2d s:td (tdb:steps-
c170: 74 61 62 6c 65 2d 67 65 74 2d 65 6e 64 20 20 20 table-get-end
c180: 20 20 20 73 74 65 70 2d 64 61 74 29 29 0a 09 09 step-dat))...
c190: 09 20 20 20 28 73 3a 74 64 20 28 74 64 62 3a 73 . (s:td (tdb:s
c1a0: 74 65 70 73 2d 74 61 62 6c 65 2d 67 65 74 2d 73 teps-table-get-s
c1b0: 74 61 74 75 73 20 20 20 73 74 65 70 2d 64 61 74 tatus step-dat
c1c0: 29 29 0a 09 09 09 20 20 20 28 73 3a 74 64 20 28 )).... (s:td (
c1d0: 74 64 62 3a 73 74 65 70 73 2d 74 61 62 6c 65 2d tdb:steps-table-
c1e0: 67 65 74 2d 72 75 6e 74 69 6d 65 20 20 73 74 65 get-runtime ste
c1f0: 70 2d 64 61 74 29 29 0a 09 09 09 20 20 20 28 73 p-dat)).... (s
c200: 3a 74 64 20 28 6c 65 74 20 28 28 73 74 65 70 2d :td (let ((step-
c210: 6c 6f 67 20 28 74 64 62 3a 73 74 65 70 73 2d 74 log (tdb:steps-t
c220: 61 62 6c 65 2d 67 65 74 2d 6c 6f 67 2d 66 69 6c able-get-log-fil
c230: 65 20 73 74 65 70 2d 64 61 74 29 29 29 0a 09 09 e step-dat)))...
c240: 09 09 20 20 20 28 73 3a 61 20 27 68 72 65 66 20 .. (s:a 'href
c250: 73 74 65 70 2d 6c 6f 67 20 73 74 65 70 2d 6c 6f step-log step-lo
c260: 67 29 29 29 29 29 0a 09 09 20 20 20 73 74 65 70 g)))))... step
c270: 73 2d 64 61 74 29 29 0a 09 20 20 20 20 20 29 29 s-dat)).. ))
c280: 29 0a 09 20 20 28 63 6c 6f 73 65 2d 6f 75 74 70 ).. (close-outp
c290: 75 74 2d 70 6f 72 74 20 6f 75 70 29 29 29 29 29 ut-port oup)))))
c2a0: 0a 09 20 20 0a 09 20 20 0a 3b 3b 20 4d 55 53 54 .. .. .;; MUST
c2b0: 20 42 45 20 43 41 4c 4c 45 44 20 6c 6f 63 61 6c BE CALLED local
c2c0: 21 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 74 65 !.;;.(define (te
c2d0: 73 74 73 3a 74 65 73 74 2d 67 65 74 2d 70 61 74 sts:test-get-pat
c2e0: 68 73 2d 6d 61 74 63 68 69 6e 67 20 6b 65 79 6e hs-matching keyn
c2f0: 61 6d 65 73 20 74 61 72 67 65 74 20 66 6e 61 6d ames target fnam
c300: 65 70 61 74 74 20 23 21 6b 65 79 20 28 72 65 73 epatt #!key (res
c310: 20 27 28 29 29 29 0a 20 20 3b 3b 20 42 55 47 3a '())). ;; BUG:
c320: 20 4d 6f 76 65 20 74 68 65 20 76 61 6c 75 65 73 Move the values
c330: 20 64 65 72 69 76 65 64 20 66 72 6f 6d 20 61 72 derived from ar
c340: 67 73 20 74 6f 20 70 61 72 61 6d 65 74 65 72 73 gs to parameters
c350: 20 61 6e 64 20 70 75 73 68 20 74 6f 20 6d 65 67 and push to meg
c360: 61 74 65 73 74 2e 73 63 6d 0a 20 20 28 6c 65 74 atest.scm. (let
c370: 2a 20 28 28 74 65 73 74 70 61 74 74 20 20 20 28 * ((testpatt (
c380: 6f 72 20 28 61 72 67 73 3a 67 65 74 2d 61 72 67 or (args:get-arg
c390: 20 22 2d 74 65 73 74 70 61 74 74 22 29 28 61 72 "-testpatt")(ar
c3a0: 67 73 3a 67 65 74 2d 61 72 67 20 22 2d 74 65 73 gs:get-arg "-tes
c3b0: 74 70 61 74 74 22 29 20 22 25 22 29 29 0a 09 20 tpatt") "%"))..
c3c0: 28 73 74 61 74 65 70 61 74 74 20 20 28 6f 72 20 (statepatt (or
c3d0: 28 61 72 67 73 3a 67 65 74 2d 61 72 67 20 22 2d (args:get-arg "-
c3e0: 73 74 61 74 65 22 29 20 20 20 28 61 72 67 73 3a state") (args:
c3f0: 67 65 74 2d 61 72 67 20 22 3a 73 74 61 74 65 22 get-arg ":state"
c400: 29 20 20 20 20 22 25 22 29 29 0a 09 20 28 73 74 ) "%")).. (st
c410: 61 74 75 73 70 61 74 74 20 28 6f 72 20 28 61 72 atuspatt (or (ar
c420: 67 73 3a 67 65 74 2d 61 72 67 20 22 2d 73 74 61 gs:get-arg "-sta
c430: 74 75 73 22 29 20 20 28 61 72 67 73 3a 67 65 74 tus") (args:get
c440: 2d 61 72 67 20 22 3a 73 74 61 74 75 73 22 29 20 -arg ":status")
c450: 20 20 22 25 22 29 29 0a 09 20 28 72 75 6e 6e 61 "%")).. (runna
c460: 6d 65 20 20 20 20 28 6f 72 20 28 61 72 67 73 3a me (or (args:
c470: 67 65 74 2d 61 72 67 20 22 2d 72 75 6e 6e 61 6d get-arg "-runnam
c480: 65 22 29 20 28 61 72 67 73 3a 67 65 74 2d 61 72 e") (args:get-ar
c490: 67 20 22 3a 72 75 6e 6e 61 6d 65 22 29 20 20 22 g ":runname") "
c4a0: 25 22 29 29 0a 09 20 28 70 61 74 68 73 2d 66 72 %")).. (paths-fr
c4b0: 6f 6d 2d 64 62 20 28 72 6d 74 3a 74 65 73 74 2d om-db (rmt:test-
c4c0: 67 65 74 2d 70 61 74 68 73 2d 6d 61 74 63 68 69 get-paths-matchi
c4d0: 6e 67 2d 6b 65 79 6e 61 6d 65 73 2d 74 61 72 67 ng-keynames-targ
c4e0: 65 74 2d 6e 65 77 20 6b 65 79 6e 61 6d 65 73 20 et-new keynames
c4f0: 74 61 72 67 65 74 20 72 65 73 0a 09 09 09 09 09 target res......
c500: 74 65 73 74 70 61 74 74 0a 09 09 09 09 09 73 74 testpatt......st
c510: 61 74 65 70 61 74 74 0a 09 09 09 09 09 73 74 61 atepatt......sta
c520: 74 75 73 70 61 74 74 0a 09 09 09 09 09 72 75 6e tuspatt......run
c530: 6e 61 6d 65 29 29 29 0a 20 20 20 20 28 69 66 20 name))). (if
c540: 66 6e 61 6d 65 70 61 74 74 0a 09 28 61 70 70 6c fnamepatt..(appl
c550: 79 20 61 70 70 65 6e 64 20 0a 09 20 20 20 20 20 y append ..
c560: 20 20 28 6d 61 70 20 28 6c 61 6d 62 64 61 20 28 (map (lambda (
c570: 70 29 0a 09 09 20 20 20 20 20 20 28 69 66 20 28 p)... (if (
c580: 64 69 72 65 63 74 6f 72 79 2d 65 78 69 73 74 73 directory-exists
c590: 3f 20 70 29 0a 09 09 09 20 20 28 6c 65 74 20 28 ? p).... (let (
c5a0: 28 67 6c 6f 62 2d 71 75 65 72 79 20 28 63 6f 6e (glob-query (con
c5b0: 63 20 70 20 22 2f 22 20 66 6e 61 6d 65 70 61 74 c p "/" fnamepat
c5c0: 74 29 29 29 0a 09 09 09 20 20 20 20 28 68 61 6e t))).... (han
c5d0: 64 6c 65 2d 65 78 63 65 70 74 69 6f 6e 73 0a 09 dle-exceptions..
c5e0: 09 09 09 65 78 6e 0a 09 09 09 09 28 77 69 74 68 ...exn.....(with
c5f0: 2d 69 6e 70 75 74 2d 66 72 6f 6d 2d 70 69 70 65 -input-from-pipe
c600: 0a 09 09 09 09 20 20 20 20 28 63 6f 6e 63 20 22 ..... (conc "
c610: 65 63 68 6f 20 22 20 67 6c 6f 62 2d 71 75 65 72 echo " glob-quer
c620: 79 29 0a 09 09 09 09 20 20 72 65 61 64 2d 6c 69 y)..... read-li
c630: 6e 65 73 29 20 20 3b 3b 20 77 65 20 61 72 65 6e nes) ;; we aren
c640: 27 74 20 67 6f 69 6e 67 20 74 6f 20 74 72 79 20 't going to try
c650: 74 6f 6f 20 68 61 72 64 2e 20 49 66 20 67 6c 6f too hard. If glo
c660: 62 20 62 72 65 61 6b 73 20 69 74 20 69 73 20 6c b breaks it is l
c670: 69 6b 65 6c 79 20 62 65 63 61 75 73 65 20 73 6f ikely because so
c680: 6d 65 6f 6e 65 20 74 72 69 65 64 20 74 6f 20 64 meone tried to d
c690: 6f 20 2a 2f 2a 2f 2a 2e 6c 6f 67 20 6f 72 20 73 o */*/*.log or s
c6a0: 69 6d 69 6c 61 72 0a 09 09 09 20 20 20 20 20 20 imilar....
c6b0: 28 67 6c 6f 62 20 67 6c 6f 62 2d 71 75 65 72 79 (glob glob-query
c6c0: 29 29 29 0a 09 09 09 20 20 27 28 29 29 29 0a 09 ))).... '()))..
c6d0: 09 20 20 20 20 70 61 74 68 73 2d 66 72 6f 6d 2d . paths-from-
c6e0: 64 62 29 29 0a 09 70 61 74 68 73 2d 66 72 6f 6d db))..paths-from
c6f0: 2d 64 62 29 29 29 0a 0a 09 09 09 20 20 20 20 20 -db))).....
c700: 20 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d .;;============
c710: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
c720: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
c730: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
c740: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 47 61 ==========.;; Ga
c750: 74 68 65 72 20 64 61 74 61 20 66 72 6f 6d 20 74 ther data from t
c760: 65 73 74 2f 74 61 73 6b 20 73 70 65 63 69 66 69 est/task specifi
c770: 63 61 74 69 6f 6e 73 0a 3b 3b 3d 3d 3d 3d 3d 3d cations.;;======
c780: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
c790: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
c7a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
c7b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
c7c0: 0a 0a 3b 3b 20 28 64 65 66 69 6e 65 20 28 74 65 ..;; (define (te
c7d0: 73 74 73 3a 67 65 74 2d 76 61 6c 69 64 2d 74 65 sts:get-valid-te
c7e0: 73 74 73 20 74 65 73 74 73 64 69 72 20 74 65 73 sts testsdir tes
c7f0: 74 2d 70 61 74 74 73 29 20 3b 3b 20 20 23 21 6b t-patts) ;; #!k
c800: 65 79 20 28 74 65 73 74 2d 6e 61 6d 65 73 20 27 ey (test-names '
c810: 28 29 29 29 0a 3b 3b 20 20 20 28 6c 65 74 20 28 ())).;; (let (
c820: 28 74 65 73 74 73 20 28 67 6c 6f 62 20 28 63 6f (tests (glob (co
c830: 6e 63 20 74 65 73 74 73 64 69 72 20 22 2f 74 65 nc testsdir "/te
c840: 73 74 73 2f 2a 22 29 29 29 29 20 3b 3b 20 22 20 sts/*")))) ;; "
c850: 28 73 74 72 69 6e 67 2d 74 72 61 6e 73 6c 61 74 (string-translat
c860: 65 20 70 61 74 74 20 22 25 22 20 22 2a 22 29 29 e patt "%" "*"))
c870: 29 29 29 0a 3b 3b 20 20 20 20 20 28 73 65 74 21 ))).;; (set!
c880: 20 74 65 73 74 73 20 28 66 69 6c 74 65 72 20 28 tests (filter (
c890: 6c 61 6d 62 64 61 20 28 74 65 73 74 29 28 66 69 lambda (test)(fi
c8a0: 6c 65 2d 65 78 69 73 74 73 3f 20 28 63 6f 6e 63 le-exists? (conc
c8b0: 20 74 65 73 74 20 22 2f 74 65 73 74 63 6f 6e 66 test "/testconf
c8c0: 69 67 22 29 29 29 20 74 65 73 74 73 29 29 0a 3b ig"))) tests)).;
c8d0: 3b 20 20 20 20 20 28 64 65 6c 65 74 65 2d 64 75 ; (delete-du
c8e0: 70 6c 69 63 61 74 65 73 0a 3b 3b 20 20 20 20 20 plicates.;;
c8f0: 20 28 66 69 6c 74 65 72 20 28 6c 61 6d 62 64 61 (filter (lambda
c900: 20 28 74 65 73 74 6e 61 6d 65 29 0a 3b 3b 20 09 (testname).;; .
c910: 20 20 20 20 20 20 20 28 74 65 73 74 73 3a 6d 61 (tests:ma
c920: 74 63 68 20 74 65 73 74 2d 70 61 74 74 73 20 74 tch test-patts t
c930: 65 73 74 6e 61 6d 65 20 23 66 29 29 0a 3b 3b 20 estname #f)).;;
c940: 09 20 20 20 20 20 28 6d 61 70 20 28 6c 61 6d 62 . (map (lamb
c950: 64 61 20 28 74 65 73 74 70 29 0a 3b 3b 20 09 09 da (testp).;; ..
c960: 20 20 20 20 28 6c 61 73 74 20 28 73 74 72 69 6e (last (strin
c970: 67 2d 73 70 6c 69 74 20 74 65 73 74 70 20 22 2f g-split testp "/
c980: 22 29 29 29 0a 3b 3b 20 09 09 20 20 74 65 73 74 "))).;; .. test
c990: 73 29 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 s)))))..(define
c9a0: 28 74 65 73 74 73 3a 67 65 74 2d 74 65 73 74 2d (tests:get-test-
c9b0: 70 61 74 68 2d 66 72 6f 6d 2d 65 6e 76 69 72 6f path-from-enviro
c9c0: 6e 6d 65 6e 74 29 0a 20 20 28 69 66 20 28 61 6e nment). (if (an
c9d0: 64 20 28 67 65 74 65 6e 76 20 22 4d 54 5f 4c 49 d (getenv "MT_LI
c9e0: 4e 4b 54 52 45 45 22 29 0a 09 20 20 20 28 67 65 NKTREE").. (ge
c9f0: 74 65 6e 76 20 22 4d 54 5f 54 41 52 47 45 54 22 tenv "MT_TARGET"
ca00: 29 0a 09 20 20 20 28 67 65 74 65 6e 76 20 22 4d ).. (getenv "M
ca10: 54 5f 52 55 4e 4e 41 4d 45 22 29 0a 09 20 20 20 T_RUNNAME")..
ca20: 28 67 65 74 65 6e 76 20 22 4d 54 5f 54 45 53 54 (getenv "MT_TEST
ca30: 5f 4e 41 4d 45 22 29 0a 09 20 20 20 28 67 65 74 _NAME").. (get
ca40: 65 6e 76 20 22 4d 54 5f 49 54 45 4d 50 41 54 48 env "MT_ITEMPATH
ca50: 22 29 29 0a 20 20 20 20 20 20 28 63 6f 6e 63 20 ")). (conc
ca60: 28 67 65 74 65 6e 76 20 22 4d 54 5f 4c 49 4e 4b (getenv "MT_LINK
ca70: 54 52 45 45 22 29 20 20 22 2f 22 0a 09 20 20 20 TREE") "/"..
ca80: 20 28 67 65 74 65 6e 76 20 22 4d 54 5f 54 41 52 (getenv "MT_TAR
ca90: 47 45 54 22 29 20 20 20 20 22 2f 22 0a 09 20 20 GET") "/"..
caa0: 20 20 28 67 65 74 65 6e 76 20 22 4d 54 5f 52 55 (getenv "MT_RU
cab0: 4e 4e 41 4d 45 22 29 20 20 20 22 2f 22 0a 09 20 NNAME") "/"..
cac0: 20 20 20 28 67 65 74 65 6e 76 20 22 4d 54 5f 54 (getenv "MT_T
cad0: 45 53 54 5f 4e 41 4d 45 22 29 20 22 2f 22 0a 09 EST_NAME") "/"..
cae0: 20 20 20 20 28 69 66 20 28 6f 72 20 28 67 65 74 (if (or (get
caf0: 65 6e 76 20 22 4d 54 5f 49 54 45 4d 50 41 54 48 env "MT_ITEMPATH
cb00: 22 29 0a 09 09 20 20 20 20 28 6e 6f 74 20 28 73 ")... (not (s
cb10: 74 72 69 6e 67 3d 3f 20 22 22 20 28 67 65 74 65 tring=? "" (gete
cb20: 6e 76 20 22 4d 54 5f 49 54 45 4d 50 41 54 48 22 nv "MT_ITEMPATH"
cb30: 29 29 29 29 0a 09 09 28 63 6f 6e 63 20 22 2f 22 ))))...(conc "/"
cb40: 20 28 67 65 74 65 6e 76 20 22 4d 54 5f 49 54 45 (getenv "MT_ITE
cb50: 4d 50 41 54 48 22 29 29 29 29 0a 20 20 20 20 20 MPATH")))).
cb60: 20 23 66 29 29 0a 0a 3b 3b 20 69 66 20 2e 74 65 #f))..;; if .te
cb70: 73 74 63 6f 6e 66 69 67 20 65 78 69 73 74 73 20 stconfig exists
cb80: 69 6e 20 74 65 73 74 20 64 69 72 65 63 74 6f 72 in test director
cb90: 79 20 72 65 61 64 20 61 6e 64 20 72 65 74 75 72 y read and retur
cba0: 6e 20 69 74 0a 3b 3b 20 65 6c 73 65 20 69 66 20 n it.;; else if
cbb0: 68 61 76 65 20 63 61 63 68 65 64 20 63 6f 70 79 have cached copy
cbc0: 20 69 6e 20 2a 74 65 73 74 63 6f 6e 66 69 67 73 in *testconfigs
cbd0: 2a 20 72 65 74 75 72 6e 20 69 74 20 49 46 46 20 * return it IFF
cbe0: 74 68 65 72 65 20 69 73 20 61 20 73 65 63 74 69 there is a secti
cbf0: 6f 6e 20 22 68 61 76 65 20 66 75 6c 6c 64 61 74 on "have fulldat
cc00: 61 22 0a 3b 3b 20 65 6c 73 65 20 72 65 61 64 20 a".;; else read
cc10: 74 68 65 20 74 65 73 74 63 6f 6e 66 69 67 20 66 the testconfig f
cc20: 69 6c 65 0a 3b 3b 20 20 20 69 66 20 68 61 76 65 ile.;; if have
cc30: 20 70 61 74 68 20 74 6f 20 74 65 73 74 20 64 69 path to test di
cc40: 72 65 63 74 6f 72 79 20 73 61 76 65 20 74 68 65 rectory save the
cc50: 20 63 6f 6e 66 69 67 20 61 73 20 2e 74 65 73 74 config as .test
cc60: 63 6f 6e 66 69 67 20 61 6e 64 20 72 65 74 75 72 config and retur
cc70: 6e 20 69 74 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 n it.;;.(define
cc80: 28 74 65 73 74 73 3a 67 65 74 2d 74 65 73 74 63 (tests:get-testc
cc90: 6f 6e 66 69 67 20 74 65 73 74 2d 6e 61 6d 65 20 onfig test-name
cca0: 69 74 65 6d 2d 70 61 74 68 20 74 65 73 74 2d 72 item-path test-r
ccb0: 65 67 69 73 74 72 79 20 73 79 73 74 65 6d 2d 61 egistry system-a
ccc0: 6c 6c 6f 77 65 64 20 23 21 6b 65 79 20 28 66 6f llowed #!key (fo
ccd0: 72 63 65 2d 63 72 65 61 74 65 20 23 66 29 29 0a rce-create #f)).
cce0: 20 20 28 6c 65 74 2a 20 28 28 75 73 65 2d 63 61 (let* ((use-ca
ccf0: 63 68 65 20 20 20 20 28 63 6f 6d 6d 6f 6e 3a 75 che (common:u
cd00: 73 65 2d 63 61 63 68 65 3f 29 29 0a 09 20 28 63 se-cache?)).. (c
cd10: 61 63 68 65 2d 70 61 74 68 20 20 20 28 74 65 73 ache-path (tes
cd20: 74 73 3a 67 65 74 2d 74 65 73 74 2d 70 61 74 68 ts:get-test-path
cd30: 2d 66 72 6f 6d 2d 65 6e 76 69 72 6f 6e 6d 65 6e -from-environmen
cd40: 74 29 29 0a 09 20 28 63 61 63 68 65 2d 66 69 6c t)).. (cache-fil
cd50: 65 20 20 20 28 61 6e 64 20 63 61 63 68 65 2d 70 e (and cache-p
cd60: 61 74 68 20 28 63 6f 6e 63 20 63 61 63 68 65 2d ath (conc cache-
cd70: 70 61 74 68 20 22 2f 2e 74 65 73 74 63 6f 6e 66 path "/.testconf
cd80: 69 67 22 29 29 29 0a 09 20 28 63 61 63 68 65 2d ig"))).. (cache-
cd90: 65 78 69 73 74 73 20 28 61 6e 64 20 63 61 63 68 exists (and cach
cda0: 65 2d 66 69 6c 65 0a 09 09 09 20 20 20 20 28 6e e-file.... (n
cdb0: 6f 74 20 66 6f 72 63 65 2d 63 72 65 61 74 65 29 ot force-create)
cdc0: 20 20 3b 3b 20 69 66 20 66 6f 72 63 65 2d 63 72 ;; if force-cr
cdd0: 65 61 74 65 20 74 68 65 6e 20 70 72 65 74 65 6e eate then preten
cde0: 64 20 74 68 65 72 65 20 69 73 20 6e 6f 20 63 61 d there is no ca
cdf0: 63 68 65 20 74 6f 20 72 65 61 64 0a 09 09 09 20 che to read....
ce00: 20 20 20 28 66 69 6c 65 2d 65 78 69 73 74 73 3f (file-exists?
ce10: 20 63 61 63 68 65 2d 66 69 6c 65 29 29 29 0a 09 cache-file)))..
ce20: 20 28 63 61 63 68 65 64 2d 64 61 74 20 20 20 28 (cached-dat (
ce30: 69 66 20 28 61 6e 64 20 28 6e 6f 74 20 66 6f 72 if (and (not for
ce40: 63 65 2d 63 72 65 61 74 65 29 0a 09 09 09 09 63 ce-create).....c
ce50: 61 63 68 65 2d 65 78 69 73 74 73 0a 09 09 09 09 ache-exists.....
ce60: 75 73 65 2d 63 61 63 68 65 29 0a 09 09 09 20 20 use-cache)....
ce70: 20 28 68 61 6e 64 6c 65 2d 65 78 63 65 70 74 69 (handle-excepti
ce80: 6f 6e 73 0a 09 09 09 20 20 20 20 65 78 6e 0a 09 ons.... exn..
ce90: 09 09 20 20 20 20 23 66 20 3b 3b 20 61 6e 79 20 .. #f ;; any
cea0: 69 73 73 75 65 73 2c 20 6a 75 73 74 20 67 69 76 issues, just giv
ceb0: 65 20 75 70 20 77 69 74 68 20 74 68 65 20 63 61 e up with the ca
cec0: 63 68 65 64 20 76 65 72 73 69 6f 6e 20 61 6e 64 ched version and
ced0: 20 72 65 2d 72 65 61 64 0a 09 09 09 20 20 20 20 re-read....
cee0: 28 63 6f 6e 66 69 67 66 3a 72 65 61 64 2d 61 6c (configf:read-al
cef0: 69 73 74 20 63 61 63 68 65 2d 66 69 6c 65 29 29 ist cache-file))
cf00: 0a 09 09 09 20 20 20 23 66 29 29 0a 20 20 20 20 .... #f)).
cf10: 20 20 20 20 20 28 74 65 73 74 2d 66 75 6c 6c 2d (test-full-
cf20: 6e 61 6d 65 20 28 69 66 20 28 61 6e 64 20 69 74 name (if (and it
cf30: 65 6d 2d 70 61 74 68 20 28 6e 6f 74 20 28 73 74 em-path (not (st
cf40: 72 69 6e 67 2d 6e 75 6c 6c 3f 20 69 74 65 6d 2d ring-null? item-
cf50: 70 61 74 68 29 29 29 0a 20 20 20 20 20 20 20 20 path))).
cf60: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
cf70: 20 20 20 20 20 28 63 6f 6e 63 20 74 65 73 74 2d (conc test-
cf80: 6e 61 6d 65 20 22 2f 22 20 69 74 65 6d 2d 70 61 name "/" item-pa
cf90: 74 68 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 th).
cfa0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
cfb0: 20 74 65 73 74 2d 6e 61 6d 65 29 29 29 0a 20 20 test-name))).
cfc0: 20 20 28 69 66 20 63 61 63 68 65 64 2d 64 61 74 (if cached-dat
cfd0: 0a 09 63 61 63 68 65 64 2d 64 61 74 0a 09 28 6c ..cached-dat..(l
cfe0: 65 74 20 28 28 64 61 74 20 28 68 61 73 68 2d 74 et ((dat (hash-t
cff0: 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 able-ref/default
d000: 20 2a 74 65 73 74 63 6f 6e 66 69 67 73 2a 20 74 *testconfigs* t
d010: 65 73 74 2d 66 75 6c 6c 2d 6e 61 6d 65 20 23 66 est-full-name #f
d020: 29 29 29 0a 09 20 20 28 69 66 20 28 61 6e 64 20 ))).. (if (and
d030: 20 64 61 74 20 3b 3b 20 68 61 76 65 20 61 20 6c dat ;; have a l
d040: 6f 63 61 6c 6c 79 20 63 61 63 68 65 64 20 76 65 ocally cached ve
d050: 72 73 69 6f 6e 0a 09 09 20 20 20 20 28 68 61 73 rsion... (has
d060: 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 h-table-ref/defa
d070: 75 6c 74 20 64 61 74 20 22 68 61 76 65 20 66 75 ult dat "have fu
d080: 6c 6c 64 61 74 61 22 20 23 66 29 29 20 3b 3b 20 lldata" #f)) ;;
d090: 6d 61 72 6b 65 64 20 61 73 20 67 6f 6f 64 20 64 marked as good d
d0a0: 61 74 61 3f 0a 09 20 20 20 20 20 20 64 61 74 0a ata?.. dat.
d0b0: 09 20 20 20 20 20 20 3b 3b 20 6e 6f 20 63 61 63 . ;; no cac
d0c0: 68 65 64 20 64 61 74 61 20 61 76 61 69 6c 61 62 hed data availab
d0d0: 6c 65 0a 09 20 20 20 20 20 20 28 6c 65 74 2a 20 le.. (let*
d0e0: 28 28 74 72 65 67 20 20 20 20 20 20 20 20 20 28 ((treg (
d0f0: 6f 72 20 74 65 73 74 2d 72 65 67 69 73 74 72 79 or test-registry
d100: 0a 09 09 09 09 20 20 20 20 20 20 20 28 74 65 73 ..... (tes
d110: 74 73 3a 67 65 74 2d 61 6c 6c 29 29 29 0a 09 09 ts:get-all)))...
d120: 20 20 20 20 20 28 74 65 73 74 2d 70 61 74 68 20 (test-path
d130: 20 20 20 28 6f 72 20 28 68 61 73 68 2d 74 61 62 (or (hash-tab
d140: 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 74 le-ref/default t
d150: 72 65 67 20 74 65 73 74 2d 6e 61 6d 65 20 23 66 reg test-name #f
d160: 29 0a 09 09 09 09 20 20 20 20 20 20 20 28 63 6f )..... (co
d170: 6e 63 20 2a 74 6f 70 70 61 74 68 2a 20 22 2f 74 nc *toppath* "/t
d180: 65 73 74 73 2f 22 20 74 65 73 74 2d 6e 61 6d 65 ests/" test-name
d190: 29 29 29 0a 09 09 20 20 20 20 20 28 74 65 73 74 )))... (test
d1a0: 2d 63 6f 6e 66 69 67 66 20 28 63 6f 6e 63 20 74 -configf (conc t
d1b0: 65 73 74 2d 70 61 74 68 20 22 2f 74 65 73 74 63 est-path "/testc
d1c0: 6f 6e 66 69 67 22 29 29 0a 09 09 20 20 20 20 20 onfig"))...
d1d0: 28 74 65 73 74 65 78 69 73 74 73 20 20 20 28 61 (testexists (a
d1e0: 6e 64 20 28 66 69 6c 65 2d 65 78 69 73 74 73 3f nd (file-exists?
d1f0: 20 74 65 73 74 2d 63 6f 6e 66 69 67 66 29 28 66 test-configf)(f
d200: 69 6c 65 2d 72 65 61 64 2d 61 63 63 65 73 73 3f ile-read-access?
d210: 20 74 65 73 74 2d 63 6f 6e 66 69 67 66 29 29 29 test-configf)))
d220: 0a 09 09 20 20 20 20 20 28 74 63 66 67 20 20 20 ... (tcfg
d230: 20 20 20 20 20 20 28 69 66 20 74 65 73 74 65 78 (if testex
d240: 69 73 74 73 0a 09 09 09 09 20 20 20 20 20 20 20 ists.....
d250: 28 72 65 61 64 2d 63 6f 6e 66 69 67 20 74 65 73 (read-config tes
d260: 74 2d 63 6f 6e 66 69 67 66 20 23 66 20 73 79 73 t-configf #f sys
d270: 74 65 6d 2d 61 6c 6c 6f 77 65 64 0a 09 09 09 09 tem-allowed.....
d280: 09 09 20 20 20 20 65 6e 76 69 72 6f 6e 2d 70 61 .. environ-pa
d290: 74 74 3a 20 28 69 66 20 73 79 73 74 65 6d 2d 61 tt: (if system-a
d2a0: 6c 6c 6f 77 65 64 0a 09 09 09 09 09 09 09 09 20 llowed.........
d2b0: 20 20 20 20 20 22 70 72 65 2d 6c 61 75 6e 63 68 "pre-launch
d2c0: 2d 65 6e 76 2d 76 61 72 73 22 0a 09 09 09 09 09 -env-vars"......
d2d0: 09 09 09 20 20 20 20 20 20 23 66 29 29 0a 09 09 ... #f))...
d2e0: 09 09 20 20 20 20 20 20 20 23 66 29 29 29 0a 09 .. #f)))..
d2f0: 09 28 69 66 20 28 61 6e 64 20 74 63 66 67 20 63 .(if (and tcfg c
d300: 61 63 68 65 2d 66 69 6c 65 29 20 28 68 61 73 68 ache-file) (hash
d310: 2d 74 61 62 6c 65 2d 73 65 74 21 20 74 63 66 67 -table-set! tcfg
d320: 20 22 68 61 76 65 20 66 75 6c 6c 64 61 74 61 22 "have fulldata"
d330: 20 23 74 29 29 20 3b 3b 20 6d 61 72 6b 20 74 68 #t)) ;; mark th
d340: 69 73 20 61 73 20 66 75 6c 6c 79 20 72 65 61 64 is as fully read
d350: 20 64 61 74 61 0a 09 09 28 69 66 20 74 63 66 67 data...(if tcfg
d360: 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 (hash-table-set
d370: 21 20 2a 74 65 73 74 63 6f 6e 66 69 67 73 2a 20 ! *testconfigs*
d380: 74 65 73 74 2d 66 75 6c 6c 2d 6e 61 6d 65 20 74 test-full-name t
d390: 63 66 67 29 29 0a 09 09 28 69 66 20 28 61 6e 64 cfg))...(if (and
d3a0: 20 74 65 73 74 65 78 69 73 74 73 0a 09 09 09 20 testexists....
d3b0: 63 61 63 68 65 2d 66 69 6c 65 0a 09 09 09 20 28 cache-file.... (
d3c0: 66 69 6c 65 2d 77 72 69 74 65 2d 61 63 63 65 73 file-write-acces
d3d0: 73 3f 20 63 61 63 68 65 2d 70 61 74 68 29 29 0a s? cache-path)).
d3e0: 09 09 20 20 20 20 28 6c 65 74 20 28 28 74 70 61 .. (let ((tpa
d3f0: 74 68 20 28 63 6f 6e 63 20 63 61 63 68 65 2d 70 th (conc cache-p
d400: 61 74 68 20 22 2f 2e 74 65 73 74 63 6f 6e 66 69 ath "/.testconfi
d410: 67 22 29 29 29 0a 09 09 20 20 20 20 20 20 28 64 g")))... (d
d420: 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 ebug:print-info
d430: 31 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 1 *default-log-p
d440: 6f 72 74 2a 20 22 43 61 63 68 69 6e 67 20 74 65 ort* "Caching te
d450: 73 74 63 6f 6e 66 69 67 20 66 6f 72 20 22 20 74 stconfig for " t
d460: 65 73 74 2d 6e 61 6d 65 20 22 20 69 6e 20 22 20 est-name " in "
d470: 74 70 61 74 68 29 0a 20 20 20 20 20 20 20 20 20 tpath).
d480: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 69 66 (if
d490: 20 28 6e 6f 74 20 28 63 6f 6d 6d 6f 6e 3a 69 6e (not (common:in
d4a0: 2d 72 75 6e 6e 69 6e 67 2d 74 65 73 74 3f 29 29 -running-test?))
d4b0: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
d4c0: 20 20 20 20 20 20 20 20 20 20 20 28 63 6f 6e 66 (conf
d4d0: 69 67 66 3a 77 72 69 74 65 2d 61 6c 69 73 74 20 igf:write-alist
d4e0: 74 63 66 67 20 74 70 61 74 68 29 29 29 29 0a 09 tcfg tpath))))..
d4f0: 09 74 63 66 67 29 29 29 29 29 29 0a 20 20 0a 3b .tcfg)))))). .;
d500: 3b 20 73 6f 72 74 20 74 65 73 74 73 20 62 79 20 ; sort tests by
d510: 70 72 69 6f 72 69 74 79 20 61 6e 64 20 77 61 69 priority and wai
d520: 74 6f 6e 0a 3b 3b 20 4d 6f 76 65 20 74 65 73 74 ton.;; Move test
d530: 20 73 70 65 63 69 66 69 63 20 73 74 75 66 66 20 specific stuff
d540: 74 6f 20 61 20 74 65 73 74 20 75 6e 69 74 20 46 to a test unit F
d550: 49 58 4d 45 20 6f 6e 65 20 6f 66 20 74 68 65 73 IXME one of thes
d560: 65 20 64 61 79 73 0a 28 64 65 66 69 6e 65 20 28 e days.(define (
d570: 74 65 73 74 73 3a 73 6f 72 74 2d 62 79 2d 70 72 tests:sort-by-pr
d580: 69 6f 72 69 74 79 2d 61 6e 64 2d 77 61 69 74 6f iority-and-waito
d590: 6e 20 74 65 73 74 2d 72 65 63 6f 72 64 73 29 0a n test-records).
d5a0: 20 20 28 69 66 20 28 65 71 3f 20 28 68 61 73 68 (if (eq? (hash
d5b0: 2d 74 61 62 6c 65 2d 73 69 7a 65 20 74 65 73 74 -table-size test
d5c0: 2d 72 65 63 6f 72 64 73 29 20 30 29 0a 20 20 20 -records) 0).
d5d0: 20 20 20 27 28 29 0a 20 20 20 20 20 20 28 6c 65 '(). (le
d5e0: 74 2a 20 28 28 6d 75 6e 67 65 70 72 69 6f 72 69 t* ((mungepriori
d5f0: 74 79 20 28 6c 61 6d 62 64 61 20 28 70 72 69 6f ty (lambda (prio
d600: 72 69 74 79 29 0a 09 09 09 20 20 20 20 20 20 28 rity).... (
d610: 69 66 20 70 72 69 6f 72 69 74 79 0a 09 09 09 09 if priority.....
d620: 20 20 28 6c 65 74 20 28 28 74 6d 70 20 28 61 6e (let ((tmp (an
d630: 79 2d 3e 6e 75 6d 62 65 72 20 70 72 69 6f 72 69 y->number priori
d640: 74 79 29 29 29 0a 09 09 09 09 20 20 20 20 28 69 ty)))..... (i
d650: 66 20 74 6d 70 20 74 6d 70 20 28 62 65 67 69 6e f tmp tmp (begin
d660: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 65 72 (debug:print-er
d670: 72 6f 72 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c ror 0 *default-l
d680: 6f 67 2d 70 6f 72 74 2a 20 22 62 61 64 20 70 72 og-port* "bad pr
d690: 69 6f 72 69 74 79 20 76 61 6c 75 65 20 22 20 70 iority value " p
d6a0: 72 69 6f 72 69 74 79 20 22 2c 20 75 73 69 6e 67 riority ", using
d6b0: 20 30 22 29 20 30 29 29 29 0a 09 09 09 09 20 20 0") 0))).....
d6c0: 30 29 29 29 0a 09 20 20 20 20 20 28 61 6c 6c 2d 0))).. (all-
d6d0: 74 65 73 74 73 20 20 20 20 20 20 28 68 61 73 68 tests (hash
d6e0: 2d 74 61 62 6c 65 2d 6b 65 79 73 20 74 65 73 74 -table-keys test
d6f0: 2d 72 65 63 6f 72 64 73 29 29 0a 09 20 20 20 20 -records))..
d700: 20 28 61 6c 6c 2d 77 61 69 74 65 64 2d 6f 6e 20 (all-waited-on
d710: 20 28 6c 65 74 20 6c 6f 6f 70 20 28 28 68 65 64 (let loop ((hed
d720: 20 28 63 61 72 20 61 6c 6c 2d 74 65 73 74 73 29 (car all-tests)
d730: 29 0a 09 09 09 09 09 28 74 61 6c 20 28 63 64 72 )......(tal (cdr
d740: 20 61 6c 6c 2d 74 65 73 74 73 29 29 0a 09 09 09 all-tests))....
d750: 09 09 28 72 65 73 20 27 28 29 29 29 0a 09 09 09 ..(res '()))....
d760: 20 20 20 20 20 20 20 28 6c 65 74 2a 20 28 28 74 (let* ((t
d770: 72 65 63 20 20 20 20 28 68 61 73 68 2d 74 61 62 rec (hash-tab
d780: 6c 65 2d 72 65 66 20 74 65 73 74 2d 72 65 63 6f le-ref test-reco
d790: 72 64 73 20 68 65 64 29 29 0a 09 09 09 09 20 20 rds hed)).....
d7a0: 20 20 20 20 28 77 61 69 74 6f 6e 73 20 28 6f 72 (waitons (or
d7b0: 20 28 74 65 73 74 73 3a 74 65 73 74 71 75 65 75 (tests:testqueu
d7c0: 65 2d 67 65 74 2d 77 61 69 74 6f 6e 73 20 74 72 e-get-waitons tr
d7d0: 65 63 29 20 27 28 29 29 29 29 0a 09 09 09 09 20 ec) '()))).....
d7e0: 28 69 66 20 28 6e 75 6c 6c 3f 20 74 61 6c 29 0a (if (null? tal).
d7f0: 09 09 09 09 20 20 20 20 20 28 61 70 70 65 6e 64 .... (append
d800: 20 72 65 73 20 77 61 69 74 6f 6e 73 29 0a 09 09 res waitons)...
d810: 09 09 20 20 20 20 20 28 6c 6f 6f 70 20 28 63 61 .. (loop (ca
d820: 72 20 74 61 6c 29 28 63 64 72 20 74 61 6c 29 28 r tal)(cdr tal)(
d830: 61 70 70 65 6e 64 20 72 65 73 20 77 61 69 74 6f append res waito
d840: 6e 73 29 29 29 29 29 29 0a 09 20 20 20 20 20 28 ns)))))).. (
d850: 73 6f 72 74 2d 66 6e 31 20 0a 09 20 20 20 20 20 sort-fn1 ..
d860: 20 28 6c 61 6d 62 64 61 20 28 61 20 62 29 0a 09 (lambda (a b)..
d870: 09 28 6c 65 74 2a 20 28 28 61 2d 72 65 63 6f 72 .(let* ((a-recor
d880: 64 20 20 20 28 68 61 73 68 2d 74 61 62 6c 65 2d d (hash-table-
d890: 72 65 66 20 74 65 73 74 2d 72 65 63 6f 72 64 73 ref test-records
d8a0: 20 61 29 29 0a 09 09 20 20 20 20 20 20 20 28 62 a))... (b
d8b0: 2d 72 65 63 6f 72 64 20 20 20 28 68 61 73 68 2d -record (hash-
d8c0: 74 61 62 6c 65 2d 72 65 66 20 74 65 73 74 2d 72 table-ref test-r
d8d0: 65 63 6f 72 64 73 20 62 29 29 0a 09 09 20 20 20 ecords b))...
d8e0: 20 20 20 20 28 61 2d 77 61 69 74 6f 6e 73 20 20 (a-waitons
d8f0: 28 6f 72 20 28 74 65 73 74 73 3a 74 65 73 74 71 (or (tests:testq
d900: 75 65 75 65 2d 67 65 74 2d 77 61 69 74 6f 6e 73 ueue-get-waitons
d910: 20 61 2d 72 65 63 6f 72 64 29 20 27 28 29 29 29 a-record) '()))
d920: 0a 09 09 20 20 20 20 20 20 20 28 62 2d 77 61 69 ... (b-wai
d930: 74 6f 6e 73 20 20 28 6f 72 20 28 74 65 73 74 73 tons (or (tests
d940: 3a 74 65 73 74 71 75 65 75 65 2d 67 65 74 2d 77 :testqueue-get-w
d950: 61 69 74 6f 6e 73 20 62 2d 72 65 63 6f 72 64 29 aitons b-record)
d960: 20 27 28 29 29 29 0a 09 09 20 20 20 20 20 20 20 '()))...
d970: 28 61 2d 63 6f 6e 66 69 67 20 20 20 28 74 65 73 (a-config (tes
d980: 74 73 3a 74 65 73 74 71 75 65 75 65 2d 67 65 74 ts:testqueue-get
d990: 2d 74 65 73 74 63 6f 6e 66 69 67 20 20 61 2d 72 -testconfig a-r
d9a0: 65 63 6f 72 64 29 29 0a 09 09 20 20 20 20 20 20 ecord))...
d9b0: 20 28 62 2d 63 6f 6e 66 69 67 20 20 20 28 74 65 (b-config (te
d9c0: 73 74 73 3a 74 65 73 74 71 75 65 75 65 2d 67 65 sts:testqueue-ge
d9d0: 74 2d 74 65 73 74 63 6f 6e 66 69 67 20 20 62 2d t-testconfig b-
d9e0: 72 65 63 6f 72 64 29 29 0a 09 09 20 20 20 20 20 record))...
d9f0: 20 20 28 61 2d 72 61 77 2d 70 72 69 20 20 28 63 (a-raw-pri (c
da00: 6f 6e 66 69 67 2d 6c 6f 6f 6b 75 70 20 61 2d 63 onfig-lookup a-c
da10: 6f 6e 66 69 67 20 22 72 65 71 75 69 72 65 6d 65 onfig "requireme
da20: 6e 74 73 22 20 22 70 72 69 6f 72 69 74 79 22 29 nts" "priority")
da30: 29 0a 09 09 20 20 20 20 20 20 20 28 62 2d 72 61 )... (b-ra
da40: 77 2d 70 72 69 20 20 28 63 6f 6e 66 69 67 2d 6c w-pri (config-l
da50: 6f 6f 6b 75 70 20 62 2d 63 6f 6e 66 69 67 20 22 ookup b-config "
da60: 72 65 71 75 69 72 65 6d 65 6e 74 73 22 20 22 70 requirements" "p
da70: 72 69 6f 72 69 74 79 22 29 29 0a 09 09 20 20 20 riority"))...
da80: 20 20 20 20 28 61 2d 70 72 69 6f 72 69 74 79 20 (a-priority
da90: 28 6d 75 6e 67 65 70 72 69 6f 72 69 74 79 20 61 (mungepriority a
daa0: 2d 72 61 77 2d 70 72 69 29 29 0a 09 09 20 20 20 -raw-pri))...
dab0: 20 20 20 20 28 62 2d 70 72 69 6f 72 69 74 79 20 (b-priority
dac0: 28 6d 75 6e 67 65 70 72 69 6f 72 69 74 79 20 62 (mungepriority b
dad0: 2d 72 61 77 2d 70 72 69 29 29 29 0a 09 09 20 20 -raw-pri)))...
dae0: 28 74 65 73 74 73 3a 74 65 73 74 71 75 65 75 65 (tests:testqueue
daf0: 2d 73 65 74 2d 70 72 69 6f 72 69 74 79 21 20 61 -set-priority! a
db00: 2d 72 65 63 6f 72 64 20 61 2d 70 72 69 6f 72 69 -record a-priori
db10: 74 79 29 0a 09 09 20 20 28 74 65 73 74 73 3a 74 ty)... (tests:t
db20: 65 73 74 71 75 65 75 65 2d 73 65 74 2d 70 72 69 estqueue-set-pri
db30: 6f 72 69 74 79 21 20 62 2d 72 65 63 6f 72 64 20 ority! b-record
db40: 62 2d 70 72 69 6f 72 69 74 79 29 0a 09 09 20 20 b-priority)...
db50: 3b 3b 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 ;; (debug:print
db60: 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 0 *default-log-p
db70: 6f 72 74 2a 20 22 61 3d 22 20 61 20 22 2c 20 62 ort* "a=" a ", b
db80: 3d 22 20 62 20 22 2c 20 61 2d 77 61 69 74 6f 6e =" b ", a-waiton
db90: 73 3d 22 20 61 2d 77 61 69 74 6f 6e 73 20 22 2c s=" a-waitons ",
dba0: 20 62 2d 77 61 69 74 6f 6e 73 3d 22 20 62 2d 77 b-waitons=" b-w
dbb0: 61 69 74 6f 6e 73 29 0a 09 09 20 20 28 63 6f 6e aitons)... (con
dbc0: 64 0a 09 09 20 20 20 3b 3b 20 69 73 20 0a 09 09 d... ;; is ...
dbd0: 20 20 20 28 28 6d 65 6d 62 65 72 20 61 20 62 2d ((member a b-
dbe0: 77 61 69 74 6f 6e 73 29 20 20 20 20 20 20 20 20 waitons)
dbf0: 20 20 3b 3b 20 69 73 20 62 20 77 61 69 74 69 6e ;; is b waitin
dc00: 67 20 6f 6e 20 61 3f 0a 09 09 20 20 20 20 3b 3b g on a?... ;;
dc10: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 (debug:print 0
dc20: 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 *default-log-por
dc30: 74 2a 20 22 63 61 73 65 31 22 29 0a 09 09 20 20 t* "case1")...
dc40: 20 20 23 74 29 0a 09 09 20 20 20 28 28 6d 65 6d #t)... ((mem
dc50: 62 65 72 20 62 20 61 2d 77 61 69 74 6f 6e 73 29 ber b a-waitons)
dc60: 20 20 20 20 20 20 20 20 20 20 3b 3b 20 69 73 20 ;; is
dc70: 61 20 77 61 69 74 69 6e 67 20 6f 6e 20 62 3f 0a a waiting on b?.
dc80: 09 09 20 20 20 20 3b 3b 20 28 64 65 62 75 67 3a .. ;; (debug:
dc90: 70 72 69 6e 74 20 30 20 2a 64 65 66 61 75 6c 74 print 0 *default
dca0: 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 63 61 73 65 -log-port* "case
dcb0: 32 22 29 0a 09 09 20 20 20 20 23 66 29 0a 09 09 2")... #f)...
dcc0: 20 20 20 28 28 61 6e 64 20 28 6e 6f 74 20 28 6e ((and (not (n
dcd0: 75 6c 6c 3f 20 61 2d 77 61 69 74 6f 6e 73 29 29 ull? a-waitons))
dce0: 20 20 3b 3b 20 62 6f 74 68 20 68 61 76 65 20 77 ;; both have w
dcf0: 61 69 74 6f 6e 73 20 2d 20 64 6f 20 6e 6f 74 20 aitons - do not
dd00: 64 69 73 74 75 72 62 0a 09 09 09 20 28 6e 6f 74 disturb.... (not
dd10: 20 28 6e 75 6c 6c 3f 20 62 2d 77 61 69 74 6f 6e (null? b-waiton
dd20: 73 29 29 29 0a 09 09 20 20 20 20 3b 3b 20 28 64 s)))... ;; (d
dd30: 65 62 75 67 3a 70 72 69 6e 74 20 30 20 2a 64 65 ebug:print 0 *de
dd40: 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 fault-log-port*
dd50: 22 63 61 73 65 32 2e 31 22 29 0a 09 09 20 20 20 "case2.1")...
dd60: 20 23 74 29 0a 09 09 20 20 20 28 28 61 6e 64 20 #t)... ((and
dd70: 28 6e 75 6c 6c 3f 20 61 2d 77 61 69 74 6f 6e 73 (null? a-waitons
dd80: 29 20 20 20 20 20 20 20 20 3b 3b 20 6e 6f 20 77 ) ;; no w
dd90: 61 69 74 6f 6e 73 20 66 6f 72 20 61 20 62 75 74 aitons for a but
dda0: 20 62 20 68 61 73 20 77 61 69 74 6f 6e 73 0a 09 b has waitons..
ddb0: 09 09 20 28 6e 6f 74 20 28 6e 75 6c 6c 3f 20 62 .. (not (null? b
ddc0: 2d 77 61 69 74 6f 6e 73 29 29 29 0a 09 09 20 20 -waitons)))...
ddd0: 20 20 3b 3b 20 28 64 65 62 75 67 3a 70 72 69 6e ;; (debug:prin
dde0: 74 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 t 0 *default-log
ddf0: 2d 70 6f 72 74 2a 20 22 63 61 73 65 33 22 29 0a -port* "case3").
de00: 09 09 20 20 20 20 23 66 29 0a 09 09 20 20 20 28 .. #f)... (
de10: 28 61 6e 64 20 28 6e 6f 74 20 28 6e 75 6c 6c 3f (and (not (null?
de20: 20 61 2d 77 61 69 74 6f 6e 73 29 29 20 20 3b 3b a-waitons)) ;;
de30: 20 61 20 68 61 73 20 77 61 69 74 6f 6e 73 20 62 a has waitons b
de40: 75 74 20 62 20 64 6f 65 73 20 6e 6f 74 0a 09 09 ut b does not...
de50: 09 20 28 6e 75 6c 6c 3f 20 62 2d 77 61 69 74 6f . (null? b-waito
de60: 6e 73 29 29 20 0a 09 09 20 20 20 20 3b 3b 20 28 ns)) ... ;; (
de70: 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 2a 64 debug:print 0 *d
de80: 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a efault-log-port*
de90: 20 22 63 61 73 65 34 22 29 0a 09 09 20 20 20 20 "case4")...
dea0: 23 74 29 0a 09 09 20 20 20 28 28 6e 6f 74 20 28 #t)... ((not (
deb0: 65 71 3f 20 61 2d 70 72 69 6f 72 69 74 79 20 62 eq? a-priority b
dec0: 2d 70 72 69 6f 72 69 74 79 29 29 20 3b 3b 20 75 -priority)) ;; u
ded0: 73 65 0a 09 09 20 20 20 20 28 3e 20 61 2d 70 72 se... (> a-pr
dee0: 69 6f 72 69 74 79 20 62 2d 70 72 69 6f 72 69 74 iority b-priorit
def0: 79 29 29 0a 09 09 20 20 20 28 65 6c 73 65 0a 09 y))... (else..
df00: 09 20 20 20 20 3b 3b 20 28 64 65 62 75 67 3a 70 . ;; (debug:p
df10: 72 69 6e 74 20 30 20 2a 64 65 66 61 75 6c 74 2d rint 0 *default-
df20: 6c 6f 67 2d 70 6f 72 74 2a 20 22 63 61 73 65 35 log-port* "case5
df30: 22 29 0a 09 09 20 20 20 20 28 73 74 72 69 6e 67 ")... (string
df40: 3e 3f 20 61 20 62 29 29 29 29 29 29 0a 09 20 20 >? a b))))))..
df50: 20 20 20 0a 09 20 20 20 20 20 28 73 6f 72 74 2d .. (sort-
df60: 66 6e 32 0a 09 20 20 20 20 20 20 28 6c 61 6d 62 fn2.. (lamb
df70: 64 61 20 28 61 20 62 29 0a 09 09 28 3e 20 28 6d da (a b)...(> (m
df80: 75 6e 67 65 70 72 69 6f 72 69 74 79 20 28 74 65 ungepriority (te
df90: 73 74 73 3a 74 65 73 74 71 75 65 75 65 2d 67 65 sts:testqueue-ge
dfa0: 74 2d 70 72 69 6f 72 69 74 79 20 28 68 61 73 68 t-priority (hash
dfb0: 2d 74 61 62 6c 65 2d 72 65 66 20 74 65 73 74 2d -table-ref test-
dfc0: 72 65 63 6f 72 64 73 20 61 29 29 29 0a 09 09 20 records a)))...
dfd0: 20 20 28 6d 75 6e 67 65 70 72 69 6f 72 69 74 79 (mungepriority
dfe0: 20 28 74 65 73 74 73 3a 74 65 73 74 71 75 65 75 (tests:testqueu
dff0: 65 2d 67 65 74 2d 70 72 69 6f 72 69 74 79 20 28 e-get-priority (
e000: 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 20 74 hash-table-ref t
e010: 65 73 74 2d 72 65 63 6f 72 64 73 20 62 29 29 29 est-records b)))
e020: 29 29 29 29 0a 09 3b 3b 20 28 6c 65 74 20 28 28 ))))..;; (let ((
e030: 64 6f 74 2d 72 65 73 20 28 74 65 73 74 73 3a 72 dot-res (tests:r
e040: 75 6e 2d 64 6f 74 20 28 74 65 73 74 73 3a 74 65 un-dot (tests:te
e050: 73 74 73 2d 3e 64 6f 74 20 74 65 73 74 2d 72 65 sts->dot test-re
e060: 63 6f 72 64 73 29 20 22 70 6c 61 69 6e 22 29 29 cords) "plain"))
e070: 29 0a 09 3b 3b 20 20 20 28 64 65 62 75 67 3a 70 )..;; (debug:p
e080: 72 69 6e 74 20 22 64 6f 74 2d 72 65 73 3d 22 20 rint "dot-res="
e090: 64 6f 74 2d 72 65 73 29 29 0a 09 3b 3b 20 28 6c dot-res))..;; (l
e0a0: 65 74 20 28 28 64 61 74 61 20 28 6d 61 70 20 63 et ((data (map c
e0b0: 64 72 20 28 66 69 6c 74 65 72 0a 09 3b 3b 20 20 dr (filter..;;
e0c0: 20 20 20 09 09 20 20 28 6c 61 6d 62 64 61 20 28 .. (lambda (
e0d0: 78 29 28 65 71 75 61 6c 3f 20 22 6e 6f 64 65 22 x)(equal? "node"
e0e0: 20 28 63 61 72 20 78 29 29 29 0a 09 3b 3b 20 20 (car x)))..;;
e0f0: 20 20 20 09 09 20 20 28 6d 61 70 20 73 74 72 69 .. (map stri
e100: 6e 67 2d 73 70 6c 69 74 20 28 74 65 73 74 73 3a ng-split (tests:
e110: 65 61 73 79 2d 64 6f 74 20 74 65 73 74 2d 72 65 easy-dot test-re
e120: 63 6f 72 64 73 20 22 70 6c 61 69 6e 22 29 29 29 cords "plain")))
e130: 29 29 29 0a 09 3b 3b 20 20 20 28 6d 61 70 20 63 )))..;; (map c
e140: 61 72 20 28 73 6f 72 74 20 64 61 74 61 20 28 6c ar (sort data (l
e150: 61 6d 62 64 61 20 28 61 20 62 29 0a 09 3b 3b 20 ambda (a b)..;;
e160: 20 20 20 20 09 09 20 20 20 20 28 3e 20 28 73 74 .. (> (st
e170: 72 69 6e 67 2d 3e 6e 75 6d 62 65 72 20 28 63 61 ring->number (ca
e180: 64 64 72 20 61 29 29 28 73 74 72 69 6e 67 2d 3e ddr a))(string->
e190: 6e 75 6d 62 65 72 20 28 63 61 64 64 72 20 62 29 number (caddr b)
e1a0: 29 29 29 29 29 29 0a 09 3b 3b 20 29 29 0a 09 28 ))))))..;; ))..(
e1b0: 73 6f 72 74 20 61 6c 6c 2d 74 65 73 74 73 20 73 sort all-tests s
e1c0: 6f 72 74 2d 66 6e 31 29 29 29 29 20 3b 3b 20 61 ort-fn1)))) ;; a
e1d0: 76 6f 69 64 20 64 65 61 6c 69 6e 67 20 77 69 74 void dealing wit
e1e0: 68 20 64 65 6c 65 74 65 64 20 74 65 73 74 73 2c h deleted tests,
e1f0: 20 6c 6f 6f 6b 20 61 74 20 74 68 65 20 68 61 73 look at the has
e200: 68 20 74 61 62 6c 65 0a 0a 28 64 65 66 69 6e 65 h table..(define
e210: 20 28 74 65 73 74 73 3a 65 61 73 79 2d 64 6f 74 (tests:easy-dot
e220: 20 74 65 73 74 2d 72 65 63 6f 72 64 73 20 6f 75 test-records ou
e230: 74 74 79 70 65 29 0a 20 20 28 6c 65 74 2d 76 61 ttype). (let-va
e240: 6c 75 65 73 20 28 28 28 66 64 20 74 65 6d 70 2d lues (((fd temp-
e250: 70 61 74 68 29 20 28 66 69 6c 65 2d 6d 6b 73 74 path) (file-mkst
e260: 65 6d 70 20 28 63 6f 6e 63 20 22 2f 74 6d 70 2f emp (conc "/tmp/
e270: 22 20 28 63 75 72 72 65 6e 74 2d 75 73 65 72 2d " (current-user-
e280: 6e 61 6d 65 29 20 22 2e 58 58 58 58 58 58 22 29 name) ".XXXXXX")
e290: 29 29 29 0a 20 20 20 20 28 6c 65 74 20 28 28 61 ))). (let ((a
e2a0: 6c 6c 2d 74 65 73 74 6e 61 6d 65 73 20 28 68 61 ll-testnames (ha
e2b0: 73 68 2d 74 61 62 6c 65 2d 6b 65 79 73 20 74 65 sh-table-keys te
e2c0: 73 74 2d 72 65 63 6f 72 64 73 29 29 0a 09 20 20 st-records))..
e2d0: 28 74 65 6d 70 2d 70 6f 72 74 20 20 20 20 20 28 (temp-port (
e2e0: 6f 70 65 6e 2d 6f 75 74 70 75 74 2d 66 69 6c 65 open-output-file
e2f0: 2a 20 66 64 29 29 29 0a 20 20 20 20 20 20 3b 3b * fd))). ;;
e300: 20 28 66 6f 72 6d 61 74 20 74 65 6d 70 2d 70 6f (format temp-po
e310: 72 74 20 22 54 68 69 73 20 66 69 6c 65 20 69 73 rt "This file is
e320: 20 7e 41 2e 7e 25 22 20 74 65 6d 70 2d 70 61 74 ~A.~%" temp-pat
e330: 68 29 0a 20 20 20 20 20 20 28 66 6f 72 6d 61 74 h). (format
e340: 20 74 65 6d 70 2d 70 6f 72 74 20 22 64 69 67 72 temp-port "digr
e350: 61 70 68 20 74 65 73 74 73 20 7b 5c 6e 22 29 0a aph tests {\n").
e360: 20 20 20 20 20 20 28 66 6f 72 6d 61 74 20 74 65 (format te
e370: 6d 70 2d 70 6f 72 74 20 22 20 20 73 69 7a 65 3d mp-port " size=
e380: 34 2c 38 5c 6e 22 29 0a 20 20 20 20 20 20 3b 3b 4,8\n"). ;;
e390: 20 28 66 6f 72 6d 61 74 20 74 65 6d 70 2d 70 6f (format temp-po
e3a0: 72 74 20 22 20 20 20 73 70 6c 69 6e 65 73 3d 6e rt " splines=n
e3b0: 6f 6e 65 5c 6e 22 29 0a 20 20 20 20 20 20 28 66 one\n"). (f
e3c0: 6f 72 2d 65 61 63 68 0a 20 20 20 20 20 20 20 28 or-each. (
e3d0: 6c 61 6d 62 64 61 20 28 74 65 73 74 6e 61 6d 65 lambda (testname
e3e0: 29 0a 09 20 28 6c 65 74 2a 20 28 28 74 65 73 74 ).. (let* ((test
e3f0: 72 65 63 20 28 68 61 73 68 2d 74 61 62 6c 65 2d rec (hash-table-
e400: 72 65 66 20 74 65 73 74 2d 72 65 63 6f 72 64 73 ref test-records
e410: 20 74 65 73 74 6e 61 6d 65 29 29 0a 09 09 28 77 testname))...(w
e420: 61 69 74 6f 6e 73 20 28 6f 72 20 28 74 65 73 74 aitons (or (test
e430: 73 3a 74 65 73 74 71 75 65 75 65 2d 67 65 74 2d s:testqueue-get-
e440: 77 61 69 74 6f 6e 73 20 74 65 73 74 72 65 63 29 waitons testrec)
e450: 20 27 28 29 29 29 29 0a 09 20 20 20 28 66 6f 72 '()))).. (for
e460: 2d 65 61 63 68 0a 09 20 20 20 20 28 6c 61 6d 62 -each.. (lamb
e470: 64 61 20 28 77 61 69 74 6f 6e 29 0a 09 20 20 20 da (waiton)..
e480: 20 20 20 28 66 6f 72 6d 61 74 20 74 65 6d 70 2d (format temp-
e490: 70 6f 72 74 20 28 63 6f 6e 63 20 22 20 20 20 22 port (conc " "
e4a0: 20 77 61 69 74 6f 6e 20 22 20 2d 3e 20 22 20 74 waiton " -> " t
e4b0: 65 73 74 6e 61 6d 65 20 22 20 5b 73 70 6c 69 6e estname " [splin
e4c0: 65 73 3d 6f 72 74 68 6f 5d 5c 6e 22 29 29 29 0a es=ortho]\n"))).
e4d0: 09 20 20 20 20 77 61 69 74 6f 6e 73 29 29 29 0a . waitons))).
e4e0: 20 20 20 20 20 20 20 61 6c 6c 2d 74 65 73 74 6e all-testn
e4f0: 61 6d 65 73 29 0a 20 20 20 20 20 20 28 66 6f 72 ames). (for
e500: 6d 61 74 20 74 65 6d 70 2d 70 6f 72 74 20 22 7d mat temp-port "}
e510: 5c 6e 22 29 0a 20 20 20 20 20 20 28 63 6c 6f 73 \n"). (clos
e520: 65 2d 6f 75 74 70 75 74 2d 70 6f 72 74 20 74 65 e-output-port te
e530: 6d 70 2d 70 6f 72 74 29 0a 20 20 20 20 20 20 28 mp-port). (
e540: 77 69 74 68 2d 69 6e 70 75 74 2d 66 72 6f 6d 2d with-input-from-
e550: 70 69 70 65 0a 20 20 20 20 20 20 20 28 63 6f 6e pipe. (con
e560: 63 20 22 65 6e 76 20 2d 69 20 50 41 54 48 3d 24 c "env -i PATH=$
e570: 50 41 54 48 20 64 6f 74 20 2d 54 22 20 6f 75 74 PATH dot -T" out
e580: 74 79 70 65 20 22 20 3c 20 22 20 74 65 6d 70 2d type " < " temp-
e590: 70 61 74 68 29 0a 20 20 20 20 20 20 20 28 6c 61 path). (la
e5a0: 6d 62 64 61 20 28 29 0a 09 20 28 6c 65 74 20 28 mbda ().. (let (
e5b0: 28 72 65 73 20 28 72 65 61 64 2d 6c 69 6e 65 73 (res (read-lines
e5c0: 29 29 29 0a 09 20 20 20 3b 3b 20 28 64 65 6c 65 ))).. ;; (dele
e5d0: 74 65 2d 66 69 6c 65 20 74 65 6d 70 2d 70 61 74 te-file temp-pat
e5e0: 68 29 0a 09 20 20 20 72 65 73 29 29 29 29 29 29 h).. res))))))
e5f0: 0a 0a 28 64 65 66 69 6e 65 20 28 74 65 73 74 73 ..(define (tests
e600: 3a 77 72 69 74 65 2d 64 6f 74 2d 66 69 6c 65 20 :write-dot-file
e610: 74 65 73 74 2d 72 65 63 6f 72 64 73 20 66 6e 61 test-records fna
e620: 6d 65 20 73 69 7a 65 78 20 73 69 7a 65 79 29 0a me sizex sizey).
e630: 20 20 28 69 66 20 28 66 69 6c 65 2d 77 72 69 74 (if (file-writ
e640: 65 2d 61 63 63 65 73 73 3f 20 28 70 61 74 68 6e e-access? (pathn
e650: 61 6d 65 2d 64 69 72 65 63 74 6f 72 79 20 66 6e ame-directory fn
e660: 61 6d 65 29 29 0a 20 20 20 20 20 20 28 77 69 74 ame)). (wit
e670: 68 2d 6f 75 74 70 75 74 2d 74 6f 2d 66 69 6c 65 h-output-to-file
e680: 20 66 6e 61 6d 65 0a 09 28 6c 61 6d 62 64 61 20 fname..(lambda
e690: 28 29 0a 09 20 20 28 6d 61 70 20 70 72 69 6e 74 ().. (map print
e6a0: 20 28 74 65 73 74 73 3a 74 65 73 74 73 2d 3e 64 (tests:tests->d
e6b0: 6f 74 20 74 65 73 74 2d 72 65 63 6f 72 64 73 20 ot test-records
e6c0: 73 69 7a 65 78 20 73 69 7a 65 79 29 29 29 29 29 sizex sizey)))))
e6d0: 29 0a 0a 28 64 65 66 69 6e 65 20 28 74 65 73 74 )..(define (test
e6e0: 73 3a 74 65 73 74 73 2d 3e 64 6f 74 20 74 65 73 s:tests->dot tes
e6f0: 74 2d 72 65 63 6f 72 64 73 20 73 69 7a 65 78 20 t-records sizex
e700: 73 69 7a 65 79 29 0a 20 20 28 6c 65 74 20 28 28 sizey). (let ((
e710: 61 6c 6c 2d 74 65 73 74 6e 61 6d 65 73 20 28 68 all-testnames (h
e720: 61 73 68 2d 74 61 62 6c 65 2d 6b 65 79 73 20 74 ash-table-keys t
e730: 65 73 74 2d 72 65 63 6f 72 64 73 29 29 29 0a 20 est-records))).
e740: 20 20 20 28 69 66 20 28 6e 75 6c 6c 3f 20 61 6c (if (null? al
e750: 6c 2d 74 65 73 74 6e 61 6d 65 73 29 0a 09 27 28 l-testnames)..'(
e760: 29 0a 09 28 6c 65 74 20 6c 6f 6f 70 20 28 28 68 )..(let loop ((h
e770: 65 64 20 28 63 61 72 20 61 6c 6c 2d 74 65 73 74 ed (car all-test
e780: 6e 61 6d 65 73 29 29 0a 09 09 20 20 20 28 74 61 names))... (ta
e790: 6c 20 28 63 64 72 20 61 6c 6c 2d 74 65 73 74 6e l (cdr all-testn
e7a0: 61 6d 65 73 29 29 0a 09 09 20 20 20 28 72 65 73 ames))... (res
e7b0: 20 28 6c 69 73 74 20 22 64 69 67 72 61 70 68 20 (list "digraph
e7c0: 74 65 73 74 73 20 7b 22 0a 09 09 09 20 20 20 20 tests {"....
e7d0: 20 20 28 63 6f 6e 63 20 22 20 73 69 7a 65 3d 5c (conc " size=\
e7e0: 22 22 20 28 6f 72 20 73 69 7a 65 78 20 31 31 29 "" (or sizex 11)
e7f0: 20 22 2c 22 20 28 6f 72 20 73 69 7a 65 79 20 31 "," (or sizey 1
e800: 31 29 20 22 5c 22 3b 22 29 0a 09 09 09 20 20 20 1) "\";")....
e810: 20 20 20 22 20 72 61 74 69 6f 3d 30 2e 39 35 3b " ratio=0.95;
e820: 22 0a 09 09 09 20 20 20 20 20 20 29 29 29 0a 09 ".... )))..
e830: 20 20 28 6c 65 74 2a 20 28 28 74 65 73 74 72 65 (let* ((testre
e840: 63 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 c (hash-table-re
e850: 66 20 74 65 73 74 2d 72 65 63 6f 72 64 73 20 68 f test-records h
e860: 65 64 29 29 0a 09 09 20 28 77 61 69 74 6f 6e 73 ed))... (waitons
e870: 20 28 6f 72 20 28 74 65 73 74 73 3a 74 65 73 74 (or (tests:test
e880: 71 75 65 75 65 2d 67 65 74 2d 77 61 69 74 6f 6e queue-get-waiton
e890: 73 20 74 65 73 74 72 65 63 29 20 27 28 29 29 29 s testrec) '()))
e8a0: 0a 09 09 20 28 6e 65 77 72 65 73 20 20 28 61 70 ... (newres (ap
e8b0: 70 65 6e 64 20 72 65 73 0a 09 09 09 09 20 20 28 pend res..... (
e8c0: 69 66 20 28 6e 75 6c 6c 3f 20 77 61 69 74 6f 6e if (null? waiton
e8d0: 73 29 0a 09 09 09 09 20 20 20 20 20 20 28 6c 69 s)..... (li
e8e0: 73 74 20 28 63 6f 6e 63 20 22 20 20 20 5c 22 22 st (conc " \""
e8f0: 20 68 65 64 20 22 5c 22 20 5b 73 68 61 70 65 3d hed "\" [shape=
e900: 62 6f 78 5d 3b 22 29 29 0a 09 09 09 09 20 20 20 box];")).....
e910: 20 20 20 28 6d 61 70 20 28 6c 61 6d 62 64 61 20 (map (lambda
e920: 28 77 61 69 74 6f 6e 29 0a 09 09 09 09 09 20 20 (waiton)......
e930: 20 20 20 28 63 6f 6e 63 20 22 20 20 20 5c 22 22 (conc " \""
e940: 20 77 61 69 74 6f 6e 20 22 5c 22 20 2d 3e 20 5c waiton "\" -> \
e950: 22 22 20 68 65 64 20 22 5c 22 20 5b 73 68 61 70 "" hed "\" [shap
e960: 65 3d 62 6f 78 5d 3b 22 29 29 0a 09 09 09 09 09 e=box];"))......
e970: 20 20 20 77 61 69 74 6f 6e 73 29 0a 09 09 09 09 waitons).....
e980: 20 20 20 20 20 20 29 29 29 29 0a 09 20 20 20 20 ))))..
e990: 28 69 66 20 28 6e 75 6c 6c 3f 20 74 61 6c 29 0a (if (null? tal).
e9a0: 09 09 28 61 70 70 65 6e 64 20 6e 65 77 72 65 73 ..(append newres
e9b0: 20 28 6c 69 73 74 20 22 7d 22 29 29 0a 09 09 28 (list "}"))...(
e9c0: 6c 6f 6f 70 20 28 63 61 72 20 74 61 6c 29 28 63 loop (car tal)(c
e9d0: 64 72 20 74 61 6c 29 20 6e 65 77 72 65 73 29 0a dr tal) newres).
e9e0: 09 09 29 29 29 29 29 29 0a 0a 3b 3b 20 28 74 65 ..))))))..;; (te
e9f0: 73 74 73 3a 72 75 6e 2d 64 6f 74 20 28 6c 69 73 sts:run-dot (lis
ea00: 74 20 22 64 69 67 72 61 70 68 20 74 65 73 74 73 t "digraph tests
ea10: 20 7b 22 20 22 61 20 2d 3e 20 62 22 20 22 7d 22 {" "a -> b" "}"
ea20: 29 20 22 70 6c 61 69 6e 22 29 0a 0a 28 64 65 66 ) "plain")..(def
ea30: 69 6e 65 20 28 74 65 73 74 73 3a 72 75 6e 2d 64 ine (tests:run-d
ea40: 6f 74 20 69 6e 64 61 74 20 6f 75 74 74 79 70 65 ot indat outtype
ea50: 29 20 3b 3b 20 6f 75 74 74 79 70 65 20 69 73 20 ) ;; outtype is
ea60: 70 6c 61 69 6e 2c 20 66 69 67 2c 20 64 6f 74 2c plain, fig, dot,
ea70: 20 65 74 63 2e 20 68 74 74 70 3a 2f 2f 77 77 77 etc. http://www
ea80: 2e 67 72 61 70 68 76 69 7a 2e 6f 72 67 2f 63 6f .graphviz.org/co
ea90: 6e 74 65 6e 74 2f 6f 75 74 70 75 74 2d 66 6f 72 ntent/output-for
eaa0: 6d 61 74 73 0a 20 20 28 6c 65 74 2d 76 61 6c 75 mats. (let-valu
eab0: 65 73 20 28 28 28 69 6e 70 20 6f 75 70 20 70 69 es (((inp oup pi
eac0: 64 29 28 70 72 6f 63 65 73 73 20 22 65 6e 76 20 d)(process "env
ead0: 2d 69 20 50 41 54 48 3d 24 50 41 54 48 20 64 6f -i PATH=$PATH do
eae0: 74 22 20 28 6c 69 73 74 20 22 2d 54 22 20 6f 75 t" (list "-T" ou
eaf0: 74 74 79 70 65 29 29 29 29 0a 20 20 20 20 28 77 ttype)))). (w
eb00: 69 74 68 2d 6f 75 74 70 75 74 2d 74 6f 2d 70 6f ith-output-to-po
eb10: 72 74 20 6f 75 70 0a 20 20 20 20 20 20 28 6c 61 rt oup. (la
eb20: 6d 62 64 61 20 28 29 0a 09 28 6d 61 70 20 70 72 mbda ()..(map pr
eb30: 69 6e 74 20 69 6e 64 61 74 29 29 29 0a 20 20 20 int indat))).
eb40: 20 28 63 6c 6f 73 65 2d 6f 75 74 70 75 74 2d 70 (close-output-p
eb50: 6f 72 74 20 6f 75 70 29 0a 20 20 20 20 28 6c 65 ort oup). (le
eb60: 74 20 28 28 72 65 73 20 28 77 69 74 68 2d 69 6e t ((res (with-in
eb70: 70 75 74 2d 66 72 6f 6d 2d 70 6f 72 74 20 69 6e put-from-port in
eb80: 70 0a 09 09 20 28 6c 61 6d 62 64 61 20 28 29 0a p... (lambda ().
eb90: 09 09 20 20 20 28 72 65 61 64 2d 6c 69 6e 65 73 .. (read-lines
eba0: 29 29 29 29 29 0a 20 20 20 20 20 20 28 63 6c 6f ))))). (clo
ebb0: 73 65 2d 69 6e 70 75 74 2d 70 6f 72 74 20 69 6e se-input-port in
ebc0: 70 29 0a 20 20 20 20 20 20 72 65 73 29 29 29 0a p). res))).
ebd0: 0a 3b 3b 20 72 65 61 64 20 64 61 74 61 20 66 72 .;; read data fr
ebe0: 6f 6d 20 74 6d 70 20 66 69 6c 65 20 6f 72 20 63 om tmp file or c
ebf0: 72 65 61 74 65 20 69 66 20 6e 6f 74 20 65 78 69 reate if not exi
ec00: 73 74 73 0a 3b 3b 20 69 66 20 65 78 69 73 74 73 sts.;; if exists
ec10: 20 72 65 67 65 6e 20 69 6e 20 62 61 63 6b 67 72 regen in backgr
ec20: 6f 75 6e 64 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 ound.;;.(define
ec30: 28 74 65 73 74 73 3a 6c 61 7a 79 2d 64 6f 74 20 (tests:lazy-dot
ec40: 74 65 73 74 72 65 63 6f 72 64 73 20 20 6f 75 74 testrecords out
ec50: 74 79 70 65 20 73 69 7a 65 78 20 73 69 7a 65 79 type sizex sizey
ec60: 29 0a 20 20 28 6c 65 74 20 28 28 64 66 69 6c 65 ). (let ((dfile
ec70: 20 28 63 6f 6e 63 20 22 2f 74 6d 70 2f 2e 22 20 (conc "/tmp/."
ec80: 28 63 75 72 72 65 6e 74 2d 75 73 65 72 2d 6e 61 (current-user-na
ec90: 6d 65 29 20 22 2d 22 20 28 73 65 72 76 65 72 3a me) "-" (server:
eca0: 6d 6b 2d 73 69 67 6e 61 74 75 72 65 29 20 22 2e mk-signature) ".
ecb0: 64 6f 74 22 29 29 0a 09 28 66 6e 61 6d 65 20 28 dot"))..(fname (
ecc0: 63 6f 6e 63 20 22 2f 74 6d 70 2f 2e 22 20 28 63 conc "/tmp/." (c
ecd0: 75 72 72 65 6e 74 2d 75 73 65 72 2d 6e 61 6d 65 urrent-user-name
ece0: 29 20 22 2d 22 20 28 73 65 72 76 65 72 3a 6d 6b ) "-" (server:mk
ecf0: 2d 73 69 67 6e 61 74 75 72 65 29 20 22 2e 64 6f -signature) ".do
ed00: 74 64 61 74 22 29 29 29 0a 20 20 20 20 28 74 65 tdat"))). (te
ed10: 73 74 73 3a 77 72 69 74 65 2d 64 6f 74 2d 66 69 sts:write-dot-fi
ed20: 6c 65 20 74 65 73 74 72 65 63 6f 72 64 73 20 64 le testrecords d
ed30: 66 69 6c 65 20 73 69 7a 65 78 20 73 69 7a 65 79 file sizex sizey
ed40: 29 0a 20 20 20 20 28 69 66 20 28 66 69 6c 65 2d ). (if (file-
ed50: 65 78 69 73 74 73 3f 20 66 6e 61 6d 65 29 0a 09 exists? fname)..
ed60: 28 6c 65 74 20 28 28 72 65 73 20 28 77 69 74 68 (let ((res (with
ed70: 2d 69 6e 70 75 74 2d 66 72 6f 6d 2d 66 69 6c 65 -input-from-file
ed80: 20 66 6e 61 6d 65 0a 09 09 20 20 20 20 20 28 6c fname... (l
ed90: 61 6d 62 64 61 20 28 29 0a 09 09 20 20 20 20 20 ambda ()...
eda0: 20 20 28 72 65 61 64 2d 6c 69 6e 65 73 29 29 29 (read-lines)))
edb0: 29 29 0a 09 20 20 28 73 79 73 74 65 6d 20 28 63 )).. (system (c
edc0: 6f 6e 63 20 22 65 6e 76 20 2d 69 20 50 41 54 48 onc "env -i PATH
edd0: 3d 24 50 41 54 48 20 64 6f 74 20 2d 54 20 22 20 =$PATH dot -T "
ede0: 6f 75 74 74 79 70 65 20 22 20 3c 20 22 20 64 66 outtype " < " df
edf0: 69 6c 65 20 22 20 3e 20 22 20 66 6e 61 6d 65 20 ile " > " fname
ee00: 22 26 22 29 29 0a 09 20 20 72 65 73 29 0a 09 28 "&")).. res)..(
ee10: 62 65 67 69 6e 0a 09 20 20 28 73 79 73 74 65 6d begin.. (system
ee20: 20 28 63 6f 6e 63 20 22 65 6e 76 20 2d 69 20 50 (conc "env -i P
ee30: 41 54 48 3d 24 50 41 54 48 20 64 6f 74 20 2d 54 ATH=$PATH dot -T
ee40: 20 22 20 6f 75 74 74 79 70 65 20 22 20 3c 20 22 " outtype " < "
ee50: 20 64 66 69 6c 65 20 22 20 3e 20 22 20 66 6e 61 dfile " > " fna
ee60: 6d 65 29 29 0a 09 20 20 28 77 69 74 68 2d 69 6e me)).. (with-in
ee70: 70 75 74 2d 66 72 6f 6d 2d 66 69 6c 65 20 66 6e put-from-file fn
ee80: 61 6d 65 0a 09 20 20 20 20 28 6c 61 6d 62 64 61 ame.. (lambda
ee90: 20 28 29 0a 09 20 20 20 20 20 20 28 72 65 61 64 ().. (read
eea0: 2d 6c 69 6e 65 73 29 29 29 29 29 29 29 0a 09 20 -lines)))))))..
eeb0: 20 0a 0a 3b 3b 20 66 6f 72 20 65 61 63 68 20 74 ..;; for each t
eec0: 65 73 74 3a 0a 3b 3b 20 20 20 0a 28 64 65 66 69 est:.;; .(defi
eed0: 6e 65 20 28 74 65 73 74 73 3a 66 69 6c 74 65 72 ne (tests:filter
eee0: 2d 6e 6f 6e 2d 72 75 6e 6e 61 62 6c 65 20 72 75 -non-runnable ru
eef0: 6e 2d 69 64 20 74 65 73 74 6b 65 79 6e 61 6d 65 n-id testkeyname
ef00: 73 20 74 65 73 74 72 65 63 6f 72 64 73 68 61 73 s testrecordshas
ef10: 68 29 0a 20 20 28 6c 65 74 20 28 28 72 75 6e 6e h). (let ((runn
ef20: 61 62 6c 65 73 20 27 28 29 29 29 0a 20 20 20 20 ables '())).
ef30: 28 66 6f 72 2d 65 61 63 68 0a 20 20 20 20 20 28 (for-each. (
ef40: 6c 61 6d 62 64 61 20 28 74 65 73 74 6b 65 79 6e lambda (testkeyn
ef50: 61 6d 65 29 0a 20 20 20 20 20 20 20 28 6c 65 74 ame). (let
ef60: 2a 20 28 28 74 65 73 74 2d 72 65 63 6f 72 64 20 * ((test-record
ef70: 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 20 (hash-table-ref
ef80: 74 65 73 74 72 65 63 6f 72 64 73 68 61 73 68 20 testrecordshash
ef90: 74 65 73 74 6b 65 79 6e 61 6d 65 29 29 0a 09 20 testkeyname))..
efa0: 20 20 20 20 20 28 74 65 73 74 2d 6e 61 6d 65 20 (test-name
efb0: 20 20 28 74 65 73 74 73 3a 74 65 73 74 71 75 65 (tests:testque
efc0: 75 65 2d 67 65 74 2d 74 65 73 74 6e 61 6d 65 20 ue-get-testname
efd0: 20 74 65 73 74 2d 72 65 63 6f 72 64 29 29 0a 09 test-record))..
efe0: 20 20 20 20 20 20 28 69 74 65 6d 64 61 74 20 20 (itemdat
eff0: 20 20 20 28 74 65 73 74 73 3a 74 65 73 74 71 75 (tests:testqu
f000: 65 75 65 2d 67 65 74 2d 69 74 65 6d 64 61 74 20 eue-get-itemdat
f010: 20 20 74 65 73 74 2d 72 65 63 6f 72 64 29 29 0a test-record)).
f020: 09 20 20 20 20 20 20 28 69 74 65 6d 2d 70 61 74 . (item-pat
f030: 68 20 20 20 28 74 65 73 74 73 3a 74 65 73 74 71 h (tests:testq
f040: 75 65 75 65 2d 67 65 74 2d 69 74 65 6d 5f 70 61 ueue-get-item_pa
f050: 74 68 20 74 65 73 74 2d 72 65 63 6f 72 64 29 29 th test-record))
f060: 0a 09 20 20 20 20 20 20 28 77 61 69 74 6f 6e 73 .. (waitons
f070: 20 20 20 20 20 28 74 65 73 74 73 3a 74 65 73 74 (tests:test
f080: 71 75 65 75 65 2d 67 65 74 2d 77 61 69 74 6f 6e queue-get-waiton
f090: 73 20 20 20 74 65 73 74 2d 72 65 63 6f 72 64 29 s test-record)
f0a0: 29 0a 09 20 20 20 20 20 20 28 6b 65 65 70 2d 74 ).. (keep-t
f0b0: 65 73 74 20 20 20 23 74 29 0a 09 20 20 20 20 20 est #t)..
f0c0: 20 28 74 65 73 74 2d 69 64 20 20 20 20 20 28 72 (test-id (r
f0d0: 6d 74 3a 67 65 74 2d 74 65 73 74 2d 69 64 20 72 mt:get-test-id r
f0e0: 75 6e 2d 69 64 20 74 65 73 74 2d 6e 61 6d 65 20 un-id test-name
f0f0: 69 74 65 6d 2d 70 61 74 68 29 29 0a 09 20 20 20 item-path))..
f100: 20 20 20 28 74 64 61 74 20 20 20 20 20 20 20 20 (tdat
f110: 28 72 6d 74 3a 67 65 74 2d 74 65 73 74 69 6e 66 (rmt:get-testinf
f120: 6f 2d 73 74 61 74 65 2d 73 74 61 74 75 73 20 72 o-state-status r
f130: 75 6e 2d 69 64 20 74 65 73 74 2d 69 64 29 29 29 un-id test-id)))
f140: 20 3b 3b 20 28 63 64 62 3a 67 65 74 2d 74 65 73 ;; (cdb:get-tes
f150: 74 2d 69 6e 66 6f 2d 62 79 2d 69 64 20 2a 72 75 t-info-by-id *ru
f160: 6e 72 65 6d 6f 74 65 2a 20 74 65 73 74 2d 69 64 nremote* test-id
f170: 29 29 29 0a 09 20 28 69 66 20 74 64 61 74 0a 09 ))).. (if tdat..
f180: 20 20 20 20 20 28 62 65 67 69 6e 0a 09 20 20 20 (begin..
f190: 20 20 20 20 3b 3b 20 4c 6f 6f 6b 20 61 74 20 74 ;; Look at t
f1a0: 68 65 20 74 65 73 74 20 73 74 61 74 65 20 61 6e he test state an
f1b0: 64 20 73 74 61 74 75 73 0a 09 20 20 20 20 20 20 d status..
f1c0: 20 28 69 66 20 28 6f 72 20 28 61 6e 64 20 28 6d (if (or (and (m
f1d0: 65 6d 62 65 72 20 28 64 62 3a 74 65 73 74 2d 67 ember (db:test-g
f1e0: 65 74 2d 73 74 61 74 75 73 20 74 64 61 74 29 20 et-status tdat)
f1f0: 0a 09 09 09 09 20 20 20 20 27 28 22 50 41 53 53 ..... '("PASS
f200: 22 20 22 57 41 52 4e 22 20 22 57 41 49 56 45 44 " "WARN" "WAIVED
f210: 22 20 22 43 48 45 43 4b 22 20 22 53 4b 49 50 22 " "CHECK" "SKIP"
f220: 29 29 0a 09 09 09 20 20 20 20 28 65 71 75 61 6c )).... (equal
f230: 3f 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 73 ? (db:test-get-s
f240: 74 61 74 65 20 74 64 61 74 29 20 22 43 4f 4d 50 tate tdat) "COMP
f250: 4c 45 54 45 44 22 29 29 0a 09 09 20 20 20 20 20 LETED"))...
f260: 20 20 28 6d 65 6d 62 65 72 20 28 64 62 3a 74 65 (member (db:te
f270: 73 74 2d 67 65 74 2d 73 74 61 74 65 20 74 64 61 st-get-state tda
f280: 74 29 0a 09 09 09 09 20 20 20 20 27 28 22 49 4e t)..... '("IN
f290: 43 4f 4d 50 4c 45 54 45 22 20 22 4b 49 4c 4c 45 COMPLETE" "KILLE
f2a0: 44 22 29 29 29 0a 09 09 20 20 20 28 73 65 74 21 D")))... (set!
f2b0: 20 6b 65 65 70 2d 74 65 73 74 20 23 66 29 29 0a keep-test #f)).
f2c0: 0a 09 20 20 20 20 20 20 20 3b 3b 20 65 78 61 6d .. ;; exam
f2d0: 69 6e 65 20 77 61 69 74 6f 6e 73 20 66 6f 72 20 ine waitons for
f2e0: 61 6e 79 20 66 61 69 6c 73 2e 20 49 66 20 69 74 any fails. If it
f2f0: 20 69 73 20 46 41 49 4c 20 6f 72 20 49 4e 43 4f is FAIL or INCO
f300: 4d 50 4c 45 54 45 20 74 68 65 6e 20 65 6c 69 6d MPLETE then elim
f310: 69 6e 61 74 65 20 74 68 69 73 20 74 65 73 74 0a inate this test.
f320: 09 20 20 20 20 20 20 20 3b 3b 20 66 72 6f 6d 20 . ;; from
f330: 74 68 65 20 72 75 6e 6e 61 62 6c 65 20 6c 69 73 the runnable lis
f340: 74 0a 09 20 20 20 20 20 20 20 28 69 66 20 6b 65 t.. (if ke
f350: 65 70 2d 74 65 73 74 0a 09 09 20 20 20 28 66 6f ep-test... (fo
f360: 72 2d 65 61 63 68 20 28 6c 61 6d 62 64 61 20 28 r-each (lambda (
f370: 77 61 69 74 6f 6e 29 0a 09 09 09 20 20 20 20 20 waiton)....
f380: 20 20 3b 3b 20 66 6f 72 20 6e 6f 77 20 77 65 20 ;; for now we
f390: 61 72 65 20 77 61 69 74 69 6e 67 20 6f 6e 6c 79 are waiting only
f3a0: 20 6f 6e 20 74 68 65 20 70 61 72 65 6e 74 20 74 on the parent t
f3b0: 65 73 74 0a 09 09 09 20 20 20 20 20 20 20 28 6c est.... (l
f3c0: 65 74 2a 20 28 28 70 61 72 65 6e 74 2d 74 65 73 et* ((parent-tes
f3d0: 74 2d 69 64 20 28 72 6d 74 3a 67 65 74 2d 74 65 t-id (rmt:get-te
f3e0: 73 74 2d 69 64 20 72 75 6e 2d 69 64 20 77 61 69 st-id run-id wai
f3f0: 74 6f 6e 20 22 22 29 29 0a 09 09 09 09 20 20 20 ton "")).....
f400: 20 20 20 28 77 74 64 61 74 20 20 20 20 20 20 20 (wtdat
f410: 20 20 20 28 72 6d 74 3a 67 65 74 2d 74 65 73 74 (rmt:get-test
f420: 69 6e 66 6f 2d 73 74 61 74 65 2d 73 74 61 74 75 info-state-statu
f430: 73 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 69 64 s run-id test-id
f440: 29 29 29 20 3b 3b 20 28 63 64 62 3a 67 65 74 2d ))) ;; (cdb:get-
f450: 74 65 73 74 2d 69 6e 66 6f 2d 62 79 2d 69 64 20 test-info-by-id
f460: 2a 72 75 6e 72 65 6d 6f 74 65 2a 20 74 65 73 74 *runremote* test
f470: 2d 69 64 29 29 29 0a 09 09 09 09 20 28 69 66 20 -id)))..... (if
f480: 28 6f 72 20 28 61 6e 64 20 28 65 71 75 61 6c 3f (or (and (equal?
f490: 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 73 74 (db:test-get-st
f4a0: 61 74 65 20 77 74 64 61 74 29 20 22 43 4f 4d 50 ate wtdat) "COMP
f4b0: 4c 45 54 45 44 22 29 0a 09 09 09 09 09 20 20 20 LETED")......
f4c0: 20 20 20 28 6d 65 6d 62 65 72 20 28 64 62 3a 74 (member (db:t
f4d0: 65 73 74 2d 67 65 74 2d 73 74 61 74 75 73 20 77 est-get-status w
f4e0: 74 64 61 74 29 20 27 28 22 46 41 49 4c 22 20 22 tdat) '("FAIL" "
f4f0: 41 42 4f 52 54 22 29 29 29 0a 09 09 09 09 09 20 ABORT")))......
f500: 28 6d 65 6d 62 65 72 20 28 64 62 3a 74 65 73 74 (member (db:test
f510: 2d 67 65 74 2d 73 74 61 74 75 73 20 77 74 64 61 -get-status wtda
f520: 74 29 20 20 27 28 22 4b 49 4c 4c 45 44 22 29 29 t) '("KILLED"))
f530: 0a 09 09 09 09 09 20 28 6d 65 6d 62 65 72 20 28 ...... (member (
f540: 64 62 3a 74 65 73 74 2d 67 65 74 2d 73 74 61 74 db:test-get-stat
f550: 65 20 77 74 64 61 74 29 20 20 20 27 28 22 49 4e e wtdat) '("IN
f560: 43 4f 4d 50 45 54 45 22 29 29 29 0a 09 09 09 09 COMPETE"))).....
f570: 20 3b 3b 20 28 69 66 20 28 6f 72 20 28 6d 65 6d ;; (if (or (mem
f580: 62 65 72 20 28 64 62 3a 74 65 73 74 2d 67 65 74 ber (db:test-get
f590: 2d 73 74 61 74 75 73 20 77 74 64 61 74 29 0a 09 -status wtdat)..
f5a0: 09 09 09 20 3b 3b 20 20 20 20 20 20 20 20 09 20 ... ;; .
f5b0: 27 28 22 46 41 49 4c 22 20 22 4b 49 4c 4c 45 44 '("FAIL" "KILLED
f5c0: 22 29 29 0a 09 09 09 09 20 3b 3b 20 20 20 20 20 "))..... ;;
f5d0: 20 20 20 20 28 6d 65 6d 62 65 72 20 28 64 62 3a (member (db:
f5e0: 74 65 73 74 2d 67 65 74 2d 73 74 61 74 65 20 77 test-get-state w
f5f0: 74 64 61 74 29 0a 09 09 09 09 20 3b 3b 20 20 20 tdat)..... ;;
f600: 20 20 20 20 20 09 20 27 28 22 49 4e 43 4f 4d 50 . '("INCOMP
f610: 45 54 45 22 29 29 29 0a 09 09 09 09 20 20 20 20 ETE"))).....
f620: 20 28 73 65 74 21 20 6b 65 65 70 2d 74 65 73 74 (set! keep-test
f630: 20 23 66 29 29 29 29 20 3b 3b 20 6e 6f 20 70 6f #f)))) ;; no po
f640: 69 6e 74 20 69 6e 20 72 75 6e 6e 69 6e 67 20 74 int in running t
f650: 68 69 73 20 6f 6e 65 20 61 67 61 69 6e 0a 09 09 his one again...
f660: 09 20 20 20 20 20 77 61 69 74 6f 6e 73 29 29 29 . waitons)))
f670: 29 0a 09 20 28 69 66 20 6b 65 65 70 2d 74 65 73 ).. (if keep-tes
f680: 74 20 28 73 65 74 21 20 72 75 6e 6e 61 62 6c 65 t (set! runnable
f690: 73 20 28 63 6f 6e 73 20 74 65 73 74 6b 65 79 6e s (cons testkeyn
f6a0: 61 6d 65 20 72 75 6e 6e 61 62 6c 65 73 29 29 29 ame runnables)))
f6b0: 29 29 0a 20 20 20 20 20 74 65 73 74 6b 65 79 6e )). testkeyn
f6c0: 61 6d 65 73 29 0a 20 20 20 20 72 75 6e 6e 61 62 ames). runnab
f6d0: 6c 65 73 29 29 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d les))..;;=======
f6e0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
f6f0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
f700: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
f710: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a ===============.
f720: 3b 3b 20 72 65 66 61 63 74 6f 72 69 6e 67 20 74 ;; refactoring t
f730: 68 69 73 20 62 6c 6f 63 6b 20 69 6e 74 6f 20 74 his block into t
f740: 65 73 74 73 3a 67 65 74 2d 66 75 6c 6c 2d 64 61 ests:get-full-da
f750: 74 61 20 66 72 6f 6d 20 6c 69 6e 65 20 32 36 33 ta from line 263
f760: 20 6f 66 20 72 75 6e 73 2e 73 63 6d 0a 3b 3b 3d of runs.scm.;;=
f770: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
f780: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
f790: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
f7a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
f7b0: 3d 3d 3d 3d 3d 0a 3b 3b 20 68 65 64 20 69 73 20 =====.;; hed is
f7c0: 74 68 65 20 74 65 73 74 20 6e 61 6d 65 0a 3b 3b the test name.;;
f7d0: 20 74 65 73 74 2d 72 65 63 6f 72 64 73 20 69 73 test-records is
f7e0: 20 61 20 68 61 73 68 20 6f 66 20 74 65 73 74 2d a hash of test-
f7f0: 6e 61 6d 65 20 3d 3e 20 74 65 73 74 20 72 65 63 name => test rec
f800: 6f 72 64 0a 28 64 65 66 69 6e 65 20 28 74 65 73 ord.(define (tes
f810: 74 73 3a 67 65 74 2d 66 75 6c 6c 2d 64 61 74 61 ts:get-full-data
f820: 20 74 65 73 74 2d 6e 61 6d 65 73 20 74 65 73 74 test-names test
f830: 2d 72 65 63 6f 72 64 73 20 72 65 71 75 69 72 65 -records require
f840: 64 2d 74 65 73 74 73 20 61 6c 6c 2d 74 65 73 74 d-tests all-test
f850: 73 2d 72 65 67 69 73 74 72 79 29 0a 20 20 28 69 s-registry). (i
f860: 66 20 28 6e 6f 74 20 28 6e 75 6c 6c 3f 20 74 65 f (not (null? te
f870: 73 74 2d 6e 61 6d 65 73 29 29 0a 20 20 20 20 20 st-names)).
f880: 20 28 6c 65 74 20 6c 6f 6f 70 20 28 28 68 65 64 (let loop ((hed
f890: 20 28 63 61 72 20 74 65 73 74 2d 6e 61 6d 65 73 (car test-names
f8a0: 29 29 0a 09 09 20 28 74 61 6c 20 28 63 64 72 20 ))... (tal (cdr
f8b0: 74 65 73 74 2d 6e 61 6d 65 73 29 29 29 20 20 20 test-names)))
f8c0: 20 20 20 20 20 20 3b 3b 20 27 72 65 74 75 72 6e ;; 'return
f8d0: 2d 70 72 6f 63 73 20 74 65 6c 6c 73 20 74 68 65 -procs tells the
f8e0: 20 63 6f 6e 66 69 67 20 72 65 61 64 65 72 20 74 config reader t
f8f0: 6f 20 70 72 65 70 20 72 75 6e 6e 69 6e 67 20 73 o prep running s
f900: 79 73 74 65 6d 20 62 75 74 20 72 65 74 75 72 6e ystem but return
f910: 20 61 20 70 72 6f 63 0a 09 28 64 65 62 75 67 3a a proc..(debug:
f920: 70 72 69 6e 74 2d 69 6e 66 6f 20 34 20 2a 64 65 print-info 4 *de
f930: 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 fault-log-port*
f940: 22 68 65 64 3d 22 20 68 65 64 20 22 20 61 74 20 "hed=" hed " at
f950: 74 6f 70 20 6f 66 20 6c 6f 6f 70 22 29 0a 20 20 top of loop").
f960: 20 20 20 20 20 20 3b 3b 20 64 6f 6e 27 74 20 6b ;; don't k
f970: 6e 6f 77 20 69 74 65 6d 2d 70 61 74 68 20 61 74 now item-path at
f980: 20 74 68 69 73 20 74 69 6d 65 2c 20 6c 65 74 20 this time, let
f990: 74 68 65 20 74 65 73 74 63 6f 6e 66 69 67 20 67 the testconfig g
f9a0: 65 74 20 74 68 65 20 74 6f 70 20 6c 65 76 65 6c et the top level
f9b0: 20 74 65 73 74 63 6f 6e 66 69 67 0a 09 28 6c 65 testconfig..(le
f9c0: 74 2a 20 28 28 63 6f 6e 66 69 67 20 20 28 74 65 t* ((config (te
f9d0: 73 74 73 3a 67 65 74 2d 74 65 73 74 63 6f 6e 66 sts:get-testconf
f9e0: 69 67 20 68 65 64 20 23 66 20 61 6c 6c 2d 74 65 ig hed #f all-te
f9f0: 73 74 73 2d 72 65 67 69 73 74 72 79 20 27 72 65 sts-registry 're
fa00: 74 75 72 6e 2d 70 72 6f 63 73 29 29 0a 09 20 20 turn-procs))..
fa10: 20 20 20 20 20 28 77 61 69 74 6f 6e 73 20 28 6c (waitons (l
fa20: 65 74 20 28 28 69 6e 73 74 72 20 28 69 66 20 63 et ((instr (if c
fa30: 6f 6e 66 69 67 20 0a 09 09 09 09 09 20 28 63 6f onfig ...... (co
fa40: 6e 66 69 67 2d 6c 6f 6f 6b 75 70 20 63 6f 6e 66 nfig-lookup conf
fa50: 69 67 20 22 72 65 71 75 69 72 65 6d 65 6e 74 73 ig "requirements
fa60: 22 20 22 77 61 69 74 6f 6e 22 29 0a 09 09 09 09 " "waiton").....
fa70: 09 20 28 62 65 67 69 6e 20 3b 3b 20 4e 6f 20 63 . (begin ;; No c
fa80: 6f 6e 66 69 67 20 6d 65 61 6e 73 20 74 68 69 73 onfig means this
fa90: 20 69 73 20 61 20 6e 6f 6e 2d 65 78 69 73 74 61 is a non-exista
faa0: 6e 74 20 74 65 73 74 0a 09 09 09 09 09 20 20 20 nt test......
fab0: 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 65 72 72 (debug:print-err
fac0: 6f 72 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f or 0 *default-lo
fad0: 67 2d 70 6f 72 74 2a 20 22 6e 6f 6e 2d 65 78 69 g-port* "non-exi
fae0: 73 74 65 6e 74 20 72 65 71 75 69 72 65 64 20 74 stent required t
faf0: 65 73 74 20 5c 22 22 20 68 65 64 20 22 5c 22 2c est \"" hed "\",
fb00: 20 67 72 65 70 20 74 68 72 6f 75 67 68 20 79 6f grep through yo
fb10: 75 72 20 74 65 73 74 63 6f 6e 66 69 67 73 20 74 ur testconfigs t
fb20: 6f 20 66 69 6e 64 20 61 6e 64 20 72 65 6d 6f 76 o find and remov
fb30: 65 20 6f 72 20 63 72 65 61 74 65 20 74 68 65 20 e or create the
fb40: 74 65 73 74 2e 20 44 69 73 63 61 72 64 69 6e 67 test. Discarding
fb50: 20 61 6e 64 20 63 6f 6e 74 69 6e 75 69 6e 67 2e and continuing.
fb60: 22 29 0a 09 09 09 09 09 20 20 20 20 20 22 22 29 ")...... "")
fb70: 29 29 29 0a 09 09 09 20 20 28 64 65 62 75 67 3a ))).... (debug:
fb80: 70 72 69 6e 74 2d 69 6e 66 6f 20 38 20 2a 64 65 print-info 8 *de
fb90: 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 fault-log-port*
fba0: 22 77 61 69 74 6f 6e 73 20 73 74 72 69 6e 67 20 "waitons string
fbb0: 69 73 20 22 20 69 6e 73 74 72 29 0a 09 09 09 20 is " instr)....
fbc0: 20 28 73 74 72 69 6e 67 2d 73 70 6c 69 74 20 28 (string-split (
fbd0: 63 6f 6e 64 0a 09 09 09 09 09 20 28 28 70 72 6f cond...... ((pro
fbe0: 63 65 64 75 72 65 3f 20 69 6e 73 74 72 29 0a 09 cedure? instr)..
fbf0: 09 09 09 09 20 20 28 6c 65 74 20 28 28 72 65 73 .... (let ((res
fc00: 20 28 69 6e 73 74 72 29 29 29 0a 09 09 09 09 09 (instr)))......
fc10: 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 (debug:print
fc20: 2d 69 6e 66 6f 20 38 20 2a 64 65 66 61 75 6c 74 -info 8 *default
fc30: 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 77 61 69 74 -log-port* "wait
fc40: 6f 6e 20 70 72 6f 63 65 64 75 72 65 20 72 65 73 on procedure res
fc50: 75 6c 74 73 20 69 6e 20 73 74 72 69 6e 67 20 22 ults in string "
fc60: 20 72 65 73 20 22 20 66 6f 72 20 74 65 73 74 20 res " for test
fc70: 22 20 68 65 64 29 0a 09 09 09 09 09 20 20 20 20 " hed)......
fc80: 72 65 73 29 29 0a 09 09 09 09 09 20 28 28 73 74 res))...... ((st
fc90: 72 69 6e 67 3f 20 69 6e 73 74 72 29 20 20 20 20 ring? instr)
fca0: 20 69 6e 73 74 72 29 0a 09 09 09 09 09 20 28 65 instr)...... (e
fcb0: 6c 73 65 20 0a 09 09 09 09 09 20 20 3b 3b 20 4e lse ...... ;; N
fcc0: 4f 54 45 3a 20 54 68 69 73 20 69 73 20 61 63 74 OTE: This is act
fcd0: 75 61 6c 6c 79 20 74 68 65 20 63 61 73 65 20 6f ually the case o
fce0: 66 20 2a 6e 6f 2a 20 77 61 69 74 6f 6e 73 21 20 f *no* waitons!
fcf0: 3b 3b 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d ;; (debug:print-
fd00: 65 72 72 6f 72 20 30 20 2a 64 65 66 61 75 6c 74 error 0 *default
fd10: 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 73 6f 6d 65 -log-port* "some
fd20: 74 68 69 6e 67 20 77 65 6e 74 20 77 72 6f 6e 67 thing went wrong
fd30: 20 69 6e 20 70 72 6f 63 65 73 73 69 6e 67 20 77 in processing w
fd40: 61 69 74 6f 6e 73 20 66 6f 72 20 74 65 73 74 20 aitons for test
fd50: 22 20 68 65 64 29 0a 09 09 09 09 09 20 20 22 22 " hed)...... ""
fd60: 29 29 29 29 29 29 0a 09 20 20 28 69 66 20 28 6e )))))).. (if (n
fd70: 6f 74 20 63 6f 6e 66 69 67 29 20 3b 3b 20 74 68 ot config) ;; th
fd80: 69 73 20 69 73 20 61 20 6e 6f 6e 2d 65 78 69 73 is is a non-exis
fd90: 74 61 6e 74 20 74 65 73 74 20 63 61 6c 6c 65 64 tant test called
fda0: 20 69 6e 20 61 20 77 61 69 74 6f 6e 2e 20 0a 09 in a waiton. ..
fdb0: 20 20 20 20 20 20 28 69 66 20 28 6e 75 6c 6c 3f (if (null?
fdc0: 20 74 61 6c 29 0a 09 09 20 20 74 65 73 74 2d 72 tal)... test-r
fdd0: 65 63 6f 72 64 73 0a 09 09 20 20 28 6c 6f 6f 70 ecords... (loop
fde0: 20 28 63 61 72 20 74 61 6c 29 28 63 64 72 20 74 (car tal)(cdr t
fdf0: 61 6c 29 29 29 0a 09 20 20 20 20 20 20 28 62 65 al))).. (be
fe00: 67 69 6e 0a 09 09 28 64 65 62 75 67 3a 70 72 69 gin...(debug:pri
fe10: 6e 74 2d 69 6e 66 6f 20 38 20 2a 64 65 66 61 75 nt-info 8 *defau
fe20: 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 77 61 lt-log-port* "wa
fe30: 69 74 6f 6e 73 3a 20 22 20 77 61 69 74 6f 6e 73 itons: " waitons
fe40: 29 0a 09 09 3b 3b 20 63 68 65 63 6b 20 66 6f 72 )...;; check for
fe50: 20 68 65 64 20 69 6e 20 77 61 69 74 6f 6e 73 20 hed in waitons
fe60: 3d 3e 20 74 68 69 73 20 77 6f 75 6c 64 20 62 65 => this would be
fe70: 20 63 69 72 63 75 6c 61 72 2c 20 72 65 6d 6f 76 circular, remov
fe80: 65 20 69 74 20 61 6e 64 20 69 73 73 75 65 20 61 e it and issue a
fe90: 6e 0a 09 09 3b 3b 20 65 72 72 6f 72 0a 09 09 28 n...;; error...(
fea0: 69 66 20 28 6d 65 6d 62 65 72 20 68 65 64 20 77 if (member hed w
feb0: 61 69 74 6f 6e 73 29 0a 09 09 20 20 20 20 28 62 aitons)... (b
fec0: 65 67 69 6e 0a 09 09 20 20 20 20 20 20 28 64 65 egin... (de
fed0: 62 75 67 3a 70 72 69 6e 74 2d 65 72 72 6f 72 20 bug:print-error
fee0: 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 0 *default-log-p
fef0: 6f 72 74 2a 20 22 74 65 73 74 20 22 20 68 65 64 ort* "test " hed
ff00: 20 22 20 68 61 73 20 6c 69 73 74 65 64 20 69 74 " has listed it
ff10: 73 65 6c 66 20 61 73 20 61 20 77 61 69 74 6f 6e self as a waiton
ff20: 2c 20 70 6c 65 61 73 65 20 63 6f 72 72 65 63 74 , please correct
ff30: 20 74 68 69 73 21 22 29 0a 09 09 20 20 20 20 20 this!")...
ff40: 20 28 73 65 74 21 20 77 61 69 74 6f 6e 73 20 28 (set! waitons (
ff50: 66 69 6c 74 65 72 20 28 6c 61 6d 62 64 61 20 28 filter (lambda (
ff60: 78 29 28 6e 6f 74 20 28 65 71 75 61 6c 3f 20 78 x)(not (equal? x
ff70: 20 68 65 64 29 29 29 20 77 61 69 74 6f 6e 73 29 hed))) waitons)
ff80: 29 29 29 0a 09 09 0a 09 09 3b 3b 20 28 69 74 65 )))......;; (ite
ff90: 6d 73 20 20 20 28 69 74 65 6d 73 3a 67 65 74 2d ms (items:get-
ffa0: 69 74 65 6d 73 2d 66 72 6f 6d 2d 63 6f 6e 66 69 items-from-confi
ffb0: 67 20 63 6f 6e 66 69 67 29 29 29 0a 09 09 28 69 g config)))...(i
ffc0: 66 20 28 6e 6f 74 20 28 68 61 73 68 2d 74 61 62 f (not (hash-tab
ffd0: 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 74 le-ref/default t
ffe0: 65 73 74 2d 72 65 63 6f 72 64 73 20 68 65 64 20 est-records hed
fff0: 23 66 29 29 0a 09 09 20 20 20 20 28 68 61 73 68 #f))... (hash
10000 2d 74 61 62 6c 65 2d 73 65 74 21 20 74 65 73 74 -table-set! test
10010 2d 72 65 63 6f 72 64 73 0a 09 09 09 09 20 20 20 -records.....
10020 20 20 68 65 64 20 28 76 65 63 74 6f 72 20 68 65 hed (vector he
10030 64 20 20 20 20 20 3b 3b 20 30 0a 09 09 09 09 09 d ;; 0......
10040 09 20 63 6f 6e 66 69 67 20 20 3b 3b 20 31 0a 09 . config ;; 1..
10050 09 09 09 09 09 20 77 61 69 74 6f 6e 73 20 3b 3b ..... waitons ;;
10060 20 32 0a 09 09 09 09 09 09 20 28 63 6f 6e 66 69 2....... (confi
10070 67 2d 6c 6f 6f 6b 75 70 20 63 6f 6e 66 69 67 20 g-lookup config
10080 22 72 65 71 75 69 72 65 6d 65 6e 74 73 22 20 22 "requirements" "
10090 70 72 69 6f 72 69 74 79 22 29 20 20 20 20 20 3b priority") ;
100a0 3b 20 70 72 69 6f 72 69 74 79 20 33 0a 09 09 09 ; priority 3....
100b0 09 09 09 20 28 6c 65 74 20 28 28 69 74 65 6d 73 ... (let ((items
100c0 20 20 20 20 20 20 28 68 61 73 68 2d 74 61 62 6c (hash-tabl
100d0 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 63 6f e-ref/default co
100e0 6e 66 69 67 20 22 69 74 65 6d 73 22 20 23 66 29 nfig "items" #f)
100f0 29 20 3b 3b 20 69 74 65 6d 73 20 34 0a 09 09 09 ) ;; items 4....
10100 09 09 09 20 20 20 20 20 20 20 28 69 74 65 6d 73 ... (items
10110 74 61 62 6c 65 20 28 68 61 73 68 2d 74 61 62 6c table (hash-tabl
10120 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 63 6f e-ref/default co
10130 6e 66 69 67 20 22 69 74 65 6d 73 74 61 62 6c 65 nfig "itemstable
10140 22 20 23 66 29 29 29 20 0a 09 09 09 09 09 09 20 " #f))) .......
10150 20 20 3b 3b 20 69 66 20 65 69 74 68 65 72 20 69 ;; if either i
10160 74 65 6d 73 20 6f 72 20 69 74 65 6d 73 20 74 61 tems or items ta
10170 62 6c 65 20 69 73 20 61 20 70 72 6f 63 20 72 65 ble is a proc re
10180 74 75 72 6e 20 69 74 20 73 6f 20 74 65 73 74 20 turn it so test
10190 72 75 6e 6e 69 6e 67 0a 09 09 09 09 09 09 20 20 running.......
101a0 20 3b 3b 20 70 72 6f 63 65 73 73 20 63 61 6e 20 ;; process can
101b0 6b 6e 6f 77 20 74 6f 20 63 61 6c 6c 20 69 74 65 know to call ite
101c0 6d 73 3a 67 65 74 2d 69 74 65 6d 73 2d 66 72 6f ms:get-items-fro
101d0 6d 2d 63 6f 6e 66 69 67 0a 09 09 09 09 09 09 20 m-config.......
101e0 20 20 3b 3b 20 69 66 20 65 69 74 68 65 72 20 69 ;; if either i
101f0 73 20 61 20 6c 69 73 74 20 61 6e 64 20 6e 6f 6e s a list and non
10200 65 20 69 73 20 61 20 70 72 6f 63 20 67 6f 20 61 e is a proc go a
10210 68 65 61 64 20 61 6e 64 20 63 61 6c 6c 20 67 65 head and call ge
10220 74 2d 69 74 65 6d 73 0a 09 09 09 09 09 09 20 20 t-items.......
10230 20 3b 3b 20 6f 74 68 65 72 77 69 73 65 20 72 65 ;; otherwise re
10240 74 75 72 6e 20 23 66 20 2d 20 74 68 69 73 20 69 turn #f - this i
10250 73 20 6e 6f 74 20 61 6e 20 69 74 65 72 61 74 65 s not an iterate
10260 64 20 74 65 73 74 0a 09 09 09 09 09 09 20 20 20 d test.......
10270 28 63 6f 6e 64 0a 09 09 09 09 09 09 20 20 20 20 (cond.......
10280 28 28 70 72 6f 63 65 64 75 72 65 3f 20 69 74 65 ((procedure? ite
10290 6d 73 29 20 20 20 20 20 20 0a 09 09 09 09 09 09 ms) .......
102a0 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e (debug:prin
102b0 74 2d 69 6e 66 6f 20 34 20 2a 64 65 66 61 75 6c t-info 4 *defaul
102c0 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 69 74 65 t-log-port* "ite
102d0 6d 73 20 69 73 20 61 20 70 72 6f 63 65 64 75 72 ms is a procedur
102e0 65 2c 20 77 69 6c 6c 20 63 61 6c 63 20 6c 61 74 e, will calc lat
102f0 65 72 22 29 0a 09 09 09 09 09 09 20 20 20 20 20 er").......
10300 69 74 65 6d 73 29 20 20 20 20 20 20 20 20 20 20 items)
10310 20 20 3b 3b 20 63 61 6c 63 20 6c 61 74 65 72 0a ;; calc later.
10320 09 09 09 09 09 09 20 20 20 20 28 28 70 72 6f 63 ...... ((proc
10330 65 64 75 72 65 3f 20 69 74 65 6d 73 74 61 62 6c edure? itemstabl
10340 65 29 0a 09 09 09 09 09 09 20 20 20 20 20 28 64 e)....... (d
10350 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 ebug:print-info
10360 34 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 4 *default-log-p
10370 6f 72 74 2a 20 22 69 74 65 6d 73 74 61 62 6c 65 ort* "itemstable
10380 20 69 73 20 61 20 70 72 6f 63 65 64 75 72 65 2c is a procedure,
10390 20 77 69 6c 6c 20 63 61 6c 63 20 6c 61 74 65 72 will calc later
103a0 22 29 0a 09 09 09 09 09 09 20 20 20 20 20 69 74 ")....... it
103b0 65 6d 73 74 61 62 6c 65 29 20 20 20 20 20 20 20 emstable)
103c0 3b 3b 20 63 61 6c 63 20 6c 61 74 65 72 0a 09 09 ;; calc later...
103d0 09 09 09 09 20 20 20 20 28 28 66 69 6c 74 65 72 .... ((filter
103e0 20 28 6c 61 6d 62 64 61 20 28 78 29 0a 09 09 09 (lambda (x)....
103f0 09 09 09 09 20 20 20 20 20 20 20 28 6c 65 74 20 .... (let
10400 28 28 76 61 6c 20 28 63 61 72 20 78 29 29 29 0a ((val (car x))).
10410 09 09 09 09 09 09 09 09 20 28 69 66 20 28 70 72 ........ (if (pr
10420 6f 63 65 64 75 72 65 3f 20 76 61 6c 29 20 76 61 ocedure? val) va
10430 6c 20 23 66 29 29 29 0a 09 09 09 09 09 09 09 20 l #f)))........
10440 20 20 20 20 28 61 70 70 65 6e 64 20 28 69 66 20 (append (if
10450 28 6c 69 73 74 3f 20 69 74 65 6d 73 29 20 69 74 (list? items) it
10460 65 6d 73 20 27 28 29 29 0a 09 09 09 09 09 09 09 ems '())........
10470 09 20 20 20 20 20 28 69 66 20 28 6c 69 73 74 3f . (if (list?
10480 20 69 74 65 6d 73 74 61 62 6c 65 29 20 69 74 65 itemstable) ite
10490 6d 73 74 61 62 6c 65 20 27 28 29 29 29 29 0a 09 mstable '())))..
104a0 09 09 09 09 09 20 20 20 20 20 27 68 61 76 65 2d ..... 'have-
104b0 70 72 6f 63 65 64 75 72 65 29 0a 09 09 09 09 09 procedure)......
104c0 09 20 20 20 20 28 28 6f 72 20 28 6c 69 73 74 3f . ((or (list?
104d0 20 69 74 65 6d 73 29 28 6c 69 73 74 3f 20 69 74 items)(list? it
104e0 65 6d 73 74 61 62 6c 65 29 29 20 3b 3b 20 63 61 emstable)) ;; ca
104f0 6c 63 20 6e 6f 77 0a 09 09 09 09 09 09 20 20 20 lc now.......
10500 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 (debug:print-i
10510 6e 66 6f 20 34 20 2a 64 65 66 61 75 6c 74 2d 6c nfo 4 *default-l
10520 6f 67 2d 70 6f 72 74 2a 20 22 69 74 65 6d 73 20 og-port* "items
10530 61 6e 64 20 69 74 65 6d 73 74 61 62 6c 65 20 61 and itemstable a
10540 72 65 20 6c 69 73 74 73 2c 20 63 61 6c 63 20 6e re lists, calc n
10550 6f 77 5c 6e 22 0a 09 09 09 09 09 09 09 09 20 20 ow\n".........
10560 20 20 20 20 20 22 20 20 20 20 69 74 65 6d 73 3a " items:
10570 20 22 20 69 74 65 6d 73 20 22 20 69 74 65 6d 73 " items " items
10580 74 61 62 6c 65 3a 20 22 20 69 74 65 6d 73 74 61 table: " itemsta
10590 62 6c 65 29 0a 09 09 09 09 09 09 20 20 20 20 20 ble).......
105a0 28 69 74 65 6d 73 3a 67 65 74 2d 69 74 65 6d 73 (items:get-items
105b0 2d 66 72 6f 6d 2d 63 6f 6e 66 69 67 20 63 6f 6e -from-config con
105c0 66 69 67 29 29 0a 09 09 09 09 09 09 20 20 20 20 fig)).......
105d0 28 65 6c 73 65 20 23 66 29 29 29 20 20 20 20 20 (else #f)))
105e0 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
105f0 20 20 20 20 20 20 3b 3b 20 6e 6f 74 20 69 74 65 ;; not ite
10600 72 61 74 65 64 0a 09 09 09 09 09 09 20 23 66 20 rated....... #f
10610 20 20 20 20 20 3b 3b 20 69 74 65 6d 73 64 61 74 ;; itemsdat
10620 20 35 0a 09 09 09 09 09 09 20 23 66 20 20 20 20 5....... #f
10630 20 20 3b 3b 20 73 70 61 72 65 20 2d 20 75 73 65 ;; spare - use
10640 64 20 66 6f 72 20 69 74 65 6d 2d 70 61 74 68 0a d for item-path.
10650 09 09 09 09 09 09 20 29 29 29 0a 09 09 28 66 6f ...... )))...(fo
10660 72 2d 65 61 63 68 20 0a 09 09 20 28 6c 61 6d 62 r-each ... (lamb
10670 64 61 20 28 77 61 69 74 6f 6e 29 0a 09 09 20 20 da (waiton)...
10680 20 28 69 66 20 28 61 6e 64 20 77 61 69 74 6f 6e (if (and waiton
10690 20 28 6e 6f 74 20 28 6d 65 6d 62 65 72 20 77 61 (not (member wa
106a0 69 74 6f 6e 20 74 65 73 74 2d 6e 61 6d 65 73 29 iton test-names)
106b0 29 29 0a 09 09 20 20 20 20 20 20 20 28 62 65 67 ))... (beg
106c0 69 6e 0a 09 09 09 20 28 73 65 74 21 20 72 65 71 in.... (set! req
106d0 75 69 72 65 64 2d 74 65 73 74 73 20 28 63 6f 6e uired-tests (con
106e0 73 20 77 61 69 74 6f 6e 20 72 65 71 75 69 72 65 s waiton require
106f0 64 2d 74 65 73 74 73 29 29 0a 09 09 09 20 28 73 d-tests)).... (s
10700 65 74 21 20 74 65 73 74 2d 6e 61 6d 65 73 20 28 et! test-names (
10710 63 6f 6e 73 20 77 61 69 74 6f 6e 20 74 65 73 74 cons waiton test
10720 2d 6e 61 6d 65 73 29 29 29 29 29 20 3b 3b 20 77 -names))))) ;; w
10730 61 73 20 61 6e 20 61 70 70 65 6e 64 2c 20 6e 6f as an append, no
10740 77 20 61 20 63 6f 6e 73 0a 09 09 20 77 61 69 74 w a cons... wait
10750 6f 6e 73 29 0a 09 09 28 6c 65 74 20 28 28 72 65 ons)...(let ((re
10760 6d 74 65 73 74 73 20 28 64 65 6c 65 74 65 2d 64 mtests (delete-d
10770 75 70 6c 69 63 61 74 65 73 20 28 61 70 70 65 6e uplicates (appen
10780 64 20 77 61 69 74 6f 6e 73 20 74 61 6c 29 29 29 d waitons tal)))
10790 29 0a 09 09 20 20 28 69 66 20 28 6e 6f 74 20 28 )... (if (not (
107a0 6e 75 6c 6c 3f 20 72 65 6d 74 65 73 74 73 29 29 null? remtests))
107b0 0a 09 09 20 20 20 20 20 20 28 6c 6f 6f 70 20 28 ... (loop (
107c0 63 61 72 20 72 65 6d 74 65 73 74 73 29 28 63 64 car remtests)(cd
107d0 72 20 72 65 6d 74 65 73 74 73 29 29 0a 09 09 20 r remtests))...
107e0 20 20 20 20 20 74 65 73 74 2d 72 65 63 6f 72 64 test-record
107f0 73 29 29 29 29 29 29 29 29 0a 0a 3b 3b 3d 3d 3d s))))))))..;;===
10800 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
10810 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
10820 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
10830 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
10840 3d 3d 3d 0a 3b 3b 20 74 65 73 74 20 73 74 65 70 ===.;; test step
10850 73 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d s.;;============
10860 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
10870 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
10880 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
10890 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 3b 3b 20 74 ==========..;; t
108a0 65 73 74 73 74 65 70 2d 73 65 74 2d 73 74 61 74 eststep-set-stat
108b0 75 73 21 20 75 73 65 64 20 74 6f 20 62 65 20 68 us! used to be h
108c0 65 72 65 0a 0a 28 64 65 66 69 6e 65 20 28 74 65 ere..(define (te
108d0 73 74 2d 67 65 74 2d 6b 69 6c 6c 2d 72 65 71 75 st-get-kill-requ
108e0 65 73 74 20 72 75 6e 2d 69 64 20 74 65 73 74 2d est run-id test-
108f0 69 64 29 20 3b 3b 20 72 75 6e 2d 69 64 20 74 65 id) ;; run-id te
10900 73 74 2d 6e 61 6d 65 20 69 74 65 6d 64 61 74 29 st-name itemdat)
10910 0a 20 20 28 6c 65 74 2a 20 28 28 74 65 73 74 64 . (let* ((testd
10920 61 74 20 20 20 28 72 6d 74 3a 67 65 74 2d 74 65 at (rmt:get-te
10930 73 74 2d 69 6e 66 6f 2d 62 79 2d 69 64 20 72 75 st-info-by-id ru
10940 6e 2d 69 64 20 74 65 73 74 2d 69 64 29 29 29 0a n-id test-id))).
10950 20 20 20 20 28 61 6e 64 20 74 65 73 74 64 61 74 (and testdat
10960 0a 09 20 28 65 71 75 61 6c 3f 20 28 74 65 73 74 .. (equal? (test
10970 3a 67 65 74 2d 73 74 61 74 65 20 74 65 73 74 64 :get-state testd
10980 61 74 29 20 22 4b 49 4c 4c 52 45 51 22 29 29 29 at) "KILLREQ")))
10990 29 0a 0a 28 64 65 66 69 6e 65 20 28 74 65 73 74 )..(define (test
109a0 3a 74 64 62 2d 67 65 74 2d 72 75 6e 64 61 74 2d :tdb-get-rundat-
109b0 63 6f 75 6e 74 20 74 64 62 29 0a 20 20 28 69 66 count tdb). (if
109c0 20 74 64 62 0a 20 20 20 20 20 20 28 6c 65 74 20 tdb. (let
109d0 28 28 72 65 73 20 30 29 29 0a 09 28 73 71 6c 69 ((res 0))..(sqli
109e0 74 65 33 3a 66 6f 72 2d 65 61 63 68 2d 72 6f 77 te3:for-each-row
109f0 0a 09 20 28 6c 61 6d 62 64 61 20 28 63 6f 75 6e .. (lambda (coun
10a00 74 29 0a 09 20 20 20 28 73 65 74 21 20 72 65 73 t).. (set! res
10a10 20 63 6f 75 6e 74 29 29 0a 09 20 74 64 62 0a 09 count)).. tdb..
10a20 20 22 53 45 4c 45 43 54 20 63 6f 75 6e 74 28 69 "SELECT count(i
10a30 64 29 20 46 52 4f 4d 20 74 65 73 74 5f 72 75 6e d) FROM test_run
10a40 64 61 74 3b 22 29 0a 09 72 65 73 29 29 0a 20 20 dat;")..res)).
10a50 30 29 0a 0a 28 64 65 66 69 6e 65 20 28 74 65 73 0)..(define (tes
10a60 74 73 3a 75 70 64 61 74 65 2d 63 65 6e 74 72 61 ts:update-centra
10a70 6c 2d 6d 65 74 61 2d 69 6e 66 6f 20 72 75 6e 2d l-meta-info run-
10a80 69 64 20 74 65 73 74 2d 69 64 20 63 70 75 6c 6f id test-id cpulo
10a90 61 64 20 64 69 73 6b 66 72 65 65 20 6d 69 6e 75 ad diskfree minu
10aa0 74 65 73 20 75 6e 61 6d 65 20 68 6f 73 74 6e 61 tes uname hostna
10ab0 6d 65 29 0a 20 20 28 72 6d 74 3a 67 65 6e 65 72 me). (rmt:gener
10ac0 61 6c 2d 63 61 6c 6c 20 27 75 70 64 61 74 65 2d al-call 'update-
10ad0 74 65 73 74 2d 72 75 6e 64 61 74 20 72 75 6e 2d test-rundat run-
10ae0 69 64 20 74 65 73 74 2d 69 64 20 28 63 75 72 72 id test-id (curr
10af0 65 6e 74 2d 73 65 63 6f 6e 64 73 29 20 28 6f 72 ent-seconds) (or
10b00 20 63 70 75 6c 6f 61 64 20 2d 31 29 28 6f 72 20 cpuload -1)(or
10b10 64 69 73 6b 66 72 65 65 20 2d 31 29 20 2d 31 20 diskfree -1) -1
10b20 28 6f 72 20 6d 69 6e 75 74 65 73 20 2d 31 29 29 (or minutes -1))
10b30 0a 20 20 28 69 66 20 28 61 6e 64 20 63 70 75 6c . (if (and cpul
10b40 6f 61 64 20 64 69 73 6b 66 72 65 65 29 0a 20 20 oad diskfree).
10b50 20 20 20 20 28 72 6d 74 3a 67 65 6e 65 72 61 6c (rmt:general
10b60 2d 63 61 6c 6c 20 27 75 70 64 61 74 65 2d 63 70 -call 'update-cp
10b70 75 6c 6f 61 64 2d 64 69 73 6b 66 72 65 65 20 72 uload-diskfree r
10b80 75 6e 2d 69 64 20 63 70 75 6c 6f 61 64 20 64 69 un-id cpuload di
10b90 73 6b 66 72 65 65 20 74 65 73 74 2d 69 64 29 29 skfree test-id))
10ba0 0a 20 20 28 69 66 20 6d 69 6e 75 74 65 73 20 0a . (if minutes .
10bb0 20 20 20 20 20 20 28 72 6d 74 3a 67 65 6e 65 72 (rmt:gener
10bc0 61 6c 2d 63 61 6c 6c 20 27 75 70 64 61 74 65 2d al-call 'update-
10bd0 72 75 6e 2d 64 75 72 61 74 69 6f 6e 20 72 75 6e run-duration run
10be0 2d 69 64 20 6d 69 6e 75 74 65 73 20 74 65 73 74 -id minutes test
10bf0 2d 69 64 29 29 0a 20 20 28 69 66 20 28 61 6e 64 -id)). (if (and
10c00 20 75 6e 61 6d 65 20 68 6f 73 74 6e 61 6d 65 29 uname hostname)
10c10 0a 20 20 20 20 20 20 28 72 6d 74 3a 67 65 6e 65 . (rmt:gene
10c20 72 61 6c 2d 63 61 6c 6c 20 27 75 70 64 61 74 65 ral-call 'update
10c30 2d 75 6e 61 6d 65 2d 68 6f 73 74 20 72 75 6e 2d -uname-host run-
10c40 69 64 20 75 6e 61 6d 65 20 68 6f 73 74 6e 61 6d id uname hostnam
10c50 65 20 74 65 73 74 2d 69 64 29 29 29 0a 20 20 0a e test-id))). .
10c60 3b 3b 20 54 68 69 73 20 6f 6e 65 20 69 73 20 66 ;; This one is f
10c70 6f 72 20 72 75 6e 6e 69 6e 67 20 77 69 74 68 20 or running with
10c80 6e 6f 20 64 62 20 61 63 63 65 73 73 20 28 69 2e no db access (i.
10c90 65 2e 20 76 69 61 20 72 6d 74 3a 20 69 6e 74 65 e. via rmt: inte
10ca0 72 6e 61 6c 6c 79 29 0a 28 64 65 66 69 6e 65 20 rnally).(define
10cb0 28 74 65 73 74 73 3a 73 65 74 2d 66 75 6c 6c 2d (tests:set-full-
10cc0 6d 65 74 61 2d 69 6e 66 6f 20 64 62 20 74 65 73 meta-info db tes
10cd0 74 2d 69 64 20 72 75 6e 2d 69 64 20 6d 69 6e 75 t-id run-id minu
10ce0 74 65 73 20 77 6f 72 6b 2d 61 72 65 61 20 72 65 tes work-area re
10cf0 6d 74 72 69 65 73 29 0a 3b 3b 20 28 64 65 66 69 mtries).;; (defi
10d00 6e 65 20 28 74 65 73 74 73 3a 73 65 74 2d 66 75 ne (tests:set-fu
10d10 6c 6c 2d 6d 65 74 61 2d 69 6e 66 6f 20 74 65 73 ll-meta-info tes
10d20 74 2d 69 64 20 72 75 6e 2d 69 64 20 6d 69 6e 75 t-id run-id minu
10d30 74 65 73 20 77 6f 72 6b 2d 61 72 65 61 29 0a 3b tes work-area).;
10d40 3b 20 20 28 6c 65 74 20 28 28 72 65 6d 74 72 69 ; (let ((remtri
10d50 65 73 20 31 30 29 29 0a 20 20 28 6c 65 74 2a 20 es 10)). (let*
10d60 28 28 63 70 75 6c 6f 61 64 20 20 28 67 65 74 2d ((cpuload (get-
10d70 63 70 75 2d 6c 6f 61 64 29 29 0a 09 20 28 64 69 cpu-load)).. (di
10d80 73 6b 66 72 65 65 20 28 67 65 74 2d 64 66 20 28 skfree (get-df (
10d90 63 75 72 72 65 6e 74 2d 64 69 72 65 63 74 6f 72 current-director
10da0 79 29 29 29 0a 09 20 28 75 6e 61 6d 65 20 20 20 y))).. (uname
10db0 20 28 67 65 74 2d 75 6e 61 6d 65 20 22 2d 73 72 (get-uname "-sr
10dc0 76 70 69 6f 22 29 29 0a 09 20 28 68 6f 73 74 6e vpio")).. (hostn
10dd0 61 6d 65 20 28 67 65 74 2d 68 6f 73 74 2d 6e 61 ame (get-host-na
10de0 6d 65 29 29 29 0a 20 20 20 20 28 74 65 73 74 73 me))). (tests
10df0 3a 75 70 64 61 74 65 2d 63 65 6e 74 72 61 6c 2d :update-central-
10e00 6d 65 74 61 2d 69 6e 66 6f 20 72 75 6e 2d 69 64 meta-info run-id
10e10 20 74 65 73 74 2d 69 64 20 63 70 75 6c 6f 61 64 test-id cpuload
10e20 20 64 69 73 6b 66 72 65 65 20 6d 69 6e 75 74 65 diskfree minute
10e30 73 20 75 6e 61 6d 65 20 68 6f 73 74 6e 61 6d 65 s uname hostname
10e40 29 29 29 0a 20 20 20 20 0a 3b 3b 20 28 64 65 66 ))). .;; (def
10e50 69 6e 65 20 28 74 65 73 74 73 3a 73 65 74 2d 70 ine (tests:set-p
10e60 61 72 74 69 61 6c 2d 6d 65 74 61 2d 69 6e 66 6f artial-meta-info
10e70 20 74 65 73 74 2d 69 64 20 72 75 6e 2d 69 64 20 test-id run-id
10e80 6d 69 6e 75 74 65 73 20 77 6f 72 6b 2d 61 72 65 minutes work-are
10e90 61 29 0a 28 64 65 66 69 6e 65 20 28 74 65 73 74 a).(define (test
10ea0 73 3a 73 65 74 2d 70 61 72 74 69 61 6c 2d 6d 65 s:set-partial-me
10eb0 74 61 2d 69 6e 66 6f 20 74 65 73 74 2d 69 64 20 ta-info test-id
10ec0 72 75 6e 2d 69 64 20 6d 69 6e 75 74 65 73 20 77 run-id minutes w
10ed0 6f 72 6b 2d 61 72 65 61 20 72 65 6d 74 72 69 65 ork-area remtrie
10ee0 73 29 0a 20 20 28 6c 65 74 2a 20 28 28 63 70 75 s). (let* ((cpu
10ef0 6c 6f 61 64 20 20 28 67 65 74 2d 63 70 75 2d 6c load (get-cpu-l
10f00 6f 61 64 29 29 0a 09 20 28 64 69 73 6b 66 72 65 oad)).. (diskfre
10f10 65 20 28 67 65 74 2d 64 66 20 28 63 75 72 72 65 e (get-df (curre
10f20 6e 74 2d 64 69 72 65 63 74 6f 72 79 29 29 29 0a nt-directory))).
10f30 09 20 28 72 65 6d 74 72 69 65 73 20 31 30 29 29 . (remtries 10))
10f40 0a 20 20 20 20 28 68 61 6e 64 6c 65 2d 65 78 63 . (handle-exc
10f50 65 70 74 69 6f 6e 73 0a 20 20 20 20 20 65 78 6e eptions. exn
10f60 0a 20 20 20 20 20 28 69 66 20 28 3e 20 72 65 6d . (if (> rem
10f70 74 72 69 65 73 20 30 29 0a 09 20 28 62 65 67 69 tries 0).. (begi
10f80 6e 0a 09 20 20 20 28 70 72 69 6e 74 2d 63 61 6c n.. (print-cal
10f90 6c 2d 63 68 61 69 6e 20 28 63 75 72 72 65 6e 74 l-chain (current
10fa0 2d 65 72 72 6f 72 2d 70 6f 72 74 29 29 0a 09 20 -error-port))..
10fb0 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 (debug:print-i
10fc0 6e 66 6f 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c nfo 0 *default-l
10fd0 6f 67 2d 70 6f 72 74 2a 20 22 57 41 52 4e 49 4e og-port* "WARNIN
10fe0 47 3a 20 66 61 69 6c 65 64 20 74 6f 20 73 65 74 G: failed to set
10ff0 20 6d 65 74 61 20 69 6e 66 6f 2e 20 57 69 6c 6c meta info. Will
11000 20 74 72 79 20 22 20 72 65 6d 74 72 69 65 73 20 try " remtries
11010 22 20 6d 6f 72 65 20 74 69 6d 65 73 22 29 0a 09 " more times")..
11020 20 20 20 28 73 65 74 21 20 72 65 6d 74 72 69 65 (set! remtrie
11030 73 20 28 2d 20 72 65 6d 74 72 69 65 73 20 31 29 s (- remtries 1)
11040 29 0a 09 20 20 20 28 74 68 72 65 61 64 2d 73 6c ).. (thread-sl
11050 65 65 70 21 20 31 30 29 0a 09 20 20 20 28 74 65 eep! 10).. (te
11060 73 74 73 3a 73 65 74 2d 66 75 6c 6c 2d 6d 65 74 sts:set-full-met
11070 61 2d 69 6e 66 6f 20 64 62 20 74 65 73 74 2d 69 a-info db test-i
11080 64 20 72 75 6e 2d 69 64 20 6d 69 6e 75 74 65 73 d run-id minutes
11090 20 77 6f 72 6b 2d 61 72 65 61 20 28 2d 20 72 65 work-area (- re
110a0 6d 74 72 69 65 73 20 31 29 29 29 0a 09 20 28 6c mtries 1))).. (l
110b0 65 74 20 28 28 65 72 72 2d 73 74 61 74 75 73 20 et ((err-status
110c0 28 28 63 6f 6e 64 69 74 69 6f 6e 2d 70 72 6f 70 ((condition-prop
110d0 65 72 74 79 2d 61 63 63 65 73 73 6f 72 20 27 73 erty-accessor 's
110e0 71 6c 69 74 65 33 20 27 73 74 61 74 75 73 20 23 qlite3 'status #
110f0 66 29 20 65 78 6e 29 29 29 0a 09 20 20 20 28 64 f) exn))).. (d
11100 65 62 75 67 3a 70 72 69 6e 74 2d 65 72 72 6f 72 ebug:print-error
11110 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 0 *default-log-
11120 70 6f 72 74 2a 20 22 74 72 69 65 64 20 66 6f 72 port* "tried for
11130 20 6f 76 65 72 20 61 20 6d 69 6e 75 74 65 20 74 over a minute t
11140 6f 20 75 70 64 61 74 65 20 6d 65 74 61 20 69 6e o update meta in
11150 66 6f 20 61 6e 64 20 66 61 69 6c 65 64 2e 20 47 fo and failed. G
11160 69 76 69 6e 67 20 75 70 22 29 0a 09 20 20 20 28 iving up").. (
11170 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 2a 64 debug:print 0 *d
11180 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a efault-log-port*
11190 20 22 45 58 43 45 50 54 49 4f 4e 3a 20 64 61 74 "EXCEPTION: dat
111a0 61 62 61 73 65 20 70 72 6f 62 61 62 6c 79 20 6f abase probably o
111b0 76 65 72 6c 6f 61 64 65 64 20 6f 72 20 75 6e 72 verloaded or unr
111c0 65 61 64 61 62 6c 65 2e 22 29 0a 09 20 20 20 28 eadable.").. (
111d0 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 2a 64 debug:print 0 *d
111e0 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a efault-log-port*
111f0 20 22 20 6d 65 73 73 61 67 65 3a 20 22 20 28 28 " message: " ((
11200 63 6f 6e 64 69 74 69 6f 6e 2d 70 72 6f 70 65 72 condition-proper
11210 74 79 2d 61 63 63 65 73 73 6f 72 20 27 65 78 6e ty-accessor 'exn
11220 20 27 6d 65 73 73 61 67 65 29 20 65 78 6e 29 29 'message) exn))
11230 0a 09 20 20 20 28 70 72 69 6e 74 20 22 65 78 6e .. (print "exn
11240 3d 22 20 28 63 6f 6e 64 69 74 69 6f 6e 2d 3e 6c =" (condition->l
11250 69 73 74 20 65 78 6e 29 29 0a 09 20 20 20 28 64 ist exn)).. (d
11260 65 62 75 67 3a 70 72 69 6e 74 20 30 20 2a 64 65 ebug:print 0 *de
11270 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 fault-log-port*
11280 22 20 73 74 61 74 75 73 3a 20 20 22 20 28 28 63 " status: " ((c
11290 6f 6e 64 69 74 69 6f 6e 2d 70 72 6f 70 65 72 74 ondition-propert
112a0 79 2d 61 63 63 65 73 73 6f 72 20 27 73 71 6c 69 y-accessor 'sqli
112b0 74 65 33 20 27 73 74 61 74 75 73 29 20 65 78 6e te3 'status) exn
112c0 29 29 0a 09 20 20 20 28 70 72 69 6e 74 2d 63 61 )).. (print-ca
112d0 6c 6c 2d 63 68 61 69 6e 20 28 63 75 72 72 65 6e ll-chain (curren
112e0 74 2d 65 72 72 6f 72 2d 70 6f 72 74 29 29 29 29 t-error-port))))
112f0 0a 20 20 20 20 20 28 74 65 73 74 73 3a 75 70 64 . (tests:upd
11300 61 74 65 2d 74 65 73 74 64 61 74 2d 6d 65 74 61 ate-testdat-meta
11310 2d 69 6e 66 6f 20 64 62 20 74 65 73 74 2d 69 64 -info db test-id
11320 20 77 6f 72 6b 2d 61 72 65 61 20 63 70 75 6c 6f work-area cpulo
11330 61 64 20 64 69 73 6b 66 72 65 65 20 6d 69 6e 75 ad diskfree minu
11340 74 65 73 29 0a 20 20 29 29 29 0a 09 20 0a 3b 3b tes). ))).. .;;
11350 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
11360 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
11370 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
11380 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
11390 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 41 20 52 20 43 20 ======.;; A R C
113a0 48 20 49 20 56 20 49 20 4e 20 47 0a 3b 3b 3d 3d H I V I N G.;;==
113b0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
113c0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
113d0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
113e0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
113f0 3d 3d 3d 3d 0a 0a 28 64 65 66 69 6e 65 20 28 74 ====..(define (t
11400 65 73 74 3a 61 72 63 68 69 76 65 20 64 62 20 74 est:archive db t
11410 65 73 74 2d 69 64 29 0a 20 20 23 66 29 0a 0a 28 est-id). #f)..(
11420 64 65 66 69 6e 65 20 28 74 65 73 74 3a 61 72 63 define (test:arc
11430 68 69 76 65 2d 74 65 73 74 73 20 64 62 20 6b 65 hive-tests db ke
11440 79 6e 61 6d 65 73 20 74 61 72 67 65 74 29 0a 20 ynames target).
11450 20 23 66 29 0a 0a #f)..