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 6d 61 70 20 63 61 64 72 (paths (map cadr
0640: 20 28 63 6f 6e 66 69 67 66 3a 67 65 74 2d 73 65 (configf:get-se
0650: 63 74 69 6f 6e 20 63 66 67 64 61 74 20 22 74 65 ction cfgdat "te
0660: 73 74 73 2d 70 61 74 68 73 22 29 29 29 29 0a 20 sts-paths")))).
0670: 20 20 20 28 66 69 6c 74 65 72 20 28 6c 61 6d 62 (filter (lamb
0680: 64 61 20 28 64 29 0a 09 20 20 20 20 20 20 28 69 da (d).. (i
0690: 66 20 28 64 69 72 65 63 74 6f 72 79 2d 65 78 69 f (directory-exi
06a0: 73 74 73 3f 20 64 29 0a 09 09 20 20 64 0a 09 09 sts? d)... d...
06b0: 20 20 28 62 65 67 69 6e 0a 09 09 20 20 20 20 28 (begin... (
06c0: 69 66 20 28 63 6f 6d 6d 6f 6e 3a 6c 6f 77 2d 6e if (common:low-n
06d0: 6f 69 73 65 2d 70 72 69 6e 74 20 36 30 20 22 74 oise-print 60 "t
06e0: 65 73 74 73 3a 67 65 74 2d 74 65 73 74 73 2d 73 ests:get-tests-s
06f0: 65 61 72 63 68 2d 70 61 74 68 22 20 64 29 0a 09 earch-path" d)..
0700: 09 09 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 ..(debug:print 0
0710: 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f *default-log-po
0720: 72 74 2a 20 22 57 41 52 4e 49 4e 47 3a 20 70 72 rt* "WARNING: pr
0730: 6f 62 6c 65 6d 20 77 69 74 68 20 64 69 72 65 63 oblem with direc
0740: 74 6f 72 79 20 22 20 64 20 22 2c 20 64 72 6f 70 tory " d ", drop
0750: 70 69 6e 67 20 69 74 20 66 72 6f 6d 20 74 65 73 ping it from tes
0760: 74 73 20 70 61 74 68 22 29 29 0a 09 09 20 20 20 ts path"))...
0770: 20 23 66 29 29 29 0a 09 20 20 20 20 28 61 70 70 #f))).. (app
0780: 65 6e 64 20 70 61 74 68 73 20 28 6c 69 73 74 20 end paths (list
0790: 28 63 6f 6e 63 20 2a 74 6f 70 70 61 74 68 2a 20 (conc *toppath*
07a0: 22 2f 74 65 73 74 73 22 29 29 29 29 29 29 0a 0a "/tests"))))))..
07b0: 28 64 65 66 69 6e 65 20 28 74 65 73 74 73 3a 67 (define (tests:g
07c0: 65 74 2d 76 61 6c 69 64 2d 74 65 73 74 73 20 74 et-valid-tests t
07d0: 65 73 74 2d 72 65 67 69 73 74 72 79 20 74 65 73 est-registry tes
07e0: 74 73 2d 70 61 74 68 73 29 0a 20 20 28 69 66 20 ts-paths). (if
07f0: 28 6e 75 6c 6c 3f 20 74 65 73 74 73 2d 70 61 74 (null? tests-pat
0800: 68 73 29 20 0a 20 20 20 20 20 20 74 65 73 74 2d hs) . test-
0810: 72 65 67 69 73 74 72 79 0a 20 20 20 20 20 20 28 registry. (
0820: 6c 65 74 20 6c 6f 6f 70 20 28 28 68 65 64 20 28 let loop ((hed (
0830: 63 61 72 20 74 65 73 74 73 2d 70 61 74 68 73 29 car tests-paths)
0840: 29 0a 09 09 20 28 74 61 6c 20 28 63 64 72 20 74 )... (tal (cdr t
0850: 65 73 74 73 2d 70 61 74 68 73 29 29 29 0a 09 28 ests-paths)))..(
0860: 69 66 20 28 66 69 6c 65 2d 65 78 69 73 74 73 3f if (file-exists?
0870: 20 68 65 64 29 0a 09 20 20 20 20 28 66 6f 72 2d hed).. (for-
0880: 65 61 63 68 20 28 6c 61 6d 62 64 61 20 28 74 65 each (lambda (te
0890: 73 74 2d 70 61 74 68 29 0a 09 09 09 28 6c 65 74 st-path)....(let
08a0: 2a 20 28 28 74 6e 61 6d 65 20 20 20 28 6c 61 73 * ((tname (las
08b0: 74 20 28 73 74 72 69 6e 67 2d 73 70 6c 69 74 20 t (string-split
08c0: 74 65 73 74 2d 70 61 74 68 20 22 2f 22 29 29 29 test-path "/")))
08d0: 0a 09 09 09 20 20 20 20 20 20 20 28 74 63 6f 6e .... (tcon
08e0: 66 69 67 20 28 63 6f 6e 63 20 74 65 73 74 2d 70 fig (conc test-p
08f0: 61 74 68 20 22 2f 74 65 73 74 63 6f 6e 66 69 67 ath "/testconfig
0900: 22 29 29 29 0a 09 09 09 20 20 28 69 66 20 28 61 "))).... (if (a
0910: 6e 64 20 28 6e 6f 74 20 28 68 61 73 68 2d 74 61 nd (not (hash-ta
0920: 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 ble-ref/default
0930: 74 65 73 74 2d 72 65 67 69 73 74 72 79 20 74 6e test-registry tn
0940: 61 6d 65 20 23 66 29 29 0a 09 09 09 09 20 20 20 ame #f)).....
0950: 28 66 69 6c 65 2d 65 78 69 73 74 73 3f 20 74 63 (file-exists? tc
0960: 6f 6e 66 69 67 29 29 0a 09 09 09 20 20 20 20 20 onfig))....
0970: 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 (hash-table-set
0980: 21 20 74 65 73 74 2d 72 65 67 69 73 74 72 79 20 ! test-registry
0990: 74 6e 61 6d 65 20 74 65 73 74 2d 70 61 74 68 29 tname test-path)
09a0: 29 29 29 0a 09 09 20 20 20 20 20 20 28 67 6c 6f )))... (glo
09b0: 62 20 28 63 6f 6e 63 20 68 65 64 20 22 2f 2a 22 b (conc hed "/*"
09c0: 29 29 29 29 0a 09 28 69 66 20 28 6e 75 6c 6c 3f ))))..(if (null?
09d0: 20 74 61 6c 29 0a 09 20 20 20 20 74 65 73 74 2d tal).. test-
09e0: 72 65 67 69 73 74 72 79 0a 09 20 20 20 20 28 6c registry.. (l
09f0: 6f 6f 70 20 28 63 61 72 20 74 61 6c 29 28 63 64 oop (car tal)(cd
0a00: 72 20 74 61 6c 29 29 29 29 29 29 0a 0a 28 64 65 r tal))))))..(de
0a10: 66 69 6e 65 20 28 74 65 73 74 73 3a 66 69 6c 74 fine (tests:filt
0a20: 65 72 2d 74 65 73 74 2d 6e 61 6d 65 73 20 74 65 er-test-names te
0a30: 73 74 2d 6e 61 6d 65 73 20 74 65 73 74 2d 70 61 st-names test-pa
0a40: 74 74 73 29 0a 20 20 28 64 65 6c 65 74 65 2d 64 tts). (delete-d
0a50: 75 70 6c 69 63 61 74 65 73 0a 20 20 20 28 66 69 uplicates. (fi
0a60: 6c 74 65 72 20 28 6c 61 6d 62 64 61 20 28 74 65 lter (lambda (te
0a70: 73 74 6e 61 6d 65 29 0a 09 20 20 20 20 20 28 74 stname).. (t
0a80: 65 73 74 73 3a 6d 61 74 63 68 20 74 65 73 74 2d ests:match test-
0a90: 70 61 74 74 73 20 74 65 73 74 6e 61 6d 65 20 23 patts testname #
0aa0: 66 29 29 0a 09 20 20 20 74 65 73 74 2d 6e 61 6d f)).. test-nam
0ab0: 65 73 29 29 29 0a 0a 3b 3b 20 69 74 65 6d 6d 61 es)))..;; itemma
0ac0: 70 20 69 73 20 61 20 6c 69 73 74 20 6f 66 20 74 p is a list of t
0ad0: 65 73 74 6e 61 6d 65 20 70 61 74 74 65 72 6e 73 estname patterns
0ae0: 20 74 6f 20 6d 61 70 73 0a 3b 3b 20 20 20 20 20 to maps.;;
0af0: 74 65 73 74 31 20 2e 2a 2f 62 61 72 2f 28 5c 64 test1 .*/bar/(\d
0b00: 2b 29 20 66 6f 6f 2f 5c 31 0a 3b 3b 20 20 20 20 +) foo/\1.;;
0b10: 20 25 20 20 20 20 20 66 6f 6f 2f 28 5b 5e 2f 5d % foo/([^/]
0b20: 2b 29 20 20 5c 31 2f 62 61 72 0a 3b 3b 0a 3b 3b +) \1/bar.;;.;;
0b30: 20 23 20 4e 4f 54 45 3a 20 74 68 65 20 6c 69 6e # NOTE: the lin
0b40: 65 20 77 69 74 68 20 74 68 65 20 73 69 6e 67 6c e with the singl
0b50: 65 20 25 20 63 6f 75 6c 64 20 62 65 20 74 68 65 e % could be the
0b60: 20 72 65 73 75 6c 74 20 6f 66 0a 3b 3b 20 23 20 result of.;; #
0b70: 20 20 20 20 20 20 69 74 65 6d 6d 61 70 20 65 6e itemmap en
0b80: 74 72 79 20 69 6e 20 72 65 71 75 69 72 65 6d 65 try in requireme
0b90: 6e 74 73 20 28 6c 65 67 61 63 79 29 2e 20 54 68 nts (legacy). Th
0ba0: 65 20 69 74 65 6d 6d 61 70 0a 3b 3b 20 23 20 20 e itemmap.;; #
0bb0: 20 20 20 20 20 72 65 71 75 69 72 65 6d 65 6e 74 requirement
0bc0: 73 20 65 6e 74 72 79 20 69 73 20 64 65 70 72 65 s entry is depre
0bd0: 63 61 74 65 64 0a 3b 3b 0a 28 64 65 66 69 6e 65 cated.;;.(define
0be0: 20 28 74 65 73 74 73 3a 67 65 74 2d 69 74 65 6d (tests:get-item
0bf0: 6d 61 70 73 20 74 63 6f 6e 66 69 67 29 0a 20 20 maps tconfig).
0c00: 28 6c 65 74 20 28 28 62 61 73 65 2d 69 74 65 6d (let ((base-item
0c10: 6d 61 70 20 20 28 63 6f 6e 66 69 67 66 3a 6c 6f map (configf:lo
0c20: 6f 6b 75 70 20 74 63 6f 6e 66 69 67 20 22 72 65 okup tconfig "re
0c30: 71 75 69 72 65 6d 65 6e 74 73 22 20 22 69 74 65 quirements" "ite
0c40: 6d 6d 61 70 22 29 29 0a 09 28 69 74 65 6d 6d 61 mmap"))..(itemma
0c50: 70 2d 74 61 62 6c 65 20 28 63 6f 6e 66 69 67 66 p-table (configf
0c60: 3a 67 65 74 2d 73 65 63 74 69 6f 6e 20 74 63 6f :get-section tco
0c70: 6e 66 69 67 20 22 69 74 65 6d 6d 61 70 22 29 29 nfig "itemmap"))
0c80: 29 0a 20 20 20 20 28 61 70 70 65 6e 64 20 28 69 ). (append (i
0c90: 66 20 62 61 73 65 2d 69 74 65 6d 6d 61 70 0a 09 f base-itemmap..
0ca0: 09 28 6c 69 73 74 20 28 6c 69 73 74 20 22 25 22 .(list (list "%"
0cb0: 20 62 61 73 65 2d 69 74 65 6d 6d 61 70 29 29 0a base-itemmap)).
0cc0: 09 09 27 28 29 29 0a 09 20 20 20 20 28 69 66 20 ..'()).. (if
0cd0: 69 74 65 6d 6d 61 70 2d 74 61 62 6c 65 0a 09 09 itemmap-table...
0ce0: 69 74 65 6d 6d 61 70 2d 74 61 62 6c 65 0a 09 09 itemmap-table...
0cf0: 27 28 29 29 29 29 29 0a 0a 3b 3b 20 67 69 76 65 '()))))..;; give
0d00: 6e 20 61 20 6c 69 73 74 20 6f 66 20 69 74 65 6d n a list of item
0d10: 6d 61 70 73 20 28 74 65 73 74 6e 61 6d 65 20 2e maps (testname .
0d20: 20 6d 61 70 29 2c 20 72 65 74 75 72 6e 20 74 68 map), return th
0d30: 65 20 66 69 72 73 74 20 6d 61 74 63 68 0a 3b 3b e first match.;;
0d40: 0a 28 64 65 66 69 6e 65 20 28 74 65 73 74 73 3a .(define (tests:
0d50: 6c 6f 6f 6b 75 70 2d 69 74 65 6d 6d 61 70 20 69 lookup-itemmap i
0d60: 74 65 6d 6d 61 70 73 20 74 65 73 74 6e 61 6d 65 temmaps testname
0d70: 29 0a 20 20 28 6c 65 74 20 28 28 62 65 73 74 2d ). (let ((best-
0d80: 6d 61 74 63 68 65 73 20 28 66 69 6c 74 65 72 20 matches (filter
0d90: 28 6c 61 6d 62 64 61 20 28 69 74 65 6d 6d 61 70 (lambda (itemmap
0da0: 29 0a 09 09 09 09 28 74 65 73 74 73 3a 6d 61 74 ).....(tests:mat
0db0: 63 68 20 28 63 61 72 20 69 74 65 6d 6d 61 70 29 ch (car itemmap)
0dc0: 20 74 65 73 74 6e 61 6d 65 20 23 66 29 29 0a 09 testname #f))..
0dd0: 09 09 20 20 20 20 20 20 69 74 65 6d 6d 61 70 73 .. itemmaps
0de0: 29 29 29 0a 20 20 20 20 28 69 66 20 28 6e 75 6c ))). (if (nul
0df0: 6c 3f 20 62 65 73 74 2d 6d 61 74 63 68 65 73 29 l? best-matches)
0e00: 0a 09 23 66 0a 09 28 6c 65 74 20 28 28 72 65 73 ..#f..(let ((res
0e10: 20 28 63 61 72 20 62 65 73 74 2d 6d 61 74 63 68 (car best-match
0e20: 65 73 29 29 29 0a 09 20 20 3b 3b 20 28 64 65 62 es))).. ;; (deb
0e30: 75 67 3a 70 72 69 6e 74 20 30 20 2a 64 65 66 61 ug:print 0 *defa
0e40: 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 72 ult-log-port* "r
0e50: 65 73 3d 22 20 72 65 73 29 0a 09 20 20 28 63 6f es=" res).. (co
0e60: 6e 64 0a 09 20 20 20 28 28 73 74 72 69 6e 67 3f nd.. ((string?
0e70: 20 72 65 73 29 20 72 65 73 29 20 3b 3b 3b 20 46 res) res) ;;; F
0e80: 49 58 20 54 48 45 20 52 4f 4f 54 20 43 41 55 53 IX THE ROOT CAUS
0e90: 45 20 48 45 52 45 20 2e 2e 2e 2e 0a 09 20 20 20 E HERE ......
0ea0: 28 28 6e 75 6c 6c 3f 20 72 65 73 29 20 20 20 23 ((null? res) #
0eb0: 66 29 0a 09 20 20 20 28 28 73 74 72 69 6e 67 3f f).. ((string?
0ec0: 20 28 63 64 72 20 72 65 73 29 29 20 28 63 64 72 (cdr res)) (cdr
0ed0: 20 72 65 73 29 29 20 20 3b 3b 20 69 74 20 69 73 res)) ;; it is
0ee0: 20 61 20 70 61 69 72 0a 09 20 20 20 28 28 73 74 a pair.. ((st
0ef0: 72 69 6e 67 3f 20 28 63 61 64 72 20 72 65 73 29 ring? (cadr res)
0f00: 29 28 63 61 64 72 20 72 65 73 29 29 20 3b 3b 20 )(cadr res)) ;;
0f10: 69 74 20 69 73 20 61 20 6c 69 73 74 0a 09 20 20 it is a list..
0f20: 20 28 65 6c 73 65 20 63 61 64 72 20 72 65 73 29 (else cadr res)
0f30: 29 29 29 29 29 0a 0a 3b 3b 20 72 65 74 75 72 6e )))))..;; return
0f40: 20 69 74 65 6d 73 20 67 69 76 65 6e 20 63 6f 6e items given con
0f50: 66 69 67 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 fig.;;.(define (
0f60: 74 65 73 74 73 3a 67 65 74 2d 69 74 65 6d 73 20 tests:get-items
0f70: 74 63 6f 6e 66 69 67 29 0a 20 20 28 6c 65 74 20 tconfig). (let
0f80: 28 28 69 74 65 6d 73 20 20 20 20 20 20 28 68 61 ((items (ha
0f90: 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 sh-table-ref/def
0fa0: 61 75 6c 74 20 74 63 6f 6e 66 69 67 20 22 69 74 ault tconfig "it
0fb0: 65 6d 73 22 20 23 66 29 29 20 3b 3b 20 69 74 65 ems" #f)) ;; ite
0fc0: 6d 73 20 34 0a 09 28 69 74 65 6d 73 74 61 62 6c ms 4..(itemstabl
0fd0: 65 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 e (hash-table-re
0fe0: 66 2f 64 65 66 61 75 6c 74 20 74 63 6f 6e 66 69 f/default tconfi
0ff0: 67 20 22 69 74 65 6d 73 74 61 62 6c 65 22 20 23 g "itemstable" #
1000: 66 29 29 29 20 0a 20 20 20 20 3b 3b 20 69 66 20 f))) . ;; if
1010: 65 69 74 68 65 72 20 69 74 65 6d 73 20 6f 72 20 either items or
1020: 69 74 65 6d 73 20 74 61 62 6c 65 20 69 73 20 61 items table is a
1030: 20 70 72 6f 63 20 72 65 74 75 72 6e 20 69 74 20 proc return it
1040: 73 6f 20 74 65 73 74 20 72 75 6e 6e 69 6e 67 0a so test running.
1050: 20 20 20 20 3b 3b 20 70 72 6f 63 65 73 73 20 63 ;; process c
1060: 61 6e 20 6b 6e 6f 77 20 74 6f 20 63 61 6c 6c 20 an know to call
1070: 69 74 65 6d 73 3a 67 65 74 2d 69 74 65 6d 73 2d items:get-items-
1080: 66 72 6f 6d 2d 63 6f 6e 66 69 67 0a 20 20 20 20 from-config.
1090: 3b 3b 20 69 66 20 65 69 74 68 65 72 20 69 73 20 ;; if either is
10a0: 61 20 6c 69 73 74 20 61 6e 64 20 6e 6f 6e 65 20 a list and none
10b0: 69 73 20 61 20 70 72 6f 63 20 67 6f 20 61 68 65 is a proc go ahe
10c0: 61 64 20 61 6e 64 20 63 61 6c 6c 20 67 65 74 2d ad and call get-
10d0: 69 74 65 6d 73 0a 20 20 20 20 3b 3b 20 6f 74 68 items. ;; oth
10e0: 65 72 77 69 73 65 20 72 65 74 75 72 6e 20 23 66 erwise return #f
10f0: 20 2d 20 74 68 69 73 20 69 73 20 6e 6f 74 20 61 - this is not a
1100: 6e 20 69 74 65 72 61 74 65 64 20 74 65 73 74 0a n iterated test.
1110: 20 20 20 20 28 63 6f 6e 64 0a 20 20 20 20 20 28 (cond. (
1120: 28 70 72 6f 63 65 64 75 72 65 3f 20 69 74 65 6d (procedure? item
1130: 73 29 20 20 20 20 20 20 0a 20 20 20 20 20 20 28 s) . (
1140: 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f debug:print-info
1150: 20 34 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 4 *default-log-
1160: 70 6f 72 74 2a 20 22 69 74 65 6d 73 20 69 73 20 port* "items is
1170: 61 20 70 72 6f 63 65 64 75 72 65 2c 20 77 69 6c a procedure, wil
1180: 6c 20 63 61 6c 63 20 6c 61 74 65 72 22 29 0a 20 l calc later").
1190: 20 20 20 20 20 69 74 65 6d 73 29 20 20 20 20 20 items)
11a0: 20 20 20 20 20 20 20 3b 3b 20 63 61 6c 63 20 6c ;; calc l
11b0: 61 74 65 72 0a 20 20 20 20 20 28 28 70 72 6f 63 ater. ((proc
11c0: 65 64 75 72 65 3f 20 69 74 65 6d 73 74 61 62 6c edure? itemstabl
11d0: 65 29 0a 20 20 20 20 20 20 28 64 65 62 75 67 3a e). (debug:
11e0: 70 72 69 6e 74 2d 69 6e 66 6f 20 34 20 2a 64 65 print-info 4 *de
11f0: 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 fault-log-port*
1200: 22 69 74 65 6d 73 74 61 62 6c 65 20 69 73 20 61 "itemstable is a
1210: 20 70 72 6f 63 65 64 75 72 65 2c 20 77 69 6c 6c procedure, will
1220: 20 63 61 6c 63 20 6c 61 74 65 72 22 29 0a 20 20 calc later").
1230: 20 20 20 20 69 74 65 6d 73 74 61 62 6c 65 29 20 itemstable)
1240: 20 20 20 20 20 20 3b 3b 20 63 61 6c 63 20 6c 61 ;; calc la
1250: 74 65 72 0a 20 20 20 20 20 28 28 66 69 6c 74 65 ter. ((filte
1260: 72 20 28 6c 61 6d 62 64 61 20 28 78 29 0a 09 09 r (lambda (x)...
1270: 28 6c 65 74 20 28 28 76 61 6c 20 28 63 61 72 20 (let ((val (car
1280: 78 29 29 29 0a 09 09 20 20 28 69 66 20 28 70 72 x)))... (if (pr
1290: 6f 63 65 64 75 72 65 3f 20 76 61 6c 29 20 76 61 ocedure? val) va
12a0: 6c 20 23 66 29 29 29 0a 09 20 20 20 20 20 20 28 l #f))).. (
12b0: 61 70 70 65 6e 64 20 28 69 66 20 28 6c 69 73 74 append (if (list
12c0: 3f 20 69 74 65 6d 73 29 20 69 74 65 6d 73 20 27 ? items) items '
12d0: 28 29 29 0a 09 09 20 20 20 20 20 20 28 69 66 20 ())... (if
12e0: 28 6c 69 73 74 3f 20 69 74 65 6d 73 74 61 62 6c (list? itemstabl
12f0: 65 29 20 69 74 65 6d 73 74 61 62 6c 65 20 27 28 e) itemstable '(
1300: 29 29 29 29 0a 20 20 20 20 20 20 27 68 61 76 65 )))). 'have
1310: 2d 70 72 6f 63 65 64 75 72 65 29 0a 20 20 20 20 -procedure).
1320: 20 28 28 6f 72 20 28 6c 69 73 74 3f 20 69 74 65 ((or (list? ite
1330: 6d 73 29 28 6c 69 73 74 3f 20 69 74 65 6d 73 74 ms)(list? itemst
1340: 61 62 6c 65 29 29 20 3b 3b 20 63 61 6c 63 20 6e able)) ;; calc n
1350: 6f 77 0a 20 20 20 20 20 20 28 64 65 62 75 67 3a ow. (debug:
1360: 70 72 69 6e 74 2d 69 6e 66 6f 20 34 20 2a 64 65 print-info 4 *de
1370: 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 fault-log-port*
1380: 22 69 74 65 6d 73 20 61 6e 64 20 69 74 65 6d 73 "items and items
1390: 74 61 62 6c 65 20 61 72 65 20 6c 69 73 74 73 2c table are lists,
13a0: 20 63 61 6c 63 20 6e 6f 77 5c 6e 22 0a 09 09 09 calc now\n"....
13b0: 22 20 20 20 20 69 74 65 6d 73 3a 20 22 20 69 74 " items: " it
13c0: 65 6d 73 20 22 20 69 74 65 6d 73 74 61 62 6c 65 ems " itemstable
13d0: 3a 20 22 20 69 74 65 6d 73 74 61 62 6c 65 29 0a : " itemstable).
13e0: 20 20 20 20 20 20 28 69 74 65 6d 73 3a 67 65 74 (items:get
13f0: 2d 69 74 65 6d 73 2d 66 72 6f 6d 2d 63 6f 6e 66 -items-from-conf
1400: 69 67 20 74 63 6f 6e 66 69 67 29 29 0a 20 20 20 ig tconfig)).
1410: 20 20 28 65 6c 73 65 20 23 66 29 29 29 29 20 20 (else #f))))
1420: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1430: 20 20 20 20 20 20 20 20 20 3b 3b 20 6e 6f 74 20 ;; not
1440: 69 74 65 72 61 74 65 64 0a 0a 0a 3b 3b 20 72 65 iterated...;; re
1450: 74 75 72 6e 73 20 77 61 69 74 6f 6e 73 20 77 61 turns waitons wa
1460: 69 74 6f 72 73 20 74 63 6f 6e 66 69 67 64 61 74 itors tconfigdat
1470: 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 74 65 73 .;;.(define (tes
1480: 74 73 3a 67 65 74 2d 77 61 69 74 6f 6e 73 20 74 ts:get-waitons t
1490: 65 73 74 2d 6e 61 6d 65 20 61 6c 6c 2d 74 65 73 est-name all-tes
14a0: 74 73 2d 72 65 67 69 73 74 72 79 29 0a 20 20 20 ts-registry).
14b0: 28 6c 65 74 2a 20 28 28 63 6f 6e 66 69 67 20 20 (let* ((config
14c0: 28 74 65 73 74 73 3a 67 65 74 2d 74 65 73 74 63 (tests:get-testc
14d0: 6f 6e 66 69 67 20 74 65 73 74 2d 6e 61 6d 65 20 onfig test-name
14e0: 61 6c 6c 2d 74 65 73 74 73 2d 72 65 67 69 73 74 all-tests-regist
14f0: 72 79 20 27 72 65 74 75 72 6e 2d 70 72 6f 63 73 ry 'return-procs
1500: 29 29 29 0a 20 20 20 20 20 28 6c 65 74 20 28 28 ))). (let ((
1510: 69 6e 73 74 72 20 28 69 66 20 63 6f 6e 66 69 67 instr (if config
1520: 20 0a 09 09 20 20 20 20 20 20 28 63 6f 6e 66 69 ... (confi
1530: 67 2d 6c 6f 6f 6b 75 70 20 63 6f 6e 66 69 67 20 g-lookup config
1540: 22 72 65 71 75 69 72 65 6d 65 6e 74 73 22 20 22 "requirements" "
1550: 77 61 69 74 6f 6e 22 29 0a 09 09 20 20 20 20 20 waiton")...
1560: 20 28 62 65 67 69 6e 20 3b 3b 20 4e 6f 20 63 6f (begin ;; No co
1570: 6e 66 69 67 20 6d 65 61 6e 73 20 74 68 69 73 20 nfig means this
1580: 69 73 20 61 20 6e 6f 6e 2d 65 78 69 73 74 61 6e is a non-existan
1590: 74 20 74 65 73 74 0a 09 09 09 28 64 65 62 75 67 t test....(debug
15a0: 3a 70 72 69 6e 74 2d 65 72 72 6f 72 20 30 20 2a :print-error 0 *
15b0: 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 default-log-port
15c0: 2a 20 22 6e 6f 6e 2d 65 78 69 73 74 65 6e 74 20 * "non-existent
15d0: 72 65 71 75 69 72 65 64 20 74 65 73 74 20 5c 22 required test \"
15e0: 22 20 74 65 73 74 2d 6e 61 6d 65 20 22 5c 22 22 " test-name "\""
15f0: 29 0a 09 09 09 28 65 78 69 74 20 31 29 29 29 29 )....(exit 1))))
1600: 0a 09 20 20 20 28 69 6e 73 74 72 32 20 28 69 66 .. (instr2 (if
1610: 20 63 6f 6e 66 69 67 0a 09 09 20 20 20 20 20 20 config...
1620: 20 28 63 6f 6e 66 69 67 2d 6c 6f 6f 6b 75 70 20 (config-lookup
1630: 63 6f 6e 66 69 67 20 22 72 65 71 75 69 72 65 6d config "requirem
1640: 65 6e 74 73 22 20 22 77 61 69 74 6f 72 22 29 0a ents" "waitor").
1650: 09 09 20 20 20 20 20 20 20 22 22 29 29 29 0a 20 .. ""))).
1660: 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 (debug:pri
1670: 6e 74 2d 69 6e 66 6f 20 38 20 2a 64 65 66 61 75 nt-info 8 *defau
1680: 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 77 61 lt-log-port* "wa
1690: 69 74 6f 6e 73 20 73 74 72 69 6e 67 20 69 73 20 itons string is
16a0: 22 20 69 6e 73 74 72 20 22 2c 20 77 61 69 74 6f " instr ", waito
16b0: 72 73 20 73 74 72 69 6e 67 20 69 73 20 22 20 69 rs string is " i
16c0: 6e 73 74 72 32 29 0a 20 20 20 20 20 20 20 28 6c nstr2). (l
16d0: 65 74 20 28 28 6e 65 77 77 61 69 74 6f 6e 73 0a et ((newwaitons.
16e0: 09 20 20 20 20 20 20 28 73 74 72 69 6e 67 2d 73 . (string-s
16f0: 70 6c 69 74 20 28 63 6f 6e 64 0a 09 09 09 20 20 plit (cond....
1700: 20 20 20 28 28 70 72 6f 63 65 64 75 72 65 3f 20 ((procedure?
1710: 69 6e 73 74 72 29 20 3b 3b 20 68 65 72 65 20 0a instr) ;; here .
1720: 09 09 09 20 20 20 20 20 20 28 6c 65 74 20 28 28 ... (let ((
1730: 72 65 73 20 28 69 6e 73 74 72 29 29 29 0a 09 09 res (instr)))...
1740: 09 09 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 ..(debug:print-i
1750: 6e 66 6f 20 38 20 2a 64 65 66 61 75 6c 74 2d 6c nfo 8 *default-l
1760: 6f 67 2d 70 6f 72 74 2a 20 22 77 61 69 74 6f 6e og-port* "waiton
1770: 20 70 72 6f 63 65 64 75 72 65 20 72 65 73 75 6c procedure resul
1780: 74 73 20 69 6e 20 73 74 72 69 6e 67 20 22 20 72 ts in string " r
1790: 65 73 20 22 20 66 6f 72 20 74 65 73 74 20 22 20 es " for test "
17a0: 74 65 73 74 2d 6e 61 6d 65 29 0a 09 09 09 09 72 test-name).....r
17b0: 65 73 29 29 0a 09 09 09 20 20 20 20 20 28 28 73 es)).... ((s
17c0: 74 72 69 6e 67 3f 20 69 6e 73 74 72 29 20 20 20 tring? instr)
17d0: 20 20 69 6e 73 74 72 29 0a 09 09 09 20 20 20 20 instr)....
17e0: 20 28 65 6c 73 65 20 0a 09 09 09 20 20 20 20 20 (else ....
17f0: 20 3b 3b 20 4e 4f 54 45 3a 20 54 68 69 73 20 69 ;; NOTE: This i
1800: 73 20 61 63 74 75 61 6c 6c 79 20 74 68 65 20 63 s actually the c
1810: 61 73 65 20 6f 66 20 2a 6e 6f 2a 20 77 61 69 74 ase of *no* wait
1820: 6f 6e 73 21 20 3b 3b 20 28 64 65 62 75 67 3a 70 ons! ;; (debug:p
1830: 72 69 6e 74 2d 65 72 72 6f 72 20 30 20 2a 64 65 rint-error 0 *de
1840: 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 fault-log-port*
1850: 22 73 6f 6d 65 74 68 69 6e 67 20 77 65 6e 74 20 "something went
1860: 77 72 6f 6e 67 20 69 6e 20 70 72 6f 63 65 73 73 wrong in process
1870: 69 6e 67 20 77 61 69 74 6f 6e 73 20 66 6f 72 20 ing waitons for
1880: 74 65 73 74 20 22 20 74 65 73 74 2d 6e 61 6d 65 test " test-name
1890: 29 0a 09 09 09 20 20 20 20 20 20 22 22 29 29 29 ).... "")))
18a0: 29 0a 09 20 20 20 20 20 28 6e 65 77 77 61 69 74 ).. (newwait
18b0: 6f 72 73 0a 09 20 20 20 20 20 20 28 73 74 72 69 ors.. (stri
18c0: 6e 67 2d 73 70 6c 69 74 20 28 63 6f 6e 64 0a 09 ng-split (cond..
18d0: 09 09 20 20 20 20 20 28 28 70 72 6f 63 65 64 75 .. ((procedu
18e0: 72 65 3f 20 69 6e 73 74 72 32 29 0a 09 09 09 20 re? instr2)....
18f0: 20 20 20 20 20 28 6c 65 74 20 28 28 72 65 73 20 (let ((res
1900: 28 69 6e 73 74 72 32 29 29 29 0a 09 09 09 09 28 (instr2))).....(
1910: 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f debug:print-info
1920: 20 38 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 8 *default-log-
1930: 70 6f 72 74 2a 20 22 77 61 69 74 6f 72 20 70 72 port* "waitor pr
1940: 6f 63 65 64 75 72 65 20 72 65 73 75 6c 74 73 20 ocedure results
1950: 69 6e 20 73 74 72 69 6e 67 20 22 20 72 65 73 20 in string " res
1960: 22 20 66 6f 72 20 74 65 73 74 20 22 20 74 65 73 " for test " tes
1970: 74 2d 6e 61 6d 65 29 0a 09 09 09 09 72 65 73 29 t-name).....res)
1980: 29 0a 09 09 09 20 20 20 20 20 28 28 73 74 72 69 ).... ((stri
1990: 6e 67 3f 20 69 6e 73 74 72 32 29 20 20 20 20 20 ng? instr2)
19a0: 69 6e 73 74 72 32 29 0a 09 09 09 20 20 20 20 20 instr2)....
19b0: 28 65 6c 73 65 20 0a 09 09 09 20 20 20 20 20 20 (else ....
19c0: 3b 3b 20 4e 4f 54 45 3a 20 54 68 69 73 20 69 73 ;; NOTE: This is
19d0: 20 61 63 74 75 61 6c 6c 79 20 74 68 65 20 63 61 actually the ca
19e0: 73 65 20 6f 66 20 2a 6e 6f 2a 20 77 61 69 74 6f se of *no* waito
19f0: 6e 73 21 20 3b 3b 20 28 64 65 62 75 67 3a 70 72 ns! ;; (debug:pr
1a00: 69 6e 74 2d 65 72 72 6f 72 20 30 20 2a 64 65 66 int-error 0 *def
1a10: 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 ault-log-port* "
1a20: 73 6f 6d 65 74 68 69 6e 67 20 77 65 6e 74 20 77 something went w
1a30: 72 6f 6e 67 20 69 6e 20 70 72 6f 63 65 73 73 69 rong in processi
1a40: 6e 67 20 77 61 69 74 6f 6e 73 20 66 6f 72 20 74 ng waitons for t
1a50: 65 73 74 20 22 20 74 65 73 74 2d 6e 61 6d 65 29 est " test-name)
1a60: 0a 09 09 09 20 20 20 20 20 20 22 22 29 29 29 29 .... ""))))
1a70: 29 0a 09 20 28 76 61 6c 75 65 73 0a 09 20 20 3b ).. (values.. ;
1a80: 3b 20 74 68 65 20 77 61 69 74 6f 6e 73 0a 09 20 ; the waitons..
1a90: 20 28 66 69 6c 74 65 72 20 28 6c 61 6d 62 64 61 (filter (lambda
1aa0: 20 28 78 29 0a 09 09 20 20 20 20 28 69 66 20 28 (x)... (if (
1ab0: 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 hash-table-ref/d
1ac0: 65 66 61 75 6c 74 20 61 6c 6c 2d 74 65 73 74 73 efault all-tests
1ad0: 2d 72 65 67 69 73 74 72 79 20 78 20 23 66 29 0a -registry x #f).
1ae0: 09 09 09 23 74 0a 09 09 09 28 62 65 67 69 6e 0a ...#t....(begin.
1af0: 09 09 09 20 20 28 64 65 62 75 67 3a 70 72 69 6e ... (debug:prin
1b00: 74 2d 65 72 72 6f 72 20 30 20 2a 64 65 66 61 75 t-error 0 *defau
1b10: 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 74 65 lt-log-port* "te
1b20: 73 74 20 22 20 74 65 73 74 2d 6e 61 6d 65 20 22 st " test-name "
1b30: 20 68 61 73 20 75 6e 72 65 63 6f 67 6e 69 73 65 has unrecognise
1b40: 64 20 77 61 69 74 6f 6e 20 74 65 73 74 6e 61 6d d waiton testnam
1b50: 65 20 22 20 78 29 0a 09 09 09 20 20 23 66 29 29 e " x).... #f))
1b60: 29 0a 09 09 20 20 6e 65 77 77 61 69 74 6f 6e 73 )... newwaitons
1b70: 29 0a 09 20 20 28 66 69 6c 74 65 72 20 28 6c 61 ).. (filter (la
1b80: 6d 62 64 61 20 28 78 29 0a 09 09 20 20 20 20 28 mbda (x)... (
1b90: 69 66 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 if (hash-table-r
1ba0: 65 66 2f 64 65 66 61 75 6c 74 20 61 6c 6c 2d 74 ef/default all-t
1bb0: 65 73 74 73 2d 72 65 67 69 73 74 72 79 20 78 20 ests-registry x
1bc0: 23 66 29 0a 09 09 09 23 74 0a 09 09 09 28 62 65 #f)....#t....(be
1bd0: 67 69 6e 0a 09 09 09 20 20 28 64 65 62 75 67 3a gin.... (debug:
1be0: 70 72 69 6e 74 2d 65 72 72 6f 72 20 30 20 2a 64 print-error 0 *d
1bf0: 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a efault-log-port*
1c00: 20 22 74 65 73 74 20 22 20 74 65 73 74 2d 6e 61 "test " test-na
1c10: 6d 65 20 22 20 68 61 73 20 75 6e 72 65 63 6f 67 me " has unrecog
1c20: 6e 69 73 65 64 20 77 61 69 74 6f 6e 20 74 65 73 nised waiton tes
1c30: 74 6e 61 6d 65 20 22 20 78 29 0a 09 09 09 20 20 tname " x)....
1c40: 23 66 29 29 29 0a 09 09 20 20 6e 65 77 77 61 69 #f)))... newwai
1c50: 74 6f 72 73 29 0a 09 20 20 63 6f 6e 66 69 67 29 tors).. config)
1c60: 29 29 29 29 0a 09 09 09 09 09 20 20 20 20 20 0a ))))...... .
1c70: 3b 3b 20 67 69 76 65 6e 20 77 61 69 74 69 6e 67 ;; given waiting
1c80: 2d 74 65 73 74 20 74 68 61 74 20 69 73 20 77 61 -test that is wa
1c90: 69 74 69 6e 67 20 6f 6e 20 77 61 69 74 6f 6e 2d iting on waiton-
1ca0: 74 65 73 74 20 65 78 74 65 6e 64 20 74 65 73 74 test extend test
1cb0: 2d 70 61 74 74 20 61 70 70 72 6f 70 72 69 61 74 -patt appropriat
1cc0: 65 6c 79 0a 3b 3b 0a 3b 3b 20 20 67 65 6e 6c 69 ely.;;.;; genli
1cd0: 62 2f 74 65 73 74 63 6f 6e 66 69 67 20 20 20 20 b/testconfig
1ce0: 20 20 20 20 20 20 20 20 20 20 20 73 69 6d 2f 74 sim/t
1cf0: 65 73 74 63 6f 6e 66 69 67 0a 3b 3b 20 20 67 65 estconfig.;; ge
1d00: 6e 6c 69 62 2f 73 63 68 20 20 20 20 20 20 20 20 nlib/sch
1d10: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 73 69 si
1d20: 6d 2f 73 63 68 2f 63 65 6c 6c 31 0a 3b 3b 0a 3b m/sch/cell1.;;.;
1d30: 3b 20 20 5b 72 65 71 75 69 72 65 6d 65 6e 74 73 ; [requirements
1d40: 5d 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ]
1d50: 20 20 20 5b 72 65 71 75 69 72 65 6d 65 6e 74 73 [requirements
1d60: 5d 0a 3b 3b 20 20 20 20 20 20 20 20 20 20 20 20 ].;;
1d70: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1d80: 20 20 20 20 20 20 6d 6f 64 65 20 69 74 65 6d 77 mode itemw
1d90: 61 69 74 0a 3b 3b 20 20 20 20 20 20 20 20 20 20 ait.;;
1da0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1db0: 20 20 20 20 20 20 20 20 23 20 74 72 69 6d 20 6f # trim o
1dc0: 66 66 20 74 68 65 20 63 65 6c 6c 20 74 6f 20 64 ff the cell to d
1dd0: 65 74 65 72 6d 69 6e 65 20 77 68 61 74 20 74 6f etermine what to
1de0: 20 72 75 6e 20 66 6f 72 20 67 65 6e 6c 69 62 0a run for genlib.
1df0: 3b 3b 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 20 20 69 74 65 6d 6d 61 70 20 2f 2e 2a 0a itemmap /.*.
1e20: 3b 3b 0a 3b 3b 20 20 20 20 20 20 20 20 20 20 20 ;;.;;
1e30: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1e40: 20 20 20 20 20 20 20 77 61 69 74 69 6e 67 2d 74 waiting-t
1e50: 65 73 74 20 69 73 20 77 61 69 74 69 6e 67 20 6f est is waiting o
1e60: 6e 20 77 61 69 74 6f 6e 2d 74 65 73 74 20 73 6f n waiton-test so
1e70: 20 77 65 20 6e 65 65 64 20 74 6f 20 63 72 65 61 we need to crea
1e80: 74 65 20 61 20 70 61 74 74 65 72 6e 20 66 6f 72 te a pattern for
1e90: 20 77 61 69 74 6f 6e 2d 74 65 73 74 20 67 69 76 waiton-test giv
1ea0: 65 6e 20 77 61 69 74 69 6e 67 2d 74 65 73 74 20 en waiting-test
1eb0: 61 6e 64 20 69 74 65 6d 6d 61 70 0a 28 64 65 66 and itemmap.(def
1ec0: 69 6e 65 20 28 74 65 73 74 73 3a 65 78 74 65 6e ine (tests:exten
1ed0: 64 2d 74 65 73 74 2d 70 61 74 74 73 20 74 65 73 d-test-patts tes
1ee0: 74 2d 70 61 74 74 20 77 61 69 74 69 6e 67 2d 74 t-patt waiting-t
1ef0: 65 73 74 20 77 61 69 74 6f 6e 2d 74 65 73 74 20 est waiton-test
1f00: 69 74 65 6d 6d 61 70 73 29 0a 20 20 28 6c 65 74 itemmaps). (let
1f10: 2a 20 28 28 69 74 65 6d 6d 61 70 20 20 20 20 20 * ((itemmap
1f20: 20 20 20 20 20 28 74 65 73 74 73 3a 6c 6f 6f 6b (tests:look
1f30: 75 70 2d 69 74 65 6d 6d 61 70 20 69 74 65 6d 6d up-itemmap itemm
1f40: 61 70 73 20 77 61 69 74 6f 6e 2d 74 65 73 74 29 aps waiton-test)
1f50: 29 0a 09 20 28 70 61 74 74 73 20 20 20 20 20 20 ).. (patts
1f60: 20 20 20 20 20 20 28 73 74 72 69 6e 67 2d 73 70 (string-sp
1f70: 6c 69 74 20 74 65 73 74 2d 70 61 74 74 20 22 2c lit test-patt ",
1f80: 22 29 29 0a 09 20 28 77 61 69 74 69 6e 67 2d 74 ")).. (waiting-t
1f90: 65 73 74 2d 6c 65 6e 20 28 2b 20 28 73 74 72 69 est-len (+ (stri
1fa0: 6e 67 2d 6c 65 6e 67 74 68 20 77 61 69 74 69 6e ng-length waitin
1fb0: 67 2d 74 65 73 74 29 20 31 29 29 0a 09 20 28 70 g-test) 1)).. (p
1fc0: 61 74 74 73 2d 77 61 69 74 6f 6e 20 20 20 20 20 atts-waiton
1fd0: 28 6d 61 70 20 28 6c 61 6d 62 64 61 20 28 78 29 (map (lambda (x)
1fe0: 20 20 3b 3b 20 66 6f 72 20 65 61 63 68 20 69 6e ;; for each in
1ff0: 63 6f 6d 69 6e 67 20 70 61 74 74 20 74 68 61 74 coming patt that
2000: 20 6d 61 74 63 68 65 73 20 74 68 65 20 77 61 69 matches the wai
2010: 74 69 6e 67 20 74 65 73 74 0a 09 09 09 09 20 20 ting test.....
2020: 28 6c 65 74 2a 20 28 28 6d 6f 64 70 61 74 74 20 (let* ((modpatt
2030: 28 69 66 20 69 74 65 6d 6d 61 70 20 28 64 62 3a (if itemmap (db:
2040: 63 6f 6e 76 65 72 74 2d 74 65 73 74 2d 69 74 65 convert-test-ite
2050: 6d 70 61 74 68 20 78 20 69 74 65 6d 6d 61 70 29 mpath x itemmap)
2060: 20 78 29 29 20 0a 09 09 09 09 09 20 28 6e 65 77 x)) ...... (new
2070: 70 61 74 74 20 28 63 6f 6e 63 20 77 61 69 74 6f patt (conc waito
2080: 6e 2d 74 65 73 74 20 22 2f 22 20 28 73 75 62 73 n-test "/" (subs
2090: 74 72 69 6e 67 20 6d 6f 64 70 61 74 74 20 77 61 tring modpatt wa
20a0: 69 74 69 6e 67 2d 74 65 73 74 2d 6c 65 6e 20 28 iting-test-len (
20b0: 73 74 72 69 6e 67 2d 6c 65 6e 67 74 68 20 6d 6f string-length mo
20c0: 64 70 61 74 74 29 29 29 29 29 0a 09 09 09 09 20 dpatt))))).....
20d0: 20 20 20 3b 3b 20 28 63 6f 6e 63 20 77 61 69 74 ;; (conc wait
20e0: 69 6e 67 2d 74 65 73 74 20 22 2f 2c 22 20 77 61 ing-test "/," wa
20f0: 69 74 69 6e 67 2d 74 65 73 74 20 22 2f 22 20 28 iting-test "/" (
2100: 73 75 62 73 74 72 69 6e 67 20 6d 6f 64 70 61 74 substring modpat
2110: 74 20 77 61 69 74 6f 6e 2d 74 65 73 74 2d 6c 65 t waiton-test-le
2120: 6e 20 28 73 74 72 69 6e 67 2d 6c 65 6e 67 74 68 n (string-length
2130: 20 6d 6f 64 70 61 74 74 29 29 29 29 29 0a 09 09 modpatt)))))...
2140: 09 09 20 20 20 20 3b 3b 20 28 70 72 69 6e 74 20 .. ;; (print
2150: 22 69 6e 20 6d 61 70 2c 20 78 3d 22 20 78 20 22 "in map, x=" x "
2160: 2c 20 6e 65 77 70 61 74 74 3d 22 20 6e 65 77 70 , newpatt=" newp
2170: 61 74 74 29 0a 09 09 09 09 20 20 20 20 6e 65 77 att)..... new
2180: 70 61 74 74 29 29 0a 09 09 09 09 28 66 69 6c 74 patt)).....(filt
2190: 65 72 20 28 6c 61 6d 62 64 61 20 28 78 29 0a 09 er (lambda (x)..
21a0: 09 09 09 09 20 20 28 65 71 3f 20 28 73 75 62 73 .... (eq? (subs
21b0: 74 72 69 6e 67 2d 69 6e 64 65 78 20 28 63 6f 6e tring-index (con
21c0: 63 20 77 61 69 74 69 6e 67 2d 74 65 73 74 20 22 c waiting-test "
21d0: 2f 22 29 20 78 29 20 30 29 29 20 3b 3b 20 69 73 /") x) 0)) ;; is
21e0: 20 74 68 69 73 20 70 61 74 74 20 70 65 72 74 69 this patt perti
21f0: 6e 65 6e 74 20 74 6f 20 74 68 65 20 77 61 69 74 nent to the wait
2200: 69 6e 67 20 74 65 73 74 0a 09 09 09 09 09 70 61 ing test......pa
2210: 74 74 73 29 29 29 29 0a 20 20 20 20 28 73 74 72 tts)))). (str
2220: 69 6e 67 2d 69 6e 74 65 72 73 70 65 72 73 65 20 ing-intersperse
2230: 28 64 65 6c 65 74 65 2d 64 75 70 6c 69 63 61 74 (delete-duplicat
2240: 65 73 20 28 61 70 70 65 6e 64 20 70 61 74 74 73 es (append patts
2250: 20 28 69 66 20 28 6e 75 6c 6c 3f 20 70 61 74 74 (if (null? patt
2260: 73 2d 77 61 69 74 6f 6e 29 0a 09 09 09 09 09 09 s-waiton).......
2270: 09 20 20 20 20 20 28 6c 69 73 74 20 28 63 6f 6e . (list (con
2280: 63 20 77 61 69 74 6f 6e 2d 74 65 73 74 20 22 2f c waiton-test "/
2290: 25 22 29 29 20 3b 3b 20 72 65 61 6c 6c 79 20 73 %")) ;; really s
22a0: 68 6f 75 6c 64 6e 27 74 20 61 64 64 20 74 68 65 houldn't add the
22b0: 20 77 61 69 74 6f 6e 20 66 6f 72 63 65 66 75 6c waiton forceful
22c0: 6c 79 20 6c 69 6b 65 20 74 68 69 73 0a 09 09 09 ly like this....
22d0: 09 09 09 09 20 20 20 20 20 70 61 74 74 73 2d 77 .... patts-w
22e0: 61 69 74 6f 6e 29 29 29 0a 09 09 09 22 2c 22 29 aiton)))....",")
22f0: 29 29 0a 0a 0a 20 20 0a 3b 3b 20 74 65 73 74 73 ))... .;; tests
2300: 3a 67 6c 6f 62 2d 6c 69 6b 65 2d 6d 61 74 63 68 :glob-like-match
2310: 20 0a 28 64 65 66 69 6e 65 20 28 74 65 73 74 73 .(define (tests
2320: 3a 67 6c 6f 62 2d 6c 69 6b 65 2d 6d 61 74 63 68 :glob-like-match
2330: 20 70 61 74 74 20 73 74 72 29 20 0a 20 20 28 6c patt str) . (l
2340: 65 74 20 28 28 6c 69 6b 65 20 28 73 75 62 73 74 et ((like (subst
2350: 72 69 6e 67 2d 69 6e 64 65 78 20 22 25 22 20 70 ring-index "%" p
2360: 61 74 74 29 29 29 0a 20 20 20 20 28 6c 65 74 2a att))). (let*
2370: 20 28 28 6e 6f 74 70 61 74 74 20 20 28 65 71 75 ((notpatt (equ
2380: 61 6c 3f 20 28 73 75 62 73 74 72 69 6e 67 2d 69 al? (substring-i
2390: 6e 64 65 78 20 22 7e 22 20 70 61 74 74 29 20 30 ndex "~" patt) 0
23a0: 29 29 0a 09 20 20 20 28 6e 65 77 70 61 74 74 20 )).. (newpatt
23b0: 20 28 69 66 20 6e 6f 74 70 61 74 74 20 28 73 75 (if notpatt (su
23c0: 62 73 74 72 69 6e 67 20 70 61 74 74 20 31 29 20 bstring patt 1)
23d0: 70 61 74 74 29 29 0a 09 20 20 20 28 66 69 6e 70 patt)).. (finp
23e0: 61 74 74 20 20 28 69 66 20 6c 69 6b 65 0a 09 09 att (if like...
23f0: 09 28 73 74 72 69 6e 67 2d 73 75 62 73 74 69 74 .(string-substit
2400: 75 74 65 20 28 72 65 67 65 78 70 20 22 25 22 29 ute (regexp "%")
2410: 20 22 2e 2a 22 20 6e 65 77 70 61 74 74 20 23 66 ".*" newpatt #f
2420: 29 0a 09 09 09 28 73 74 72 69 6e 67 2d 73 75 62 )....(string-sub
2430: 73 74 69 74 75 74 65 20 28 72 65 67 65 78 70 20 stitute (regexp
2440: 22 5c 5c 2a 22 29 20 22 2e 2a 22 20 6e 65 77 70 "\\*") ".*" newp
2450: 61 74 74 20 23 66 29 29 29 0a 09 20 20 20 28 72 att #f))).. (r
2460: 65 73 20 20 20 20 20 20 23 66 29 29 0a 20 20 20 es #f)).
2470: 20 20 20 3b 3b 20 28 70 72 69 6e 74 20 22 74 65 ;; (print "te
2480: 73 74 73 3a 67 6c 6f 62 2d 6c 69 6b 65 2d 6d 61 sts:glob-like-ma
2490: 74 63 68 20 3d 3e 20 6e 6f 74 70 61 74 74 3a 20 tch => notpatt:
24a0: 22 20 6e 6f 74 70 61 74 74 20 22 2c 20 6e 65 77 " notpatt ", new
24b0: 70 61 74 74 3a 20 22 20 6e 65 77 70 61 74 74 20 patt: " newpatt
24c0: 22 2c 20 66 69 6e 70 61 74 74 3a 20 22 20 66 69 ", finpatt: " fi
24d0: 6e 70 61 74 74 29 0a 20 20 20 20 20 20 28 73 65 npatt). (se
24e0: 74 21 20 72 65 73 20 28 73 74 72 69 6e 67 2d 6d t! res (string-m
24f0: 61 74 63 68 20 28 72 65 67 65 78 70 20 66 69 6e atch (regexp fin
2500: 70 61 74 74 20 28 69 66 20 6c 69 6b 65 20 23 74 patt (if like #t
2510: 20 23 66 29 29 20 73 74 72 29 29 0a 20 20 20 20 #f)) str)).
2520: 20 20 28 69 66 20 6e 6f 74 70 61 74 74 20 28 6e (if notpatt (n
2530: 6f 74 20 72 65 73 29 20 72 65 73 29 29 29 29 0a ot res) res)))).
2540: 0a 3b 3b 20 69 66 20 69 74 65 6d 70 61 74 68 20 .;; if itempath
2550: 69 73 20 23 66 20 74 68 65 6e 20 6c 6f 6f 6b 20 is #f then look
2560: 6f 6e 6c 79 20 61 74 20 74 68 65 20 74 65 73 74 only at the test
2570: 6e 61 6d 65 20 70 61 72 74 0a 3b 3b 0a 28 64 65 name part.;;.(de
2580: 66 69 6e 65 20 28 74 65 73 74 73 3a 6d 61 74 63 fine (tests:matc
2590: 68 20 70 61 74 74 65 72 6e 73 20 74 65 73 74 6e h patterns testn
25a0: 61 6d 65 20 69 74 65 6d 70 61 74 68 20 23 21 6b ame itempath #!k
25b0: 65 79 20 28 72 65 71 75 69 72 65 64 20 27 28 29 ey (required '()
25c0: 29 29 0a 20 20 28 69 66 20 28 73 74 72 69 6e 67 )). (if (string
25d0: 3f 20 70 61 74 74 65 72 6e 73 29 0a 20 20 20 20 ? patterns).
25e0: 20 20 28 6c 65 74 20 28 28 70 61 74 74 73 20 28 (let ((patts (
25f0: 61 70 70 65 6e 64 20 28 73 74 72 69 6e 67 2d 73 append (string-s
2600: 70 6c 69 74 20 70 61 74 74 65 72 6e 73 20 22 2c plit patterns ",
2610: 22 29 20 72 65 71 75 69 72 65 64 29 29 29 0a 09 ") required)))..
2620: 28 69 66 20 28 6e 75 6c 6c 3f 20 70 61 74 74 73 (if (null? patts
2630: 29 20 3b 3b 3b 20 6e 6f 20 70 61 74 74 65 72 6e ) ;;; no pattern
2640: 28 73 29 20 6d 65 61 6e 73 20 6e 6f 20 6d 61 74 (s) means no mat
2650: 63 68 0a 09 20 20 20 20 23 66 0a 09 20 20 20 20 ch.. #f..
2660: 28 6c 65 74 20 6c 6f 6f 70 20 28 28 70 61 74 74 (let loop ((patt
2670: 20 28 63 61 72 20 70 61 74 74 73 29 29 0a 09 09 (car patts))...
2680: 20 20 20 20 20 20 20 28 74 61 6c 20 20 28 63 64 (tal (cd
2690: 72 20 70 61 74 74 73 29 29 29 0a 09 20 20 20 20 r patts)))..
26a0: 20 20 3b 3b 20 28 70 72 69 6e 74 20 22 6c 6f 6f ;; (print "loo
26b0: 70 3a 20 70 61 74 74 3a 20 22 20 70 61 74 74 20 p: patt: " patt
26c0: 22 2c 20 74 61 6c 20 22 20 74 61 6c 29 0a 09 20 ", tal " tal)..
26d0: 20 20 20 20 20 28 69 66 20 28 73 74 72 69 6e 67 (if (string
26e0: 3d 3f 20 70 61 74 74 20 22 22 29 0a 09 09 20 20 =? patt "")...
26f0: 23 66 20 3b 3b 20 6e 6f 74 68 69 6e 67 20 65 76 #f ;; nothing ev
2700: 65 72 20 6d 61 74 63 68 65 73 20 65 6d 70 74 79 er matches empty
2710: 20 73 74 72 69 6e 67 20 2d 20 70 6f 6c 69 63 79 string - policy
2720: 0a 09 09 20 20 28 6c 65 74 2a 20 28 28 70 61 74 ... (let* ((pat
2730: 74 2d 70 61 72 74 73 20 28 73 74 72 69 6e 67 2d t-parts (string-
2740: 6d 61 74 63 68 20 28 72 65 67 65 78 70 20 22 5e match (regexp "^
2750: 28 5b 5e 5c 5c 2f 5d 2a 29 28 5c 5c 2f 28 2e 2a ([^\\/]*)(\\/(.*
2760: 29 7c 29 24 22 29 20 70 61 74 74 29 29 0a 09 09 )|)$") patt))...
2770: 09 20 28 74 65 73 74 2d 70 61 74 74 20 20 28 63 . (test-patt (c
2780: 61 64 72 20 70 61 74 74 2d 70 61 72 74 73 29 29 adr patt-parts))
2790: 0a 09 09 09 20 28 69 74 65 6d 2d 70 61 74 74 20 .... (item-patt
27a0: 20 28 63 61 64 64 64 72 20 70 61 74 74 2d 70 61 (cadddr patt-pa
27b0: 72 74 73 29 29 29 0a 09 09 20 20 20 20 3b 3b 20 rts)))... ;;
27c0: 73 70 65 63 69 61 6c 20 63 61 73 65 3a 20 74 65 special case: te
27d0: 73 74 20 76 73 2e 20 74 65 73 74 2f 0a 09 09 20 st vs. test/...
27e0: 20 20 20 3b 3b 20 20 20 74 65 73 74 20 20 3d 3e ;; test =>
27f0: 20 22 74 65 73 74 22 20 22 25 22 0a 09 09 20 20 "test" "%"...
2800: 20 20 3b 3b 20 20 20 74 65 73 74 2f 20 3d 3e 20 ;; test/ =>
2810: 22 74 65 73 74 22 20 22 22 0a 09 09 20 20 20 20 "test" ""...
2820: 28 69 66 20 28 61 6e 64 20 28 6e 6f 74 20 28 73 (if (and (not (s
2830: 75 62 73 74 72 69 6e 67 2d 69 6e 64 65 78 20 22 ubstring-index "
2840: 2f 22 20 70 61 74 74 29 29 20 3b 3b 20 6e 6f 20 /" patt)) ;; no
2850: 73 6c 61 73 68 20 69 6e 20 74 68 65 20 6f 72 69 slash in the ori
2860: 67 69 6e 61 6c 0a 09 09 09 20 20 20 20 20 28 6f ginal.... (o
2870: 72 20 28 6e 6f 74 20 69 74 65 6d 2d 70 61 74 74 r (not item-patt
2880: 29 0a 09 09 09 09 20 28 65 71 75 61 6c 3f 20 69 )..... (equal? i
2890: 74 65 6d 2d 70 61 74 74 20 22 22 29 29 29 20 20 tem-patt "")))
28a0: 20 20 20 20 3b 3b 20 73 68 6f 75 6c 64 20 61 6c ;; should al
28b0: 77 61 79 73 20 62 65 20 74 72 75 65 20 74 68 61 ways be true tha
28c0: 74 20 69 74 65 6d 2d 70 61 74 74 20 69 73 20 22 t item-patt is "
28d0: 22 0a 09 09 09 28 73 65 74 21 20 69 74 65 6d 2d "....(set! item-
28e0: 70 61 74 74 20 22 25 22 29 29 0a 09 09 20 20 20 patt "%"))...
28f0: 20 3b 3b 20 28 70 72 69 6e 74 20 22 74 65 73 74 ;; (print "test
2900: 73 3a 6d 61 74 63 68 20 3d 3e 20 70 61 74 74 2d s:match => patt-
2910: 70 61 72 74 73 3a 20 22 20 70 61 74 74 2d 70 61 parts: " patt-pa
2920: 72 74 73 20 22 2c 20 74 65 73 74 2d 70 61 74 74 rts ", test-patt
2930: 3a 20 22 20 74 65 73 74 2d 70 61 74 74 20 22 2c : " test-patt ",
2940: 20 69 74 65 6d 2d 70 61 74 74 3a 20 22 20 69 74 item-patt: " it
2950: 65 6d 2d 70 61 74 74 29 0a 09 09 20 20 20 20 28 em-patt)... (
2960: 69 66 20 28 61 6e 64 20 28 74 65 73 74 73 3a 67 if (and (tests:g
2970: 6c 6f 62 2d 6c 69 6b 65 2d 6d 61 74 63 68 20 74 lob-like-match t
2980: 65 73 74 2d 70 61 74 74 20 74 65 73 74 6e 61 6d est-patt testnam
2990: 65 29 0a 09 09 09 20 20 20 20 20 28 6f 72 20 28 e).... (or (
29a0: 6e 6f 74 20 69 74 65 6d 70 61 74 68 29 0a 09 09 not itempath)...
29b0: 09 09 20 28 74 65 73 74 73 3a 67 6c 6f 62 2d 6c .. (tests:glob-l
29c0: 69 6b 65 2d 6d 61 74 63 68 20 28 69 66 20 69 74 ike-match (if it
29d0: 65 6d 2d 70 61 74 74 20 69 74 65 6d 2d 70 61 74 em-patt item-pat
29e0: 74 20 22 22 29 20 69 74 65 6d 70 61 74 68 29 29 t "") itempath))
29f0: 29 0a 09 09 09 23 74 0a 09 09 09 28 69 66 20 28 )....#t....(if (
2a00: 6e 75 6c 6c 3f 20 74 61 6c 29 0a 09 09 09 20 20 null? tal)....
2a10: 20 20 23 66 0a 09 09 09 20 20 20 20 28 6c 6f 6f #f.... (loo
2a20: 70 20 28 63 61 72 20 74 61 6c 29 28 63 64 72 20 p (car tal)(cdr
2a30: 74 61 6c 29 29 29 29 29 29 29 29 29 29 29 0a 0a tal)))))))))))..
2a40: 3b 3b 20 69 66 20 69 74 65 6d 70 61 74 68 20 69 ;; if itempath i
2a50: 73 20 23 66 20 74 68 65 6e 20 6c 6f 6f 6b 20 6f s #f then look o
2a60: 6e 6c 79 20 61 74 20 74 68 65 20 74 65 73 74 6e nly at the testn
2a70: 61 6d 65 20 70 61 72 74 0a 3b 3b 0a 28 64 65 66 ame part.;;.(def
2a80: 69 6e 65 20 28 74 65 73 74 73 3a 6d 61 74 63 68 ine (tests:match
2a90: 2d 3e 73 71 6c 71 72 79 20 70 61 74 74 65 72 6e ->sqlqry pattern
2aa0: 73 29 0a 20 20 28 69 66 20 28 73 74 72 69 6e 67 s). (if (string
2ab0: 3f 20 70 61 74 74 65 72 6e 73 29 0a 20 20 20 20 ? patterns).
2ac0: 20 20 28 6c 65 74 20 28 28 70 61 74 74 73 20 28 (let ((patts (
2ad0: 73 74 72 69 6e 67 2d 73 70 6c 69 74 20 70 61 74 string-split pat
2ae0: 74 65 72 6e 73 20 22 2c 22 29 29 29 0a 09 28 69 terns ",")))..(i
2af0: 66 20 28 6e 75 6c 6c 3f 20 70 61 74 74 73 29 20 f (null? patts)
2b00: 3b 3b 3b 20 6e 6f 20 70 61 74 74 65 72 6e 28 73 ;;; no pattern(s
2b10: 29 20 6d 65 61 6e 73 20 6e 6f 20 6d 61 74 63 68 ) means no match
2b20: 2c 20 77 65 20 77 69 6c 6c 20 64 6f 20 6e 6f 20 , we will do no
2b30: 71 75 65 72 79 0a 09 20 20 20 20 23 66 0a 09 20 query.. #f..
2b40: 20 20 20 28 6c 65 74 20 6c 6f 6f 70 20 28 28 70 (let loop ((p
2b50: 61 74 74 20 28 63 61 72 20 70 61 74 74 73 29 29 att (car patts))
2b60: 0a 09 09 20 20 20 20 20 20 20 28 74 61 6c 20 20 ... (tal
2b70: 28 63 64 72 20 70 61 74 74 73 29 29 0a 09 09 20 (cdr patts))...
2b80: 20 20 20 20 20 20 28 72 65 73 20 20 27 28 29 29 (res '())
2b90: 29 0a 09 20 20 20 20 20 20 3b 3b 20 28 70 72 69 ).. ;; (pri
2ba0: 6e 74 20 22 6c 6f 6f 70 3a 20 70 61 74 74 3a 20 nt "loop: patt:
2bb0: 22 20 70 61 74 74 20 22 2c 20 74 61 6c 20 22 20 " patt ", tal "
2bc0: 74 61 6c 29 0a 09 20 20 20 20 20 20 28 6c 65 74 tal).. (let
2bd0: 2a 20 28 28 70 61 74 74 2d 70 61 72 74 73 20 28 * ((patt-parts (
2be0: 73 74 72 69 6e 67 2d 6d 61 74 63 68 20 28 72 65 string-match (re
2bf0: 67 65 78 70 20 22 5e 28 5b 5e 5c 5c 2f 5d 2a 29 gexp "^([^\\/]*)
2c00: 28 5c 5c 2f 28 2e 2a 29 7c 29 24 22 29 20 70 61 (\\/(.*)|)$") pa
2c10: 74 74 29 29 0a 09 09 20 20 20 20 20 28 74 65 73 tt))... (tes
2c20: 74 2d 70 61 74 74 20 20 28 63 61 64 72 20 70 61 t-patt (cadr pa
2c30: 74 74 2d 70 61 72 74 73 29 29 0a 09 09 20 20 20 tt-parts))...
2c40: 20 20 28 69 74 65 6d 2d 70 61 74 74 20 20 28 63 (item-patt (c
2c50: 61 64 64 64 72 20 70 61 74 74 2d 70 61 72 74 73 adddr patt-parts
2c60: 29 29 0a 09 09 20 20 20 20 20 28 74 65 73 74 2d ))... (test-
2c70: 71 72 79 20 20 20 28 64 62 3a 70 61 74 74 2d 3e qry (db:patt->
2c80: 6c 69 6b 65 20 22 74 65 73 74 6e 61 6d 65 22 20 like "testname"
2c90: 74 65 73 74 2d 70 61 74 74 29 29 0a 09 09 20 20 test-patt))...
2ca0: 20 20 20 28 69 74 65 6d 2d 71 72 79 20 20 20 28 (item-qry (
2cb0: 64 62 3a 70 61 74 74 2d 3e 6c 69 6b 65 20 22 69 db:patt->like "i
2cc0: 74 65 6d 5f 70 61 74 68 22 20 69 74 65 6d 2d 70 tem_path" item-p
2cd0: 61 74 74 29 29 0a 09 09 20 20 20 20 20 28 71 72 att))... (qr
2ce0: 79 20 20 20 20 20 20 20 20 28 63 6f 6e 63 20 22 y (conc "
2cf0: 28 22 20 74 65 73 74 2d 71 72 79 20 22 20 41 4e (" test-qry " AN
2d00: 44 20 22 20 69 74 65 6d 2d 71 72 79 20 22 29 22 D " item-qry ")"
2d10: 29 29 29 0a 09 09 3b 3b 20 28 70 72 69 6e 74 20 )))...;; (print
2d20: 22 74 65 73 74 73 3a 6d 61 74 63 68 20 3d 3e 20 "tests:match =>
2d30: 70 61 74 74 2d 70 61 72 74 73 3a 20 22 20 70 61 patt-parts: " pa
2d40: 74 74 2d 70 61 72 74 73 20 22 2c 20 74 65 73 74 tt-parts ", test
2d50: 2d 70 61 74 74 3a 20 22 20 74 65 73 74 2d 70 61 -patt: " test-pa
2d60: 74 74 20 22 2c 20 69 74 65 6d 2d 70 61 74 74 3a tt ", item-patt:
2d70: 20 22 20 69 74 65 6d 2d 70 61 74 74 29 0a 09 09 " item-patt)...
2d80: 28 69 66 20 28 6e 75 6c 6c 3f 20 74 61 6c 29 0a (if (null? tal).
2d90: 09 09 20 20 20 20 28 73 74 72 69 6e 67 2d 69 6e .. (string-in
2da0: 74 65 72 73 70 65 72 73 65 20 28 61 70 70 65 6e tersperse (appen
2db0: 64 20 28 72 65 76 65 72 73 65 20 72 65 73 29 28 d (reverse res)(
2dc0: 6c 69 73 74 20 71 72 79 29 29 20 22 20 4f 52 20 list qry)) " OR
2dd0: 22 29 0a 09 09 20 20 20 20 28 6c 6f 6f 70 20 28 ")... (loop (
2de0: 63 61 72 20 74 61 6c 29 28 63 64 72 20 74 61 6c car tal)(cdr tal
2df0: 29 28 63 6f 6e 73 20 71 72 79 20 72 65 73 29 29 )(cons qry res))
2e00: 29 29 29 29 29 0a 20 20 20 20 20 20 23 66 29 29 ))))). #f))
2e10: 0a 0a 3b 3b 20 43 68 65 63 6b 20 66 6f 72 20 77 ..;; Check for w
2e20: 61 69 76 65 72 20 65 6c 69 67 69 62 69 6c 69 74 aiver eligibilit
2e30: 79 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 74 65 y.;;.(define (te
2e40: 73 74 73 3a 63 68 65 63 6b 2d 77 61 69 76 65 72 sts:check-waiver
2e50: 2d 65 6c 69 67 69 62 69 6c 69 74 79 20 74 65 73 -eligibility tes
2e60: 74 64 61 74 20 70 72 65 76 2d 74 65 73 74 64 61 tdat prev-testda
2e70: 74 29 0a 20 20 28 6c 65 74 2a 20 28 28 74 65 73 t). (let* ((tes
2e80: 74 2d 72 65 67 69 73 74 72 79 20 28 6d 61 6b 65 t-registry (make
2e90: 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 0a 09 20 -hash-table))..
2ea0: 28 74 65 73 74 63 6f 6e 66 69 67 20 20 28 74 65 (testconfig (te
2eb0: 73 74 73 3a 67 65 74 2d 74 65 73 74 63 6f 6e 66 sts:get-testconf
2ec0: 69 67 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d ig (db:test-get-
2ed0: 74 65 73 74 6e 61 6d 65 20 74 65 73 74 64 61 74 testname testdat
2ee0: 29 20 74 65 73 74 2d 72 65 67 69 73 74 72 79 20 ) test-registry
2ef0: 23 66 29 29 0a 09 20 28 74 65 73 74 2d 72 75 6e #f)).. (test-run
2f00: 64 69 72 20 3b 3b 20 28 73 64 62 3a 71 72 79 20 dir ;; (sdb:qry
2f10: 27 70 61 73 73 73 74 72 20 0a 09 20 20 28 64 62 'passstr .. (db
2f20: 3a 74 65 73 74 2d 67 65 74 2d 72 75 6e 64 69 72 :test-get-rundir
2f30: 20 74 65 73 74 64 61 74 29 29 20 3b 3b 20 29 0a testdat)) ;; ).
2f40: 09 20 28 70 72 65 76 2d 72 75 6e 64 69 72 20 3b . (prev-rundir ;
2f50: 3b 20 28 73 64 62 3a 71 72 79 20 27 70 61 73 73 ; (sdb:qry 'pass
2f60: 73 74 72 20 0a 09 20 20 28 64 62 3a 74 65 73 74 str .. (db:test
2f70: 2d 67 65 74 2d 72 75 6e 64 69 72 20 70 72 65 76 -get-rundir prev
2f80: 2d 74 65 73 74 64 61 74 29 29 20 3b 3b 20 29 0a -testdat)) ;; ).
2f90: 09 20 28 77 61 69 76 65 72 73 20 20 20 20 20 28 . (waivers (
2fa0: 69 66 20 74 65 73 74 63 6f 6e 66 69 67 20 28 63 if testconfig (c
2fb0: 6f 6e 66 69 67 66 3a 73 65 63 74 69 6f 6e 2d 76 onfigf:section-v
2fc0: 61 72 73 20 74 65 73 74 63 6f 6e 66 69 67 20 22 ars testconfig "
2fd0: 77 61 69 76 65 72 73 22 29 20 27 28 29 29 29 0a waivers") '())).
2fe0: 09 20 28 77 61 69 76 65 72 2d 72 78 20 20 20 28 . (waiver-rx (
2ff0: 72 65 67 65 78 70 20 22 5e 28 5c 5c 53 2b 29 5c regexp "^(\\S+)\
3000: 5c 73 2b 28 2e 2a 29 24 22 29 29 0a 09 20 28 64 \s+(.*)$")).. (d
3010: 69 66 66 2d 72 75 6c 65 20 20 20 22 64 69 66 66 iff-rule "diff
3020: 20 25 66 69 6c 65 31 25 20 25 66 69 6c 65 32 25 %file1% %file2%
3030: 22 29 0a 09 20 28 6c 6f 67 70 72 6f 2d 72 75 6c ").. (logpro-rul
3040: 65 20 22 64 69 66 66 20 25 66 69 6c 65 31 25 20 e "diff %file1%
3050: 25 66 69 6c 65 32 25 20 7c 20 6c 6f 67 70 72 6f %file2% | logpro
3060: 20 25 77 61 69 76 65 72 6e 61 6d 65 25 2e 6c 6f %waivername%.lo
3070: 67 70 72 6f 20 25 77 61 69 76 65 72 6e 61 6d 65 gpro %waivername
3080: 25 2e 68 74 6d 6c 22 29 29 0a 20 20 20 20 28 69 %.html")). (i
3090: 66 20 28 6e 6f 74 20 28 66 69 6c 65 2d 65 78 69 f (not (file-exi
30a0: 73 74 73 3f 20 74 65 73 74 2d 72 75 6e 64 69 72 sts? test-rundir
30b0: 29 29 0a 09 28 62 65 67 69 6e 0a 09 20 20 28 64 ))..(begin.. (d
30c0: 65 62 75 67 3a 70 72 69 6e 74 2d 65 72 72 6f 72 ebug:print-error
30d0: 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 0 *default-log-
30e0: 70 6f 72 74 2a 20 22 74 65 73 74 20 72 75 6e 20 port* "test run
30f0: 64 69 72 65 63 74 6f 72 79 20 69 73 20 67 6f 6e directory is gon
3100: 65 2c 20 63 61 6e 6e 6f 74 20 70 72 6f 70 61 67 e, cannot propag
3110: 61 74 65 20 77 61 69 76 65 72 22 29 0a 09 20 20 ate waiver")..
3120: 23 66 29 0a 09 28 62 65 67 69 6e 0a 09 20 20 28 #f)..(begin.. (
3130: 70 75 73 68 2d 64 69 72 65 63 74 6f 72 79 20 74 push-directory t
3140: 65 73 74 2d 72 75 6e 64 69 72 29 0a 09 20 20 28 est-rundir).. (
3150: 6c 65 74 20 28 28 72 65 73 75 6c 74 20 28 69 66 let ((result (if
3160: 20 28 6e 75 6c 6c 3f 20 77 61 69 76 65 72 73 29 (null? waivers)
3170: 0a 09 09 09 20 20 20 20 23 66 0a 09 09 09 20 20 .... #f....
3180: 20 20 28 6c 65 74 20 6c 6f 6f 70 20 28 28 68 65 (let loop ((he
3190: 64 20 28 63 61 72 20 77 61 69 76 65 72 73 29 29 d (car waivers))
31a0: 0a 09 09 09 09 20 20 20 20 20 20 20 28 74 61 6c ..... (tal
31b0: 20 28 63 64 72 20 77 61 69 76 65 72 73 29 29 29 (cdr waivers)))
31c0: 0a 09 09 09 20 20 20 20 20 20 28 64 65 62 75 67 .... (debug
31d0: 3a 70 72 69 6e 74 20 30 20 2a 64 65 66 61 75 6c :print 0 *defaul
31e0: 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 49 4e 46 t-log-port* "INF
31f0: 4f 3a 20 41 70 70 6c 79 69 6e 67 20 77 61 69 76 O: Applying waiv
3200: 65 72 20 72 75 6c 65 20 5c 22 22 20 68 65 64 20 er rule \"" hed
3210: 22 5c 22 22 29 0a 09 09 09 20 20 20 20 20 20 28 "\"").... (
3220: 6c 65 74 2a 20 28 28 77 61 69 76 65 72 20 20 20 let* ((waiver
3230: 20 20 20 28 63 6f 6e 66 69 67 66 3a 6c 6f 6f 6b (configf:look
3240: 75 70 20 74 65 73 74 63 6f 6e 66 69 67 20 22 77 up testconfig "w
3250: 61 69 76 65 72 73 22 20 68 65 64 29 29 0a 09 09 aivers" hed))...
3260: 09 09 20 20 20 20 20 28 77 70 61 72 74 73 20 20 .. (wparts
3270: 20 20 20 20 28 69 66 20 77 61 69 76 65 72 20 28 (if waiver (
3280: 73 74 72 69 6e 67 2d 6d 61 74 63 68 20 77 61 69 string-match wai
3290: 76 65 72 2d 72 78 20 77 61 69 76 65 72 29 20 23 ver-rx waiver) #
32a0: 66 29 29 0a 09 09 09 09 20 20 20 20 20 28 77 61 f))..... (wa
32b0: 69 76 65 72 2d 72 75 6c 65 20 28 69 66 20 77 70 iver-rule (if wp
32c0: 61 72 74 73 20 28 63 61 64 72 20 77 70 61 72 74 arts (cadr wpart
32d0: 73 29 20 20 23 66 29 29 0a 09 09 09 09 20 20 20 s) #f)).....
32e0: 20 20 28 77 61 69 76 65 72 2d 67 6c 6f 62 20 28 (waiver-glob (
32f0: 69 66 20 77 70 61 72 74 73 20 28 63 61 64 64 72 if wparts (caddr
3300: 20 77 70 61 72 74 73 29 20 23 66 29 29 0a 09 09 wparts) #f))...
3310: 09 09 20 20 20 20 20 28 6c 6f 67 70 72 6f 2d 66 .. (logpro-f
3320: 69 6c 65 20 28 69 66 20 77 61 69 76 65 72 0a 09 ile (if waiver..
3330: 09 09 09 09 09 20 20 20 20 20 20 28 6c 65 74 20 ..... (let
3340: 28 28 66 6e 61 6d 65 20 28 63 6f 6e 63 20 68 65 ((fname (conc he
3350: 64 20 22 2e 6c 6f 67 70 72 6f 22 29 29 29 0a 09 d ".logpro")))..
3360: 09 09 09 09 09 09 28 69 66 20 28 66 69 6c 65 2d ......(if (file-
3370: 65 78 69 73 74 73 3f 20 66 6e 61 6d 65 29 0a 09 exists? fname)..
3380: 09 09 09 09 09 09 20 20 20 20 66 6e 61 6d 65 20 ...... fname
3390: 0a 09 09 09 09 09 09 09 20 20 20 20 28 62 65 67 ........ (beg
33a0: 69 6e 0a 09 09 09 09 09 09 09 20 20 20 20 20 20 in........
33b0: 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 2a (debug:print 0 *
33c0: 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 default-log-port
33d0: 2a 20 22 49 4e 46 4f 3a 20 4e 6f 20 6c 6f 67 70 * "INFO: No logp
33e0: 72 6f 20 66 69 6c 65 20 22 20 66 6e 61 6d 65 20 ro file " fname
33f0: 22 20 66 61 6c 6c 69 6e 67 20 62 61 63 6b 20 74 " falling back t
3400: 6f 20 64 69 66 66 22 29 0a 09 09 09 09 09 09 09 o diff")........
3410: 20 20 20 20 20 20 23 66 29 29 29 0a 09 09 09 09 #f))).....
3420: 09 09 20 20 20 20 20 20 23 66 29 29 0a 09 09 09 .. #f))....
3430: 09 20 20 20 20 20 3b 3b 20 69 66 20 72 75 6c 65 . ;; if rule
3440: 20 62 79 20 6e 61 6d 65 20 6f 66 20 77 61 69 76 by name of waiv
3450: 65 72 2d 72 75 6c 65 20 69 73 20 66 6f 75 6e 64 er-rule is found
3460: 20 69 6e 20 74 65 73 74 63 6f 6e 66 69 67 20 2d in testconfig -
3470: 20 75 73 65 20 69 74 0a 09 09 09 09 20 20 20 20 use it.....
3480: 20 3b 3b 20 65 6c 73 65 20 69 66 20 77 61 69 76 ;; else if waiv
3490: 65 72 6e 61 6d 65 2e 6c 6f 67 70 72 6f 20 65 78 ername.logpro ex
34a0: 69 73 74 73 20 75 73 65 20 6c 6f 67 70 72 6f 2d ists use logpro-
34b0: 72 75 6c 65 0a 09 09 09 09 20 20 20 20 20 3b 3b rule..... ;;
34c0: 20 65 6c 73 65 20 64 65 66 61 75 6c 74 20 74 6f else default to
34d0: 20 64 69 66 66 2d 72 75 6c 65 0a 09 09 09 09 20 diff-rule.....
34e0: 20 20 20 20 28 72 75 6c 65 2d 73 74 72 69 6e 67 (rule-string
34f0: 20 28 6c 65 74 20 28 28 72 75 6c 65 20 28 63 6f (let ((rule (co
3500: 6e 66 69 67 66 3a 6c 6f 6f 6b 75 70 20 74 65 73 nfigf:lookup tes
3510: 74 63 6f 6e 66 69 67 20 22 77 61 69 76 65 72 5f tconfig "waiver_
3520: 72 75 6c 65 73 22 20 77 61 69 76 65 72 2d 72 75 rules" waiver-ru
3530: 6c 65 29 29 29 0a 09 09 09 09 09 09 20 20 20 20 le))).......
3540: 28 69 66 20 72 75 6c 65 0a 09 09 09 09 09 09 09 (if rule........
3550: 72 75 6c 65 0a 09 09 09 09 09 09 09 28 69 66 20 rule........(if
3560: 6c 6f 67 70 72 6f 2d 66 69 6c 65 0a 09 09 09 09 logpro-file.....
3570: 09 09 09 20 20 20 20 6c 6f 67 70 72 6f 2d 72 75 ... logpro-ru
3580: 6c 65 0a 09 09 09 09 09 09 09 20 20 20 20 28 62 le........ (b
3590: 65 67 69 6e 0a 09 09 09 09 09 09 09 20 20 20 20 egin........
35a0: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 (debug:print 0
35b0: 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f *default-log-po
35c0: 72 74 2a 20 22 49 4e 46 4f 3a 20 4e 6f 20 6c 6f rt* "INFO: No lo
35d0: 67 70 72 6f 20 66 69 6c 65 20 22 20 6c 6f 67 70 gpro file " logp
35e0: 72 6f 2d 66 69 6c 65 20 22 20 66 6f 75 6e 64 2c ro-file " found,
35f0: 20 75 73 69 6e 67 20 64 69 66 66 20 72 75 6c 65 using diff rule
3600: 22 29 0a 09 09 09 09 09 09 09 20 20 20 20 20 20 ")........
3610: 64 69 66 66 2d 72 75 6c 65 29 29 29 29 29 0a 09 diff-rule)))))..
3620: 09 09 09 20 20 20 20 20 3b 3b 20 28 73 74 72 69 ... ;; (stri
3630: 6e 67 2d 73 75 62 73 74 69 74 75 74 65 20 22 25 ng-substitute "%
3640: 66 69 6c 65 31 25 22 20 22 66 6f 6f 66 6f 6f 2e file1%" "foofoo.
3650: 74 78 74 22 20 22 54 68 69 73 20 69 73 20 25 66 txt" "This is %f
3660: 69 6c 65 31 25 20 61 6e 64 20 73 6f 20 69 73 20 ile1% and so is
3670: 74 68 69 73 20 25 66 69 6c 65 31 25 2e 22 20 23 this %file1%." #
3680: 74 29 0a 09 09 09 09 20 20 20 20 20 28 70 72 6f t)..... (pro
3690: 63 65 73 73 65 64 2d 63 6d 64 20 28 73 74 72 69 cessed-cmd (stri
36a0: 6e 67 2d 73 75 62 73 74 69 74 75 74 65 20 0a 09 ng-substitute ..
36b0: 09 09 09 09 09 20 20 20 20 20 22 25 66 69 6c 65 ..... "%file
36c0: 31 25 22 20 28 63 6f 6e 63 20 74 65 73 74 2d 72 1%" (conc test-r
36d0: 75 6e 64 69 72 20 22 2f 22 20 77 61 69 76 65 72 undir "/" waiver
36e0: 2d 67 6c 6f 62 29 0a 09 09 09 09 09 09 20 20 20 -glob).......
36f0: 20 20 28 73 74 72 69 6e 67 2d 73 75 62 73 74 69 (string-substi
3700: 74 75 74 65 0a 09 09 09 09 09 09 20 20 20 20 20 tute.......
3710: 20 22 25 66 69 6c 65 32 25 22 20 28 63 6f 6e 63 "%file2%" (conc
3720: 20 70 72 65 76 2d 72 75 6e 64 69 72 20 22 2f 22 prev-rundir "/"
3730: 20 77 61 69 76 65 72 2d 67 6c 6f 62 29 0a 09 09 waiver-glob)...
3740: 09 09 09 09 20 20 20 20 20 20 28 73 74 72 69 6e .... (strin
3750: 67 2d 73 75 62 73 74 69 74 75 74 65 0a 09 09 09 g-substitute....
3760: 09 09 09 20 20 20 20 20 20 20 22 25 77 61 69 76 ... "%waiv
3770: 65 72 6e 61 6d 65 25 22 20 68 65 64 20 72 75 6c ername%" hed rul
3780: 65 2d 73 74 72 69 6e 67 20 23 74 29 20 23 74 29 e-string #t) #t)
3790: 20 23 74 29 29 0a 09 09 09 09 20 20 20 20 20 28 #t))..... (
37a0: 72 65 73 20 20 20 20 20 20 20 20 20 20 20 20 23 res #
37b0: 66 29 29 0a 09 09 09 09 28 64 65 62 75 67 3a 70 f)).....(debug:p
37c0: 72 69 6e 74 20 30 20 2a 64 65 66 61 75 6c 74 2d rint 0 *default-
37d0: 6c 6f 67 2d 70 6f 72 74 2a 20 22 49 4e 46 4f 3a log-port* "INFO:
37e0: 20 77 61 69 76 65 72 20 63 6f 6d 6d 61 6e 64 20 waiver command
37f0: 69 73 20 5c 22 22 20 70 72 6f 63 65 73 73 65 64 is \"" processed
3800: 2d 63 6d 64 20 22 5c 22 22 29 0a 09 09 09 09 28 -cmd "\"").....(
3810: 69 66 20 28 65 71 3f 20 28 73 79 73 74 65 6d 20 if (eq? (system
3820: 70 72 6f 63 65 73 73 65 64 2d 63 6d 64 29 20 30 processed-cmd) 0
3830: 29 0a 09 09 09 09 20 20 20 20 28 69 66 20 28 6e )..... (if (n
3840: 75 6c 6c 3f 20 74 61 6c 29 0a 09 09 09 09 09 23 ull? tal)......#
3850: 74 0a 09 09 09 09 09 28 6c 6f 6f 70 20 28 63 61 t......(loop (ca
3860: 72 20 74 61 6c 29 28 63 64 72 20 74 61 6c 29 29 r tal)(cdr tal))
3870: 29 0a 09 09 09 09 20 20 20 20 23 66 29 29 29 29 )..... #f))))
3880: 29 29 0a 09 20 20 20 20 28 70 6f 70 2d 64 69 72 )).. (pop-dir
3890: 65 63 74 6f 72 79 29 0a 09 20 20 20 20 72 65 73 ectory).. res
38a0: 75 6c 74 29 29 29 29 29 0a 0a 28 64 65 66 69 6e ult)))))..(defin
38b0: 65 20 28 74 65 73 74 73 3a 74 65 73 74 2d 66 6f e (tests:test-fo
38c0: 72 63 65 2d 73 74 61 74 65 2d 73 74 61 74 75 73 rce-state-status
38d0: 21 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 69 64 ! run-id test-id
38e0: 20 73 74 61 74 65 20 73 74 61 74 75 73 29 0a 20 state status).
38f0: 20 28 72 6d 74 3a 74 65 73 74 2d 73 65 74 2d 73 (rmt:test-set-s
3900: 74 61 74 75 73 2d 73 74 61 74 65 20 72 75 6e 2d tatus-state run-
3910: 69 64 20 74 65 73 74 2d 69 64 20 73 74 61 74 75 id test-id statu
3920: 73 20 73 74 61 74 65 20 23 66 29 0a 20 20 3b 3b s state #f). ;;
3930: 20 28 72 6d 74 3a 72 6f 6c 6c 2d 75 70 2d 70 61 (rmt:roll-up-pa
3940: 73 73 2d 66 61 69 6c 2d 63 6f 75 6e 74 73 20 72 ss-fail-counts r
3950: 75 6e 2d 69 64 20 74 65 73 74 2d 6e 61 6d 65 20 un-id test-name
3960: 69 74 65 6d 0a 20 20 28 6d 74 3a 70 72 6f 63 65 item. (mt:proce
3970: 73 73 2d 74 72 69 67 67 65 72 73 20 72 75 6e 2d ss-triggers run-
3980: 69 64 20 74 65 73 74 2d 69 64 20 73 74 61 74 65 id test-id state
3990: 20 73 74 61 74 75 73 29 29 0a 0a 3b 3b 20 44 6f status))..;; Do
39a0: 20 6e 6f 74 20 72 70 63 20 74 68 69 73 20 6f 6e not rpc this on
39b0: 65 2c 20 64 6f 20 74 68 65 20 75 6e 64 65 72 6c e, do the underl
39c0: 79 69 6e 67 20 63 61 6c 6c 73 21 21 21 0a 28 64 ying calls!!!.(d
39d0: 65 66 69 6e 65 20 28 74 65 73 74 73 3a 74 65 73 efine (tests:tes
39e0: 74 2d 73 65 74 2d 73 74 61 74 75 73 21 20 72 75 t-set-status! ru
39f0: 6e 2d 69 64 20 74 65 73 74 2d 69 64 20 73 74 61 n-id test-id sta
3a00: 74 65 20 73 74 61 74 75 73 20 63 6f 6d 6d 65 6e te status commen
3a10: 74 20 64 61 74 20 23 21 6b 65 79 20 28 77 6f 72 t dat #!key (wor
3a20: 6b 2d 61 72 65 61 20 23 66 29 29 0a 20 20 28 6c k-area #f)). (l
3a30: 65 74 2a 20 28 28 72 65 61 6c 2d 73 74 61 74 75 et* ((real-statu
3a40: 73 20 73 74 61 74 75 73 29 0a 09 20 28 6f 74 68 s status).. (oth
3a50: 65 72 64 61 74 20 20 20 20 28 69 66 20 64 61 74 erdat (if dat
3a60: 20 64 61 74 20 28 6d 61 6b 65 2d 68 61 73 68 2d dat (make-hash-
3a70: 74 61 62 6c 65 29 29 29 0a 09 20 28 74 65 73 74 table))).. (test
3a80: 64 61 74 20 20 20 20 20 28 72 6d 74 3a 67 65 74 dat (rmt:get
3a90: 2d 74 65 73 74 2d 69 6e 66 6f 2d 62 79 2d 69 64 -test-info-by-id
3aa0: 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 69 64 29 run-id test-id)
3ab0: 29 0a 09 20 28 74 65 73 74 2d 6e 61 6d 65 20 20 ).. (test-name
3ac0: 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 74 65 (db:test-get-te
3ad0: 73 74 6e 61 6d 65 20 20 74 65 73 74 64 61 74 29 stname testdat)
3ae0: 29 0a 09 20 28 69 74 65 6d 2d 70 61 74 68 20 20 ).. (item-path
3af0: 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 69 74 (db:test-get-it
3b00: 65 6d 2d 70 61 74 68 20 74 65 73 74 64 61 74 29 em-path testdat)
3b10: 29 0a 09 20 3b 3b 20 62 65 66 6f 72 65 20 70 72 ).. ;; before pr
3b20: 6f 63 65 65 64 69 6e 67 20 77 65 20 6d 75 73 74 oceeding we must
3b30: 20 66 69 6e 64 20 6f 75 74 20 69 66 20 74 68 65 find out if the
3b40: 20 70 72 65 76 69 6f 75 73 20 74 65 73 74 20 28 previous test (
3b50: 77 68 65 72 65 20 61 6c 6c 20 6b 65 79 73 20 6d where all keys m
3b60: 61 74 63 68 65 64 20 65 78 63 65 70 74 20 72 75 atched except ru
3b70: 6e 6e 61 6d 65 29 0a 09 20 3b 3b 20 77 61 73 20 nname).. ;; was
3b80: 57 41 49 56 45 44 20 69 66 20 74 68 69 73 20 74 WAIVED if this t
3b90: 65 73 74 20 69 73 20 46 41 49 4c 0a 0a 09 20 3b est is FAIL... ;
3ba0: 3b 20 4e 4f 54 45 53 3a 0a 09 20 3b 3b 20 20 31 ; NOTES:.. ;; 1
3bb0: 2e 20 49 73 20 74 68 65 20 63 61 6c 6c 20 74 6f . Is the call to
3bc0: 20 74 65 73 74 3a 67 65 74 2d 70 72 65 76 69 6f test:get-previo
3bd0: 75 73 2d 72 75 6e 2d 72 65 63 6f 72 64 20 72 65 us-run-record re
3be0: 6d 6f 74 69 66 69 65 64 3f 0a 09 20 3b 3b 20 20 motified?.. ;;
3bf0: 32 2e 20 41 64 64 20 74 65 73 74 20 66 6f 72 20 2. Add test for
3c00: 74 65 73 74 63 6f 6e 66 69 67 20 77 61 69 76 65 testconfig waive
3c10: 72 20 70 72 6f 70 61 67 61 74 69 6f 6e 20 63 6f r propagation co
3c20: 6e 74 72 6f 6c 20 68 65 72 65 0a 09 20 3b 3b 0a ntrol here.. ;;.
3c30: 09 20 28 70 72 65 76 2d 74 65 73 74 20 20 20 28 . (prev-test (
3c40: 69 66 20 28 65 71 75 61 6c 3f 20 73 74 61 74 75 if (equal? statu
3c50: 73 20 22 46 41 49 4c 22 29 0a 09 09 09 20 20 28 s "FAIL").... (
3c60: 72 6d 74 3a 67 65 74 2d 70 72 65 76 69 6f 75 73 rmt:get-previous
3c70: 2d 74 65 73 74 2d 72 75 6e 2d 72 65 63 6f 72 64 -test-run-record
3c80: 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 6e 61 6d run-id test-nam
3c90: 65 20 69 74 65 6d 2d 70 61 74 68 29 0a 09 09 09 e item-path)....
3ca0: 20 20 23 66 29 29 0a 09 20 28 77 61 69 76 65 64 #f)).. (waived
3cb0: 20 20 20 28 69 66 20 70 72 65 76 2d 74 65 73 74 (if prev-test
3cc0: 0a 09 09 20 20 20 20 20 20 20 28 69 66 20 70 72 ... (if pr
3cd0: 65 76 2d 74 65 73 74 20 3b 3b 20 74 72 75 65 20 ev-test ;; true
3ce0: 69 66 20 77 65 20 66 6f 75 6e 64 20 61 20 70 72 if we found a pr
3cf0: 65 76 69 6f 75 73 20 74 65 73 74 20 69 6e 20 74 evious test in t
3d00: 68 69 73 20 72 75 6e 20 73 65 72 69 65 73 0a 09 his run series..
3d10: 09 09 20 20 20 28 6c 65 74 20 28 28 70 72 65 76 .. (let ((prev
3d20: 2d 73 74 61 74 75 73 20 20 28 64 62 3a 74 65 73 -status (db:tes
3d30: 74 2d 67 65 74 2d 73 74 61 74 75 73 20 20 70 72 t-get-status pr
3d40: 65 76 2d 74 65 73 74 29 29 0a 09 09 09 09 20 28 ev-test))..... (
3d50: 70 72 65 76 2d 73 74 61 74 65 20 20 20 28 64 62 prev-state (db
3d60: 3a 74 65 73 74 2d 67 65 74 2d 73 74 61 74 65 20 :test-get-state
3d70: 20 20 70 72 65 76 2d 74 65 73 74 29 29 0a 09 09 prev-test))...
3d80: 09 09 20 28 70 72 65 76 2d 63 6f 6d 6d 65 6e 74 .. (prev-comment
3d90: 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 63 6f (db:test-get-co
3da0: 6d 6d 65 6e 74 20 70 72 65 76 2d 74 65 73 74 29 mment prev-test)
3db0: 29 29 0a 09 09 09 20 20 20 20 20 28 64 65 62 75 )).... (debu
3dc0: 67 3a 70 72 69 6e 74 20 34 20 2a 64 65 66 61 75 g:print 4 *defau
3dd0: 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 70 72 lt-log-port* "pr
3de0: 65 76 2d 73 74 61 74 75 73 20 22 20 70 72 65 76 ev-status " prev
3df0: 2d 73 74 61 74 75 73 20 22 2c 20 70 72 65 76 2d -status ", prev-
3e00: 73 74 61 74 65 20 22 20 70 72 65 76 2d 73 74 61 state " prev-sta
3e10: 74 65 20 22 2c 20 70 72 65 76 2d 63 6f 6d 6d 65 te ", prev-comme
3e20: 6e 74 20 22 20 70 72 65 76 2d 63 6f 6d 6d 65 6e nt " prev-commen
3e30: 74 29 0a 09 09 09 20 20 20 20 20 28 69 66 20 28 t).... (if (
3e40: 61 6e 64 20 28 65 71 75 61 6c 3f 20 70 72 65 76 and (equal? prev
3e50: 2d 73 74 61 74 65 20 20 22 43 4f 4d 50 4c 45 54 -state "COMPLET
3e60: 45 44 22 29 0a 09 09 09 09 20 20 20 20 20 20 28 ED")..... (
3e70: 65 71 75 61 6c 3f 20 70 72 65 76 2d 73 74 61 74 equal? prev-stat
3e80: 75 73 20 22 57 41 49 56 45 44 22 29 29 0a 09 09 us "WAIVED"))...
3e90: 09 09 20 28 69 66 20 63 6f 6d 6d 65 6e 74 0a 09 .. (if comment..
3ea0: 09 09 09 20 20 20 20 20 63 6f 6d 6d 65 6e 74 0a ... comment.
3eb0: 09 09 09 09 20 20 20 20 20 70 72 65 76 2d 63 6f .... prev-co
3ec0: 6d 6d 65 6e 74 29 20 3b 3b 20 77 61 69 76 65 64 mment) ;; waived
3ed0: 20 69 73 20 65 69 74 68 65 72 20 74 68 65 20 63 is either the c
3ee0: 6f 6d 6d 65 6e 74 20 6f 72 20 23 66 0a 09 09 09 omment or #f....
3ef0: 09 20 23 66 29 29 0a 09 09 09 20 20 20 23 66 29 . #f)).... #f)
3f00: 0a 09 09 20 20 20 20 20 20 20 23 66 29 29 29 0a ... #f))).
3f10: 20 20 20 20 28 69 66 20 28 61 6e 64 20 77 61 69 (if (and wai
3f20: 76 65 64 20 0a 09 20 20 20 20 20 28 74 65 73 74 ved .. (test
3f30: 73 3a 63 68 65 63 6b 2d 77 61 69 76 65 72 2d 65 s:check-waiver-e
3f40: 6c 69 67 69 62 69 6c 69 74 79 20 74 65 73 74 64 ligibility testd
3f50: 61 74 20 70 72 65 76 2d 74 65 73 74 29 29 0a 09 at prev-test))..
3f60: 28 73 65 74 21 20 72 65 61 6c 2d 73 74 61 74 75 (set! real-statu
3f70: 73 20 22 57 41 49 56 45 44 22 29 29 0a 0a 20 20 s "WAIVED"))..
3f80: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 34 (debug:print 4
3f90: 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f *default-log-po
3fa0: 72 74 2a 20 22 72 65 61 6c 2d 73 74 61 74 75 73 rt* "real-status
3fb0: 20 22 20 72 65 61 6c 2d 73 74 61 74 75 73 20 22 " real-status "
3fc0: 2c 20 77 61 69 76 65 64 20 22 20 77 61 69 76 65 , waived " waive
3fd0: 64 20 22 2c 20 73 74 61 74 75 73 20 22 20 73 74 d ", status " st
3fe0: 61 74 75 73 29 0a 0a 20 20 20 20 3b 3b 20 75 70 atus).. ;; up
3ff0: 64 61 74 65 20 74 68 65 20 70 72 69 6d 61 72 79 date the primary
4000: 20 72 65 63 6f 72 64 20 49 46 20 73 74 61 74 65 record IF state
4010: 20 41 4e 44 20 73 74 61 74 75 73 20 61 72 65 20 AND status are
4020: 64 65 66 69 6e 65 64 0a 20 20 20 20 28 69 66 20 defined. (if
4030: 28 61 6e 64 20 73 74 61 74 65 20 73 74 61 74 75 (and state statu
4040: 73 29 0a 09 28 62 65 67 69 6e 0a 09 20 20 28 72 s)..(begin.. (r
4050: 6d 74 3a 74 65 73 74 2d 73 65 74 2d 73 74 61 74 mt:test-set-stat
4060: 75 73 2d 73 74 61 74 65 20 72 75 6e 2d 69 64 20 us-state run-id
4070: 74 65 73 74 2d 69 64 20 72 65 61 6c 2d 73 74 61 test-id real-sta
4080: 74 75 73 20 73 74 61 74 65 20 28 69 66 20 77 61 tus state (if wa
4090: 69 76 65 64 20 77 61 69 76 65 64 20 63 6f 6d 6d ived waived comm
40a0: 65 6e 74 29 29 0a 09 20 20 28 6d 74 3a 70 72 6f ent)).. (mt:pro
40b0: 63 65 73 73 2d 74 72 69 67 67 65 72 73 20 72 75 cess-triggers ru
40c0: 6e 2d 69 64 20 74 65 73 74 2d 69 64 20 73 74 61 n-id test-id sta
40d0: 74 65 20 72 65 61 6c 2d 73 74 61 74 75 73 29 0a te real-status).
40e0: 09 20 20 29 29 0a 20 20 20 20 0a 20 20 20 20 3b . )). . ;
40f0: 3b 20 69 66 20 73 74 61 74 75 73 20 69 73 20 22 ; if status is "
4100: 41 55 54 4f 22 20 74 68 65 6e 20 63 61 6c 6c 20 AUTO" then call
4110: 72 6f 6c 6c 75 70 20 28 6e 6f 74 65 2c 20 74 68 rollup (note, th
4120: 69 73 20 6f 6e 65 20 6d 6f 64 69 66 69 65 73 20 is one modifies
4130: 64 61 74 61 20 69 6e 20 74 65 73 74 0a 20 20 20 data in test.
4140: 20 3b 3b 20 72 75 6e 20 61 72 65 61 2c 20 69 74 ;; run area, it
4150: 20 64 6f 65 73 20 72 65 6d 6f 74 65 20 63 61 6c does remote cal
4160: 6c 73 20 75 6e 64 65 72 20 74 68 65 20 68 6f 6f ls under the hoo
4170: 64 2e 0a 20 20 20 20 28 69 66 20 28 61 6e 64 20 d.. (if (and
4180: 74 65 73 74 2d 69 64 20 73 74 61 74 65 20 73 74 test-id state st
4190: 61 74 75 73 20 28 65 71 75 61 6c 3f 20 73 74 61 atus (equal? sta
41a0: 74 75 73 20 22 41 55 54 4f 22 29 29 20 0a 09 28 tus "AUTO")) ..(
41b0: 72 6d 74 3a 74 65 73 74 2d 64 61 74 61 2d 72 6f rmt:test-data-ro
41c0: 6c 6c 75 70 20 72 75 6e 2d 69 64 20 74 65 73 74 llup run-id test
41d0: 2d 69 64 20 73 74 61 74 75 73 29 29 0a 0a 20 20 -id status))..
41e0: 20 20 3b 3b 20 61 64 64 20 6d 65 74 61 64 61 74 ;; add metadat
41f0: 61 20 28 6e 65 65 64 20 74 6f 20 64 6f 20 74 68 a (need to do th
4200: 69 73 20 77 61 79 20 74 6f 20 61 76 6f 69 64 20 is way to avoid
4210: 53 51 4c 20 69 6e 6a 65 63 74 69 6f 6e 20 69 73 SQL injection is
4220: 73 75 65 73 29 0a 0a 20 20 20 20 3b 3b 20 3a 66 sues).. ;; :f
4230: 69 72 73 74 5f 65 72 72 0a 20 20 20 20 3b 3b 20 irst_err. ;;
4240: 28 6c 65 74 20 28 28 76 61 6c 20 28 68 61 73 68 (let ((val (hash
4250: 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 -table-ref/defau
4260: 6c 74 20 6f 74 68 65 72 64 61 74 20 22 3a 66 69 lt otherdat ":fi
4270: 72 73 74 5f 65 72 72 22 20 23 66 29 29 29 0a 20 rst_err" #f))).
4280: 20 20 20 3b 3b 20 20 20 28 69 66 20 76 61 6c 0a ;; (if val.
4290: 20 20 20 20 3b 3b 20 20 20 20 20 20 20 28 73 71 ;; (sq
42a0: 6c 69 74 65 33 3a 65 78 65 63 75 74 65 20 64 62 lite3:execute db
42b0: 20 22 55 50 44 41 54 45 20 74 65 73 74 73 20 53 "UPDATE tests S
42c0: 45 54 20 66 69 72 73 74 5f 65 72 72 3d 3f 20 57 ET first_err=? W
42d0: 48 45 52 45 20 72 75 6e 5f 69 64 3d 3f 20 41 4e HERE run_id=? AN
42e0: 44 20 74 65 73 74 6e 61 6d 65 3d 3f 20 41 4e 44 D testname=? AND
42f0: 20 69 74 65 6d 5f 70 61 74 68 3d 3f 3b 22 20 76 item_path=?;" v
4300: 61 6c 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 6e al run-id test-n
4310: 61 6d 65 20 69 74 65 6d 2d 70 61 74 68 29 29 29 ame item-path)))
4320: 0a 20 20 20 20 3b 3b 20 0a 20 20 20 20 3b 3b 20 . ;; . ;;
4330: 3b 3b 20 3a 66 69 72 73 74 5f 77 61 72 6e 0a 20 ;; :first_warn.
4340: 20 20 20 3b 3b 20 28 6c 65 74 20 28 28 76 61 6c ;; (let ((val
4350: 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 (hash-table-ref
4360: 2f 64 65 66 61 75 6c 74 20 6f 74 68 65 72 64 61 /default otherda
4370: 74 20 22 3a 66 69 72 73 74 5f 77 61 72 6e 22 20 t ":first_warn"
4380: 23 66 29 29 29 0a 20 20 20 20 3b 3b 20 20 20 28 #f))). ;; (
4390: 69 66 20 76 61 6c 0a 20 20 20 20 3b 3b 20 20 20 if val. ;;
43a0: 20 20 20 20 28 73 71 6c 69 74 65 33 3a 65 78 65 (sqlite3:exe
43b0: 63 75 74 65 20 64 62 20 22 55 50 44 41 54 45 20 cute db "UPDATE
43c0: 74 65 73 74 73 20 53 45 54 20 66 69 72 73 74 5f tests SET first_
43d0: 77 61 72 6e 3d 3f 20 57 48 45 52 45 20 72 75 6e warn=? WHERE run
43e0: 5f 69 64 3d 3f 20 41 4e 44 20 74 65 73 74 6e 61 _id=? AND testna
43f0: 6d 65 3d 3f 20 41 4e 44 20 69 74 65 6d 5f 70 61 me=? AND item_pa
4400: 74 68 3d 3f 3b 22 20 76 61 6c 20 72 75 6e 2d 69 th=?;" val run-i
4410: 64 20 74 65 73 74 2d 6e 61 6d 65 20 69 74 65 6d d test-name item
4420: 2d 70 61 74 68 29 29 29 0a 0a 20 20 20 20 28 6c -path))).. (l
4430: 65 74 20 28 28 63 61 74 65 67 6f 72 79 20 28 68 et ((category (h
4440: 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 ash-table-ref/de
4450: 66 61 75 6c 74 20 6f 74 68 65 72 64 61 74 20 22 fault otherdat "
4460: 3a 63 61 74 65 67 6f 72 79 22 20 22 22 29 29 0a :category" "")).
4470: 09 20 20 28 76 61 72 69 61 62 6c 65 20 28 68 61 . (variable (ha
4480: 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 sh-table-ref/def
4490: 61 75 6c 74 20 6f 74 68 65 72 64 61 74 20 22 3a ault otherdat ":
44a0: 76 61 72 69 61 62 6c 65 22 20 22 22 29 29 0a 09 variable" ""))..
44b0: 20 20 28 76 61 6c 75 65 20 20 20 20 28 68 61 73 (value (has
44c0: 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 h-table-ref/defa
44d0: 75 6c 74 20 6f 74 68 65 72 64 61 74 20 22 3a 76 ult otherdat ":v
44e0: 61 6c 75 65 22 20 20 20 20 23 66 29 29 0a 09 20 alue" #f))..
44f0: 20 28 65 78 70 65 63 74 65 64 20 28 68 61 73 68 (expected (hash
4500: 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 -table-ref/defau
4510: 6c 74 20 6f 74 68 65 72 64 61 74 20 22 3a 65 78 lt otherdat ":ex
4520: 70 65 63 74 65 64 22 20 23 66 29 29 0a 09 20 20 pected" #f))..
4530: 28 74 6f 6c 20 20 20 20 20 20 28 68 61 73 68 2d (tol (hash-
4540: 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c table-ref/defaul
4550: 74 20 6f 74 68 65 72 64 61 74 20 22 3a 74 6f 6c t otherdat ":tol
4560: 22 20 20 20 20 20 20 23 66 29 29 0a 09 20 20 28 " #f)).. (
4570: 75 6e 69 74 73 20 20 20 20 28 68 61 73 68 2d 74 units (hash-t
4580: 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 able-ref/default
4590: 20 6f 74 68 65 72 64 61 74 20 22 3a 75 6e 69 74 otherdat ":unit
45a0: 73 22 20 20 20 20 22 22 29 29 0a 09 20 20 28 74 s" "")).. (t
45b0: 79 70 65 20 20 20 20 20 28 68 61 73 68 2d 74 61 ype (hash-ta
45c0: 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 ble-ref/default
45d0: 6f 74 68 65 72 64 61 74 20 22 3a 74 79 70 65 22 otherdat ":type"
45e0: 20 20 20 20 20 22 22 29 29 0a 09 20 20 28 64 63 "")).. (dc
45f0: 6f 6d 6d 65 6e 74 20 28 68 61 73 68 2d 74 61 62 omment (hash-tab
4600: 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 6f le-ref/default o
4610: 74 68 65 72 64 61 74 20 22 3a 63 6f 6d 6d 65 6e therdat ":commen
4620: 74 22 20 20 22 22 29 29 29 0a 20 20 20 20 20 20 t" ""))).
4630: 28 64 65 62 75 67 3a 70 72 69 6e 74 20 34 20 2a (debug:print 4 *
4640: 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 default-log-port
4650: 2a 20 0a 09 09 20 20 20 22 63 61 74 65 67 6f 72 * ... "categor
4660: 79 3a 20 22 20 63 61 74 65 67 6f 72 79 20 22 2c y: " category ",
4670: 20 76 61 72 69 61 62 6c 65 3a 20 22 20 76 61 72 variable: " var
4680: 69 61 62 6c 65 20 22 2c 20 76 61 6c 75 65 3a 20 iable ", value:
4690: 22 20 76 61 6c 75 65 0a 09 09 20 20 20 22 2c 20 " value... ",
46a0: 65 78 70 65 63 74 65 64 3a 20 22 20 65 78 70 65 expected: " expe
46b0: 63 74 65 64 20 22 2c 20 74 6f 6c 3a 20 22 20 74 cted ", tol: " t
46c0: 6f 6c 20 22 2c 20 75 6e 69 74 73 3a 20 22 20 75 ol ", units: " u
46d0: 6e 69 74 73 29 0a 20 20 20 20 20 20 28 69 66 20 nits). (if
46e0: 28 61 6e 64 20 76 61 6c 75 65 20 65 78 70 65 63 (and value expec
46f0: 74 65 64 20 74 6f 6c 29 20 3b 3b 20 61 6c 6c 20 ted tol) ;; all
4700: 74 68 72 65 65 20 72 65 71 75 69 72 65 64 0a 09 three required..
4710: 20 20 28 6c 65 74 20 28 28 64 61 74 20 28 63 6f (let ((dat (co
4720: 6e 63 20 63 61 74 65 67 6f 72 79 20 22 2c 22 0a nc category ",".
4730: 09 09 09 20 20 20 76 61 72 69 61 62 6c 65 20 22 ... variable "
4740: 2c 22 0a 09 09 09 20 20 20 76 61 6c 75 65 20 20 ,".... value
4750: 20 20 22 2c 22 0a 09 09 09 20 20 20 65 78 70 65 ",".... expe
4760: 63 74 65 64 20 22 2c 22 0a 09 09 09 20 20 20 74 cted ",".... t
4770: 6f 6c 20 20 20 20 20 20 22 2c 22 0a 09 09 09 20 ol ","....
4780: 20 20 75 6e 69 74 73 20 20 20 20 22 2c 22 0a 09 units ","..
4790: 09 09 20 20 20 64 63 6f 6d 6d 65 6e 74 20 22 2c .. dcomment ",
47a0: 2c 22 20 3b 3b 20 65 78 74 72 61 20 63 6f 6d 6d ," ;; extra comm
47b0: 61 20 66 6f 72 20 73 74 61 74 75 73 0a 09 09 09 a for status....
47c0: 20 20 20 74 79 70 65 20 20 20 20 20 29 29 29 0a type ))).
47d0: 09 20 20 20 20 3b 3b 20 54 68 69 73 20 77 61 73 . ;; This was
47e0: 20 72 75 6e 20 72 65 6d 6f 74 65 2c 20 64 6f 6e run remote, don
47f0: 27 74 20 74 68 69 6e 6b 20 74 68 61 74 20 6d 61 't think that ma
4800: 6b 65 73 20 73 65 6e 73 65 2e 20 50 65 72 68 61 kes sense. Perha
4810: 70 73 20 6e 6f 74 2c 20 62 75 74 20 74 68 61 74 ps not, but that
4820: 20 69 73 20 74 68 65 20 65 61 73 69 65 73 74 20 is the easiest
4830: 70 61 74 68 20 66 6f 72 20 74 68 65 20 6d 6f 6d path for the mom
4840: 65 6e 74 2e 0a 09 20 20 20 20 28 72 6d 74 3a 63 ent... (rmt:c
4850: 73 76 2d 3e 74 65 73 74 2d 64 61 74 61 20 72 75 sv->test-data ru
4860: 6e 2d 69 64 20 74 65 73 74 2d 69 64 0a 09 09 09 n-id test-id....
4870: 09 64 61 74 29 29 29 29 0a 20 20 20 20 20 20 0a .dat)))). .
4880: 20 20 20 20 3b 3b 20 6e 65 65 64 20 74 6f 20 75 ;; need to u
4890: 70 64 61 74 65 20 74 68 65 20 74 6f 70 20 74 65 pdate the top te
48a0: 73 74 20 72 65 63 6f 72 64 20 69 66 20 50 41 53 st record if PAS
48b0: 53 20 6f 72 20 46 41 49 4c 20 61 6e 64 20 74 68 S or FAIL and th
48c0: 69 73 20 69 73 20 61 20 73 75 62 74 65 73 74 0a is is a subtest.
48d0: 20 20 20 20 28 69 66 20 28 6e 6f 74 20 28 65 71 (if (not (eq
48e0: 75 61 6c 3f 20 69 74 65 6d 2d 70 61 74 68 20 22 ual? item-path "
48f0: 22 29 29 0a 09 28 72 6d 74 3a 72 6f 6c 6c 2d 75 "))..(rmt:roll-u
4900: 70 2d 70 61 73 73 2d 66 61 69 6c 2d 63 6f 75 6e p-pass-fail-coun
4910: 74 73 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 6e ts run-id test-n
4920: 61 6d 65 20 69 74 65 6d 2d 70 61 74 68 20 73 74 ame item-path st
4930: 61 74 65 20 73 74 61 74 75 73 20 23 66 29 29 0a ate status #f)).
4940: 0a 20 20 20 20 28 69 66 20 28 6f 72 20 28 61 6e . (if (or (an
4950: 64 20 28 73 74 72 69 6e 67 3f 20 63 6f 6d 6d 65 d (string? comme
4960: 6e 74 29 0a 09 09 20 28 73 74 72 69 6e 67 2d 6d nt)... (string-m
4970: 61 74 63 68 20 28 72 65 67 65 78 70 20 22 5c 5c atch (regexp "\\
4980: 53 2b 22 29 20 63 6f 6d 6d 65 6e 74 29 29 0a 09 S+") comment))..
4990: 20 20 20 20 77 61 69 76 65 64 29 0a 09 28 6c 65 waived)..(le
49a0: 74 20 28 28 63 6d 74 20 20 28 69 66 20 77 61 69 t ((cmt (if wai
49b0: 76 65 64 20 77 61 69 76 65 64 20 63 6f 6d 6d 65 ved waived comme
49c0: 6e 74 29 29 29 0a 09 20 20 28 72 6d 74 3a 67 65 nt))).. (rmt:ge
49d0: 6e 65 72 61 6c 2d 63 61 6c 6c 20 27 73 65 74 2d neral-call 'set-
49e0: 74 65 73 74 2d 63 6f 6d 6d 65 6e 74 20 72 75 6e test-comment run
49f0: 2d 69 64 20 63 6d 74 20 74 65 73 74 2d 69 64 29 -id cmt test-id)
4a00: 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 74 ))))..(define (t
4a10: 65 73 74 73 3a 74 65 73 74 2d 73 65 74 2d 74 6f ests:test-set-to
4a20: 70 6c 6f 67 21 20 72 75 6e 2d 69 64 20 74 65 73 plog! run-id tes
4a30: 74 2d 6e 61 6d 65 20 6c 6f 67 66 29 20 0a 20 20 t-name logf) .
4a40: 28 72 6d 74 3a 67 65 6e 65 72 61 6c 2d 63 61 6c (rmt:general-cal
4a50: 6c 20 27 74 65 73 74 73 3a 74 65 73 74 2d 73 65 l 'tests:test-se
4a60: 74 2d 74 6f 70 6c 6f 67 20 72 75 6e 2d 69 64 20 t-toplog run-id
4a70: 6c 6f 67 66 20 72 75 6e 2d 69 64 20 74 65 73 74 logf run-id test
4a80: 2d 6e 61 6d 65 29 29 0a 0a 28 64 65 66 69 6e 65 -name))..(define
4a90: 20 28 74 65 73 74 73 3a 73 75 6d 6d 61 72 69 7a (tests:summariz
4aa0: 65 2d 69 74 65 6d 73 20 72 75 6e 2d 69 64 20 74 e-items run-id t
4ab0: 65 73 74 2d 69 64 20 74 65 73 74 2d 6e 61 6d 65 est-id test-name
4ac0: 20 66 6f 72 63 65 29 0a 20 20 3b 3b 20 69 66 20 force). ;; if
4ad0: 6e 6f 74 20 66 6f 72 63 65 20 74 68 65 6e 20 6f not force then o
4ae0: 6e 6c 79 20 75 70 64 61 74 65 20 74 68 65 20 72 nly update the r
4af0: 65 63 6f 72 64 20 69 66 20 6f 6e 65 20 6f 66 20 ecord if one of
4b00: 74 68 65 73 65 20 69 73 20 74 72 75 65 3a 0a 20 these is true:.
4b10: 20 3b 3b 20 20 20 31 2e 20 6c 6f 67 66 20 69 73 ;; 1. logf is
4b20: 20 22 6c 6f 67 2f 66 69 6e 61 6c 2e 6c 6f 67 0a "log/final.log.
4b30: 20 20 3b 3b 20 20 20 32 2e 20 6c 6f 67 66 20 69 ;; 2. logf i
4b40: 73 20 73 61 6d 65 20 61 73 20 6f 75 74 70 75 74 s same as output
4b50: 66 69 6c 65 6e 61 6d 65 0a 20 20 28 6c 65 74 2a filename. (let*
4b60: 20 28 28 6f 75 74 70 75 74 66 69 6c 65 6e 61 6d ((outputfilenam
4b70: 65 20 28 63 6f 6e 63 20 22 6d 65 67 61 74 65 73 e (conc "megates
4b80: 74 2d 72 6f 6c 6c 75 70 2d 22 20 74 65 73 74 2d t-rollup-" test-
4b90: 6e 61 6d 65 20 22 2e 68 74 6d 6c 22 29 29 0a 09 name ".html"))..
4ba0: 20 28 6f 72 69 67 2d 64 69 72 20 20 20 20 20 20 (orig-dir
4bb0: 20 28 63 75 72 72 65 6e 74 2d 64 69 72 65 63 74 (current-direct
4bc0: 6f 72 79 29 29 0a 09 20 28 6c 6f 67 66 2d 69 6e ory)).. (logf-in
4bd0: 66 6f 20 20 20 20 20 20 28 72 6d 74 3a 74 65 73 fo (rmt:tes
4be0: 74 2d 67 65 74 2d 6c 6f 67 66 69 6c 65 2d 69 6e t-get-logfile-in
4bf0: 66 6f 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 6e fo run-id test-n
4c00: 61 6d 65 29 29 0a 09 20 28 6c 6f 67 66 20 20 20 ame)).. (logf
4c10: 20 20 20 20 20 20 20 20 28 69 66 20 6c 6f 67 66 (if logf
4c20: 2d 69 6e 66 6f 20 28 63 61 64 72 20 6c 6f 67 66 -info (cadr logf
4c30: 2d 69 6e 66 6f 29 20 23 66 29 29 0a 09 20 28 70 -info) #f)).. (p
4c40: 61 74 68 20 20 20 20 20 20 20 20 20 20 20 28 69 ath (i
4c50: 66 20 6c 6f 67 66 2d 69 6e 66 6f 20 28 63 61 72 f logf-info (car
4c60: 20 20 6c 6f 67 66 2d 69 6e 66 6f 29 20 23 66 29 logf-info) #f)
4c70: 29 29 0a 20 20 20 20 3b 3b 20 54 68 69 73 20 71 )). ;; This q
4c80: 75 65 72 79 20 66 69 6e 64 73 20 74 68 65 20 70 uery finds the p
4c90: 61 74 68 20 61 6e 64 20 63 68 61 6e 67 65 73 20 ath and changes
4ca0: 74 68 65 20 64 69 72 65 63 74 6f 72 79 20 74 6f the directory to
4cb0: 20 69 74 20 66 6f 72 20 74 68 65 20 74 65 73 74 it for the test
4cc0: 0a 20 20 20 20 28 69 66 20 28 61 6e 64 20 28 73 . (if (and (s
4cd0: 74 72 69 6e 67 3f 20 70 61 74 68 29 0a 09 20 20 tring? path)..
4ce0: 20 20 20 28 64 69 72 65 63 74 6f 72 79 3f 20 70 (directory? p
4cf0: 61 74 68 29 29 20 3b 3b 20 63 61 6e 20 67 65 74 ath)) ;; can get
4d00: 20 23 66 20 68 65 72 65 20 75 6e 64 65 72 20 73 #f here under s
4d10: 6f 6d 65 20 77 69 65 72 64 20 63 6f 6e 64 69 74 ome wierd condit
4d20: 69 6f 6e 73 2e 20 77 68 79 2c 20 75 6e 6b 6e 6f ions. why, unkno
4d30: 77 6e 20 2e 2e 2e 0a 09 28 62 65 67 69 6e 0a 09 wn .....(begin..
4d40: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 34 (debug:print 4
4d50: 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f *default-log-po
4d60: 72 74 2a 20 22 46 6f 75 6e 64 20 70 61 74 68 3a rt* "Found path:
4d70: 20 22 20 70 61 74 68 29 0a 09 20 20 28 63 68 61 " path).. (cha
4d80: 6e 67 65 2d 64 69 72 65 63 74 6f 72 79 20 70 61 nge-directory pa
4d90: 74 68 29 29 0a 09 3b 3b 20 28 73 65 74 21 20 6f th))..;; (set! o
4da0: 75 74 70 75 74 66 69 6c 65 6e 61 6d 65 20 28 63 utputfilename (c
4db0: 6f 6e 63 20 70 61 74 68 20 22 2f 22 20 6f 75 74 onc path "/" out
4dc0: 70 75 74 66 69 6c 65 6e 61 6d 65 29 29 29 0a 09 putfilename)))..
4dd0: 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 65 72 72 (debug:print-err
4de0: 6f 72 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f or 0 *default-lo
4df0: 67 2d 70 6f 72 74 2a 20 22 73 75 6d 6d 61 72 69 g-port* "summari
4e00: 7a 65 2d 69 74 65 6d 73 20 66 6f 72 20 72 75 6e ze-items for run
4e10: 2d 69 64 3d 22 20 72 75 6e 2d 69 64 20 22 2c 20 -id=" run-id ",
4e20: 74 65 73 74 2d 6e 61 6d 65 3d 22 20 74 65 73 74 test-name=" test
4e30: 2d 6e 61 6d 65 20 22 2c 20 6e 6f 20 73 75 63 68 -name ", no such
4e40: 20 70 61 74 68 3a 20 22 20 70 61 74 68 29 29 0a path: " path)).
4e50: 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 (debug:print
4e60: 20 34 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 4 *default-log-
4e70: 70 6f 72 74 2a 20 22 73 75 6d 6d 61 72 69 7a 65 port* "summarize
4e80: 2d 69 74 65 6d 73 20 77 69 74 68 20 6c 6f 67 66 -items with logf
4e90: 20 22 20 6c 6f 67 66 20 22 2c 20 6f 75 74 70 75 " logf ", outpu
4ea0: 74 66 69 6c 65 6e 61 6d 65 20 22 20 6f 75 74 70 tfilename " outp
4eb0: 75 74 66 69 6c 65 6e 61 6d 65 20 22 20 61 6e 64 utfilename " and
4ec0: 20 66 6f 72 63 65 20 22 20 66 6f 72 63 65 29 0a force " force).
4ed0: 20 20 20 20 28 69 66 20 28 6f 72 20 28 65 71 75 (if (or (equ
4ee0: 61 6c 3f 20 6c 6f 67 66 20 22 6c 6f 67 73 2f 66 al? logf "logs/f
4ef0: 69 6e 61 6c 2e 6c 6f 67 22 29 0a 09 20 20 20 20 inal.log")..
4f00: 28 65 71 75 61 6c 3f 20 6c 6f 67 66 20 6f 75 74 (equal? logf out
4f10: 70 75 74 66 69 6c 65 6e 61 6d 65 29 0a 09 20 20 putfilename)..
4f20: 20 20 66 6f 72 63 65 29 0a 09 28 6c 65 74 20 28 force)..(let (
4f30: 28 6d 79 2d 73 74 61 72 74 2d 74 69 6d 65 20 28 (my-start-time (
4f40: 63 75 72 72 65 6e 74 2d 73 65 63 6f 6e 64 73 29 current-seconds)
4f50: 29 0a 09 20 20 20 20 20 20 28 6c 6f 63 6b 66 20 ).. (lockf
4f60: 20 20 20 20 20 20 20 20 28 63 6f 6e 63 20 6f 75 (conc ou
4f70: 74 70 75 74 66 69 6c 65 6e 61 6d 65 20 22 2e 6c tputfilename ".l
4f80: 6f 63 6b 22 29 29 29 0a 09 20 20 28 6c 65 74 20 ock"))).. (let
4f90: 6c 6f 6f 70 20 28 28 68 61 76 65 2d 6c 6f 63 6b loop ((have-lock
4fa0: 20 20 28 63 6f 6d 6d 6f 6e 3a 73 69 6d 70 6c 65 (common:simple
4fb0: 2d 66 69 6c 65 2d 6c 6f 63 6b 20 6c 6f 63 6b 66 -file-lock lockf
4fc0: 29 29 29 0a 09 20 20 20 20 28 69 66 20 68 61 76 ))).. (if hav
4fd0: 65 2d 6c 6f 63 6b 0a 09 09 28 6c 65 74 20 28 28 e-lock...(let ((
4fe0: 73 63 72 69 70 74 20 28 63 6f 6e 66 69 67 66 3a script (configf:
4ff0: 6c 6f 6f 6b 75 70 20 2a 63 6f 6e 66 69 67 64 61 lookup *configda
5000: 74 2a 20 22 74 65 73 74 72 6f 6c 6c 75 70 22 20 t* "testrollup"
5010: 74 65 73 74 2d 6e 61 6d 65 29 29 29 0a 09 09 20 test-name)))...
5020: 20 28 70 72 69 6e 74 20 22 4f 62 74 61 69 6e 65 (print "Obtaine
5030: 64 20 6c 6f 63 6b 20 66 6f 72 20 22 20 6f 75 74 d lock for " out
5040: 70 75 74 66 69 6c 65 6e 61 6d 65 29 0a 09 09 20 putfilename)...
5050: 20 3b 3b 20 28 72 6d 74 3a 74 6f 70 2d 74 65 73 ;; (rmt:top-tes
5060: 74 2d 73 65 74 2d 70 65 72 2d 70 66 2d 63 6f 75 t-set-per-pf-cou
5070: 6e 74 73 20 72 75 6e 2d 69 64 20 74 65 73 74 2d nts run-id test-
5080: 6e 61 6d 65 29 0a 09 09 20 20 28 72 6d 74 3a 72 name)... (rmt:r
5090: 6f 6c 6c 2d 75 70 2d 70 61 73 73 2d 66 61 69 6c oll-up-pass-fail
50a0: 2d 63 6f 75 6e 74 73 20 72 75 6e 2d 69 64 20 74 -counts run-id t
50b0: 65 73 74 2d 6e 61 6d 65 20 22 22 20 23 66 20 23 est-name "" #f #
50c0: 66 20 23 66 29 0a 09 09 20 20 28 72 6d 74 3a 74 f #f)... (rmt:t
50d0: 6f 70 2d 74 65 73 74 2d 73 65 74 2d 70 65 72 2d op-test-set-per-
50e0: 70 66 2d 63 6f 75 6e 74 73 20 72 75 6e 2d 69 64 pf-counts run-id
50f0: 20 74 65 73 74 2d 6e 61 6d 65 29 0a 09 09 20 20 test-name)...
5100: 28 69 66 20 73 63 72 69 70 74 0a 09 09 20 20 20 (if script...
5110: 20 20 20 28 73 79 73 74 65 6d 20 28 63 6f 6e 63 (system (conc
5120: 20 73 63 72 69 70 74 20 22 20 3e 20 22 20 6f 75 script " > " ou
5130: 74 70 75 74 66 69 6c 65 6e 61 6d 65 20 22 20 26 tputfilename " &
5140: 20 22 29 29 0a 09 09 20 20 20 20 20 20 28 74 65 "))... (te
5150: 73 74 73 3a 67 65 6e 65 72 61 74 65 2d 68 74 6d sts:generate-htm
5160: 6c 2d 73 75 6d 6d 61 72 79 2d 66 6f 72 2d 69 74 l-summary-for-it
5170: 65 72 61 74 65 64 2d 74 65 73 74 20 72 75 6e 2d erated-test run-
5180: 69 64 20 74 65 73 74 2d 69 64 20 74 65 73 74 2d id test-id test-
5190: 6e 61 6d 65 20 6f 75 74 70 75 74 66 69 6c 65 6e name outputfilen
51a0: 61 6d 65 29 29 0a 09 09 20 20 28 63 6f 6d 6d 6f ame))... (commo
51b0: 6e 3a 73 69 6d 70 6c 65 2d 66 69 6c 65 2d 72 65 n:simple-file-re
51c0: 6c 65 61 73 65 2d 6c 6f 63 6b 20 6c 6f 63 6b 66 lease-lock lockf
51d0: 29 0a 09 09 20 20 28 63 68 61 6e 67 65 2d 64 69 )... (change-di
51e0: 72 65 63 74 6f 72 79 20 6f 72 69 67 2d 64 69 72 rectory orig-dir
51f0: 29 0a 09 09 20 20 3b 3b 20 4e 42 2f 2f 20 74 65 )... ;; NB// te
5200: 73 74 73 3a 74 65 73 74 2d 73 65 74 2d 74 6f 70 sts:test-set-top
5210: 6c 6f 67 21 20 69 73 20 72 65 6d 6f 74 65 20 69 log! is remote i
5220: 6e 74 65 72 6e 61 6c 2e 2e 2e 0a 09 09 20 20 28 nternal...... (
5230: 74 65 73 74 73 3a 74 65 73 74 2d 73 65 74 2d 74 tests:test-set-t
5240: 6f 70 6c 6f 67 21 20 72 75 6e 2d 69 64 20 74 65 oplog! run-id te
5250: 73 74 2d 6e 61 6d 65 20 6f 75 74 70 75 74 66 69 st-name outputfi
5260: 6c 65 6e 61 6d 65 29 29 0a 09 09 3b 3b 20 64 69 lename))...;; di
5270: 64 6e 27 74 20 67 65 74 20 74 68 65 20 6c 6f 63 dn't get the loc
5280: 6b 2c 20 63 68 65 63 6b 20 74 6f 20 73 65 65 20 k, check to see
5290: 69 66 20 63 75 72 72 65 6e 74 20 75 70 64 61 74 if current updat
52a0: 65 20 73 74 61 72 74 65 64 20 6c 61 74 65 72 20 e started later
52b0: 74 68 61 6e 20 74 68 69 73 20 0a 09 09 3b 3b 20 than this ...;;
52c0: 75 70 64 61 74 65 2c 20 69 66 20 73 6f 20 77 65 update, if so we
52d0: 20 63 61 6e 20 65 78 69 74 20 77 69 74 68 6f 75 can exit withou
52e0: 74 20 64 6f 69 6e 67 20 61 6e 79 20 77 6f 72 6b t doing any work
52f0: 0a 09 09 28 69 66 20 28 3e 20 6d 79 2d 73 74 61 ...(if (> my-sta
5300: 72 74 2d 74 69 6d 65 20 28 66 69 6c 65 2d 6d 6f rt-time (file-mo
5310: 64 69 66 69 63 61 74 69 6f 6e 2d 74 69 6d 65 20 dification-time
5320: 6c 6f 63 6b 66 29 29 0a 09 09 20 20 20 20 3b 3b lockf))... ;;
5330: 20 77 65 20 73 74 61 72 74 65 64 20 73 69 6e 63 we started sinc
5340: 65 20 63 75 72 72 65 6e 74 20 72 65 2d 67 65 6e e current re-gen
5350: 20 69 6e 20 66 6c 69 67 68 74 2c 20 64 65 6c 61 in flight, dela
5360: 79 20 61 20 6c 69 74 74 6c 65 20 61 6e 64 20 74 y a little and t
5370: 72 79 20 61 67 61 69 6e 0a 09 09 20 20 20 20 28 ry again... (
5380: 62 65 67 69 6e 0a 09 09 20 20 20 20 20 20 28 64 begin... (d
5390: 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 ebug:print-info
53a0: 31 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 1 *default-log-p
53b0: 6f 72 74 2a 20 22 57 61 69 74 69 6e 67 20 74 6f ort* "Waiting to
53c0: 20 75 70 64 61 74 65 20 22 20 6f 75 74 70 75 74 update " output
53d0: 66 69 6c 65 6e 61 6d 65 20 22 2c 20 61 6e 6f 74 filename ", anot
53e0: 68 65 72 20 74 65 73 74 20 63 75 72 72 65 6e 74 her test current
53f0: 6c 79 20 75 70 64 61 74 69 6e 67 20 69 74 22 29 ly updating it")
5400: 0a 09 09 20 20 20 20 20 20 28 74 68 72 65 61 64 ... (thread
5410: 2d 73 6c 65 65 70 21 20 28 2b 20 35 20 28 72 61 -sleep! (+ 5 (ra
5420: 6e 64 6f 6d 20 35 29 29 29 20 3b 3b 20 64 65 6c ndom 5))) ;; del
5430: 61 79 20 62 65 74 77 65 65 6e 20 35 20 61 6e 64 ay between 5 and
5440: 20 31 30 20 73 65 63 6f 6e 64 73 0a 09 09 20 20 10 seconds...
5450: 20 20 20 20 28 6c 6f 6f 70 20 28 63 6f 6d 6d 6f (loop (commo
5460: 6e 3a 73 69 6d 70 6c 65 2d 66 69 6c 65 2d 6c 6f n:simple-file-lo
5470: 63 6b 20 6c 6f 63 6b 66 29 29 29 29 29 29 29 29 ck lockf))))))))
5480: 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 74 65 73 ))..(define (tes
5490: 74 73 3a 67 65 6e 65 72 61 74 65 2d 68 74 6d 6c ts:generate-html
54a0: 2d 73 75 6d 6d 61 72 79 2d 66 6f 72 2d 69 74 65 -summary-for-ite
54b0: 72 61 74 65 64 2d 74 65 73 74 20 72 75 6e 2d 69 rated-test run-i
54c0: 64 20 74 65 73 74 2d 69 64 20 74 65 73 74 2d 6e d test-id test-n
54d0: 61 6d 65 20 6f 75 74 70 75 74 66 69 6c 65 6e 61 ame outputfilena
54e0: 6d 65 29 0a 20 20 28 6c 65 74 20 28 28 63 6f 75 me). (let ((cou
54f0: 6e 74 73 20 20 20 20 20 20 20 20 20 20 20 20 20 nts
5500: 20 28 6d 61 6b 65 2d 68 61 73 68 2d 74 61 62 6c (make-hash-tabl
5510: 65 29 29 0a 09 28 73 74 61 74 65 63 6f 75 6e 74 e))..(statecount
5520: 73 20 20 20 20 20 20 20 20 20 28 6d 61 6b 65 2d s (make-
5530: 68 61 73 68 2d 74 61 62 6c 65 29 29 0a 09 28 6f hash-table))..(o
5540: 75 74 74 78 74 20 20 20 20 20 20 20 20 20 20 20 uttxt
5550: 20 20 20 22 22 29 0a 09 28 74 6f 74 20 20 20 20 "")..(tot
5560: 20 20 20 20 20 20 20 20 20 20 20 20 20 30 29 0a 0).
5570: 09 28 74 65 73 74 64 61 74 20 20 20 20 20 20 20 .(testdat
5580: 20 20 20 20 20 20 28 72 6d 74 3a 74 65 73 74 2d (rmt:test-
5590: 67 65 74 2d 72 65 63 6f 72 64 73 2d 66 6f 72 2d get-records-for-
55a0: 69 6e 64 65 78 2d 66 69 6c 65 20 72 75 6e 2d 69 index-file run-i
55b0: 64 20 74 65 73 74 2d 6e 61 6d 65 29 29 29 0a 20 d test-name))).
55c0: 20 20 20 28 77 69 74 68 2d 6f 75 74 70 75 74 2d (with-output-
55d0: 74 6f 2d 66 69 6c 65 20 6f 75 74 70 75 74 66 69 to-file outputfi
55e0: 6c 65 6e 61 6d 65 0a 20 20 20 20 20 20 28 6c 61 lename. (la
55f0: 6d 62 64 61 20 28 29 0a 09 28 73 65 74 21 20 6f mbda ()..(set! o
5600: 75 74 74 78 74 20 28 63 6f 6e 63 20 6f 75 74 74 uttxt (conc outt
5610: 78 74 20 22 3c 68 74 6d 6c 3e 3c 74 69 74 6c 65 xt "<html><title
5620: 3e 53 75 6d 6d 61 72 79 3a 20 22 20 74 65 73 74 >Summary: " test
5630: 2d 6e 61 6d 65 20 0a 09 09 09 20 20 20 22 3c 2f -name .... "</
5640: 74 69 74 6c 65 3e 3c 62 6f 64 79 3e 3c 68 32 3e title><body><h2>
5650: 53 75 6d 6d 61 72 79 20 66 6f 72 20 22 20 74 65 Summary for " te
5660: 73 74 2d 6e 61 6d 65 20 22 3c 2f 68 32 3e 22 29 st-name "</h2>")
5670: 29 0a 09 28 66 6f 72 2d 65 61 63 68 0a 09 20 28 )..(for-each.. (
5680: 6c 61 6d 62 64 61 20 28 74 65 73 74 72 65 63 6f lambda (testreco
5690: 72 64 29 0a 09 20 20 20 28 6c 65 74 20 28 28 69 rd).. (let ((i
56a0: 64 20 20 20 20 20 20 20 20 20 20 20 20 20 28 76 d (v
56b0: 65 63 74 6f 72 2d 72 65 66 20 74 65 73 74 72 65 ector-ref testre
56c0: 63 6f 72 64 20 30 29 29 0a 09 09 20 28 69 74 65 cord 0))... (ite
56d0: 6d 70 61 74 68 20 20 20 20 20 20 20 28 76 65 63 mpath (vec
56e0: 74 6f 72 2d 72 65 66 20 74 65 73 74 72 65 63 6f tor-ref testreco
56f0: 72 64 20 31 29 29 0a 09 09 20 28 73 74 61 74 65 rd 1))... (state
5700: 20 20 20 20 20 20 20 20 20 20 28 76 65 63 74 6f (vecto
5710: 72 2d 72 65 66 20 74 65 73 74 72 65 63 6f 72 64 r-ref testrecord
5720: 20 32 29 29 0a 09 09 20 28 73 74 61 74 75 73 20 2))... (status
5730: 20 20 20 20 20 20 20 20 28 76 65 63 74 6f 72 2d (vector-
5740: 72 65 66 20 74 65 73 74 72 65 63 6f 72 64 20 33 ref testrecord 3
5750: 29 29 0a 09 09 20 28 72 75 6e 5f 64 75 72 61 74 ))... (run_durat
5760: 69 6f 6e 20 20 20 28 76 65 63 74 6f 72 2d 72 65 ion (vector-re
5770: 66 20 74 65 73 74 72 65 63 6f 72 64 20 34 29 29 f testrecord 4))
5780: 0a 09 09 20 28 6c 6f 67 66 20 20 20 20 20 20 20 ... (logf
5790: 20 20 20 20 28 76 65 63 74 6f 72 2d 72 65 66 20 (vector-ref
57a0: 74 65 73 74 72 65 63 6f 72 64 20 35 29 29 0a 09 testrecord 5))..
57b0: 09 20 28 63 6f 6d 6d 65 6e 74 20 20 20 20 20 20 . (comment
57c0: 20 20 28 76 65 63 74 6f 72 2d 72 65 66 20 74 65 (vector-ref te
57d0: 73 74 72 65 63 6f 72 64 20 36 29 29 29 0a 09 20 strecord 6)))..
57e0: 20 20 20 20 28 68 61 73 68 2d 74 61 62 6c 65 2d (hash-table-
57f0: 73 65 74 21 20 63 6f 75 6e 74 73 20 73 74 61 74 set! counts stat
5800: 75 73 20 28 2b 20 31 20 28 68 61 73 68 2d 74 61 us (+ 1 (hash-ta
5810: 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 ble-ref/default
5820: 63 6f 75 6e 74 73 20 73 74 61 74 75 73 20 30 29 counts status 0)
5830: 29 29 0a 09 20 20 20 20 20 28 68 61 73 68 2d 74 )).. (hash-t
5840: 61 62 6c 65 2d 73 65 74 21 20 73 74 61 74 65 63 able-set! statec
5850: 6f 75 6e 74 73 20 73 74 61 74 65 20 28 2b 20 31 ounts state (+ 1
5860: 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 (hash-table-ref
5870: 2f 64 65 66 61 75 6c 74 20 73 74 61 74 65 63 6f /default stateco
5880: 75 6e 74 73 20 73 74 61 74 65 20 30 29 29 29 0a unts state 0))).
5890: 09 20 20 20 20 20 28 73 65 74 21 20 6f 75 74 74 . (set! outt
58a0: 78 74 20 28 63 6f 6e 63 20 6f 75 74 74 78 74 20 xt (conc outtxt
58b0: 22 3c 74 72 3e 22 0a 09 09 09 09 3b 3b 20 22 3c "<tr>".....;; "<
58c0: 74 64 3e 3c 61 20 68 72 65 66 3d 5c 22 22 20 69 td><a href=\"" i
58d0: 74 65 6d 70 61 74 68 20 22 2f 22 20 6c 6f 67 66 tempath "/" logf
58e0: 20 22 5c 22 3e 20 22 20 69 74 65 6d 70 61 74 68 "\"> " itempath
58f0: 20 22 3c 2f 61 3e 3c 2f 74 64 3e 22 20 0a 09 09 "</a></td>" ...
5900: 09 09 22 3c 74 64 3e 3c 61 20 68 72 65 66 3d 5c .."<td><a href=\
5910: 22 22 20 69 74 65 6d 70 61 74 68 20 22 2f 74 65 "" itempath "/te
5920: 73 74 2d 73 75 6d 6d 61 72 79 2e 68 74 6d 6c 5c st-summary.html\
5930: 22 3e 20 22 20 69 74 65 6d 70 61 74 68 20 22 3c "> " itempath "<
5940: 2f 61 3e 3c 2f 74 64 3e 22 20 0a 09 09 09 09 22 /a></td>" ....."
5950: 3c 74 64 3e 22 20 73 74 61 74 65 20 20 20 20 22 <td>" state "
5960: 3c 2f 74 64 3e 22 20 0a 09 09 09 09 22 3c 74 64 </td>" ....."<td
5970: 3e 3c 66 6f 6e 74 20 63 6f 6c 6f 72 3d 22 20 28 ><font color=" (
5980: 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 63 6f 6c 6f 72 common:get-color
5990: 2d 66 72 6f 6d 2d 73 74 61 74 75 73 20 73 74 61 -from-status sta
59a0: 74 75 73 29 0a 09 09 09 09 22 3e 22 20 20 20 73 tus).....">" s
59b0: 74 61 74 75 73 20 20 20 22 3c 2f 66 6f 6e 74 3e tatus "</font>
59c0: 3c 2f 74 64 3e 22 0a 09 09 09 09 22 3c 74 64 3e </td>"....."<td>
59d0: 22 20 28 69 66 20 28 65 71 75 61 6c 3f 20 63 6f " (if (equal? co
59e0: 6d 6d 65 6e 74 20 22 22 29 0a 09 09 09 09 09 20 mment "")......
59f0: 20 20 22 26 6e 62 73 70 3b 22 0a 09 09 09 09 09 " "......
5a00: 20 20 20 63 6f 6d 6d 65 6e 74 29 20 22 3c 2f 74 comment) "</t
5a10: 64 3e 22 0a 09 09 09 09 09 20 20 20 22 3c 2f 74 d>"...... "</t
5a20: 72 3e 22 29 29 29 29 0a 09 20 28 69 66 20 28 6c r>")))).. (if (l
5a30: 69 73 74 3f 20 74 65 73 74 64 61 74 29 0a 09 20 ist? testdat)..
5a40: 20 20 20 20 74 65 73 74 64 61 74 0a 09 20 20 20 testdat..
5a50: 20 20 28 62 65 67 69 6e 0a 09 20 20 20 20 20 20 (begin..
5a60: 20 28 70 72 69 6e 74 20 22 45 52 52 4f 52 3a 20 (print "ERROR:
5a70: 66 61 69 6c 65 64 20 74 6f 20 67 65 74 20 72 65 failed to get re
5a80: 63 6f 72 64 73 20 77 69 74 68 20 72 6d 74 3a 74 cords with rmt:t
5a90: 65 73 74 2d 67 65 74 2d 72 65 63 6f 72 64 73 2d est-get-records-
5aa0: 66 6f 72 2d 69 6e 64 65 78 2d 66 69 6c 65 20 72 for-index-file r
5ab0: 75 6e 2d 69 64 3d 22 20 72 75 6e 2d 69 64 20 22 un-id=" run-id "
5ac0: 74 65 73 74 2d 6e 61 6d 65 3d 22 20 74 65 73 74 test-name=" test
5ad0: 2d 6e 61 6d 65 29 0a 09 20 20 20 20 20 20 20 27 -name).. '
5ae0: 28 29 29 29 29 0a 09 0a 09 28 70 72 69 6e 74 20 ())))....(print
5af0: 22 3c 74 61 62 6c 65 3e 3c 74 72 3e 3c 74 64 20 "<table><tr><td
5b00: 76 61 6c 69 67 6e 3d 5c 22 74 6f 70 5c 22 3e 22 valign=\"top\">"
5b10: 29 0a 09 3b 3b 20 50 72 69 6e 74 20 6f 75 74 20 )..;; Print out
5b20: 73 74 61 74 73 20 66 6f 72 20 73 74 61 74 75 73 stats for status
5b30: 0a 09 28 73 65 74 21 20 74 6f 74 20 30 29 0a 09 ..(set! tot 0)..
5b40: 28 70 72 69 6e 74 20 22 3c 74 61 62 6c 65 20 63 (print "<table c
5b50: 65 6c 6c 73 70 61 63 69 6e 67 3d 5c 22 30 5c 22 ellspacing=\"0\"
5b60: 20 62 6f 72 64 65 72 3d 5c 22 31 5c 22 3e 3c 74 border=\"1\"><t
5b70: 72 3e 3c 74 64 20 63 6f 6c 73 70 61 6e 3d 5c 22 r><td colspan=\"
5b80: 32 5c 22 3e 3c 68 32 3e 53 74 61 74 65 20 73 74 2\"><h2>State st
5b90: 61 74 73 3c 2f 68 32 3e 3c 2f 74 64 3e 3c 2f 74 ats</h2></td></t
5ba0: 72 3e 22 29 0a 09 28 66 6f 72 2d 65 61 63 68 20 r>")..(for-each
5bb0: 28 6c 61 6d 62 64 61 20 28 73 74 61 74 65 29 0a (lambda (state).
5bc0: 09 09 20 20 20 20 28 73 65 74 21 20 74 6f 74 20 .. (set! tot
5bd0: 28 2b 20 74 6f 74 20 28 68 61 73 68 2d 74 61 62 (+ tot (hash-tab
5be0: 6c 65 2d 72 65 66 20 73 74 61 74 65 63 6f 75 6e le-ref statecoun
5bf0: 74 73 20 73 74 61 74 65 29 29 29 0a 09 09 20 20 ts state)))...
5c00: 20 20 28 70 72 69 6e 74 20 22 3c 74 72 3e 3c 74 (print "<tr><t
5c10: 64 3e 22 20 73 74 61 74 65 20 22 3c 2f 74 64 3e d>" state "</td>
5c20: 3c 74 64 3e 22 20 28 68 61 73 68 2d 74 61 62 6c <td>" (hash-tabl
5c30: 65 2d 72 65 66 20 73 74 61 74 65 63 6f 75 6e 74 e-ref statecount
5c40: 73 20 73 74 61 74 65 29 20 22 3c 2f 74 64 3e 3c s state) "</td><
5c50: 2f 74 72 3e 22 29 29 0a 09 09 20 20 28 68 61 73 /tr>"))... (has
5c60: 68 2d 74 61 62 6c 65 2d 6b 65 79 73 20 73 74 61 h-table-keys sta
5c70: 74 65 63 6f 75 6e 74 73 29 29 0a 09 28 70 72 69 tecounts))..(pri
5c80: 6e 74 20 22 3c 74 72 3e 3c 74 64 3e 54 6f 74 61 nt "<tr><td>Tota
5c90: 6c 3c 2f 74 64 3e 3c 74 64 3e 22 20 74 6f 74 20 l</td><td>" tot
5ca0: 22 3c 2f 74 64 3e 3c 2f 74 72 3e 3c 2f 74 61 62 "</td></tr></tab
5cb0: 6c 65 3e 22 29 0a 09 28 70 72 69 6e 74 20 22 3c le>")..(print "<
5cc0: 2f 74 64 3e 3c 74 64 20 76 61 6c 69 67 6e 3d 5c /td><td valign=\
5cd0: 22 74 6f 70 5c 22 3e 22 29 0a 09 3b 3b 20 50 72 "top\">")..;; Pr
5ce0: 69 6e 74 20 6f 75 74 20 73 74 61 74 73 20 66 6f int out stats fo
5cf0: 72 20 73 74 61 74 65 0a 09 28 73 65 74 21 20 74 r state..(set! t
5d00: 6f 74 20 30 29 0a 09 28 70 72 69 6e 74 20 22 3c ot 0)..(print "<
5d10: 74 61 62 6c 65 20 63 65 6c 6c 73 70 61 63 69 6e table cellspacin
5d20: 67 3d 5c 22 30 5c 22 20 62 6f 72 64 65 72 3d 5c g=\"0\" border=\
5d30: 22 31 5c 22 3e 3c 74 72 3e 3c 74 64 20 63 6f 6c "1\"><tr><td col
5d40: 73 70 61 6e 3d 5c 22 32 5c 22 3e 3c 68 32 3e 53 span=\"2\"><h2>S
5d50: 74 61 74 75 73 20 73 74 61 74 73 3c 2f 68 32 3e tatus stats</h2>
5d60: 3c 2f 74 64 3e 3c 2f 74 72 3e 22 29 0a 09 28 66 </td></tr>")..(f
5d70: 6f 72 2d 65 61 63 68 20 28 6c 61 6d 62 64 61 20 or-each (lambda
5d80: 28 73 74 61 74 75 73 29 0a 09 09 20 20 20 20 28 (status)... (
5d90: 73 65 74 21 20 74 6f 74 20 28 2b 20 74 6f 74 20 set! tot (+ tot
5da0: 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 20 (hash-table-ref
5db0: 63 6f 75 6e 74 73 20 73 74 61 74 75 73 29 29 29 counts status)))
5dc0: 0a 09 09 20 20 20 20 28 70 72 69 6e 74 20 22 3c ... (print "<
5dd0: 74 72 3e 3c 74 64 3e 3c 66 6f 6e 74 20 63 6f 6c tr><td><font col
5de0: 6f 72 3d 5c 22 22 20 28 63 6f 6d 6d 6f 6e 3a 67 or=\"" (common:g
5df0: 65 74 2d 63 6f 6c 6f 72 2d 66 72 6f 6d 2d 73 74 et-color-from-st
5e00: 61 74 75 73 20 73 74 61 74 75 73 29 20 22 5c 22 atus status) "\"
5e10: 3e 22 20 73 74 61 74 75 73 0a 09 09 09 20 20 20 >" status....
5e20: 22 3c 2f 66 6f 6e 74 3e 3c 2f 74 64 3e 3c 74 64 "</font></td><td
5e30: 3e 22 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 >" (hash-table-r
5e40: 65 66 20 63 6f 75 6e 74 73 20 73 74 61 74 75 73 ef counts status
5e50: 29 20 22 3c 2f 74 64 3e 3c 2f 74 72 3e 22 29 29 ) "</td></tr>"))
5e60: 0a 09 09 20 20 28 68 61 73 68 2d 74 61 62 6c 65 ... (hash-table
5e70: 2d 6b 65 79 73 20 63 6f 75 6e 74 73 29 29 0a 09 -keys counts))..
5e80: 28 70 72 69 6e 74 20 22 3c 74 72 3e 3c 74 64 3e (print "<tr><td>
5e90: 54 6f 74 61 6c 3c 2f 74 64 3e 3c 74 64 3e 22 20 Total</td><td>"
5ea0: 74 6f 74 20 22 3c 2f 74 64 3e 3c 2f 74 72 3e 3c tot "</td></tr><
5eb0: 2f 74 61 62 6c 65 3e 22 29 0a 09 28 70 72 69 6e /table>")..(prin
5ec0: 74 20 22 3c 2f 74 64 3e 3c 2f 74 64 3e 3c 2f 74 t "</td></td></t
5ed0: 72 3e 3c 2f 74 61 62 6c 65 3e 22 29 0a 09 0a 09 r></table>")....
5ee0: 28 70 72 69 6e 74 20 22 3c 74 61 62 6c 65 20 63 (print "<table c
5ef0: 65 6c 6c 73 70 61 63 69 6e 67 3d 5c 22 30 5c 22 ellspacing=\"0\"
5f00: 20 62 6f 72 64 65 72 3d 5c 22 31 5c 22 3e 22 20 border=\"1\">"
5f10: 0a 09 20 20 20 20 20 20 20 22 3c 74 72 3e 3c 74 .. "<tr><t
5f20: 64 3e 49 74 65 6d 3c 2f 74 64 3e 3c 74 64 3e 53 d>Item</td><td>S
5f30: 74 61 74 65 3c 2f 74 64 3e 3c 74 64 3e 53 74 61 tate</td><td>Sta
5f40: 74 75 73 3c 2f 74 64 3e 3c 74 64 3e 43 6f 6d 6d tus</td><td>Comm
5f50: 65 6e 74 3c 2f 74 64 3e 22 0a 09 20 20 20 20 20 ent</td>"..
5f60: 20 20 6f 75 74 74 78 74 20 22 3c 2f 74 61 62 6c outtxt "</tabl
5f70: 65 3e 3c 2f 62 6f 64 79 3e 3c 2f 68 74 6d 6c 3e e></body></html>
5f80: 22 29 0a 09 3b 3b 20 28 72 65 6c 65 61 73 65 2d ")..;; (release-
5f90: 64 6f 74 2d 6c 6f 63 6b 20 6f 75 74 70 75 74 66 dot-lock outputf
5fa0: 69 6c 65 6e 61 6d 65 29 0a 09 3b 3b 28 72 6d 74 ilename)..;;(rmt
5fb0: 3a 75 70 64 61 74 65 2d 72 75 6e 2d 73 74 61 74 :update-run-stat
5fc0: 73 20 0a 09 3b 3b 20 72 75 6e 2d 69 64 0a 09 3b s ..;; run-id..;
5fd0: 3b 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 6d 61 ; (hash-table-ma
5fe0: 70 0a 09 3b 3b 20 20 73 74 61 74 65 2d 73 74 61 p..;; state-sta
5ff0: 74 75 73 2d 63 6f 75 6e 74 73 0a 09 3b 3b 20 20 tus-counts..;;
6000: 28 6c 61 6d 62 64 61 20 28 6b 65 79 20 76 61 6c (lambda (key val
6010: 29 0a 09 3b 3b 09 28 61 70 70 65 6e 64 20 6b 65 )..;;.(append ke
6020: 79 20 28 6c 69 73 74 20 76 61 6c 29 29 29 29 29 y (list val)))))
6030: 0a 09 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 ..))))..(define
6040: 74 65 73 74 73 3a 63 73 73 2d 6a 73 63 72 69 70 tests:css-jscrip
6050: 74 2d 62 6c 6f 63 6b 0a 23 3c 3c 45 4f 46 0a 3c t-block.#<<EOF.<
6060: 73 74 79 6c 65 20 74 79 70 65 3d 22 74 65 78 74 style type="text
6070: 2f 63 73 73 22 3e 0a 75 6c 2e 4c 69 6e 6b 65 64 /css">.ul.Linked
6080: 4c 69 73 74 20 7b 20 64 69 73 70 6c 61 79 3a 20 List { display:
6090: 62 6c 6f 63 6b 3b 20 7d 0a 2f 2a 20 75 6c 2e 4c block; }./* ul.L
60a0: 69 6e 6b 65 64 4c 69 73 74 20 75 6c 20 7b 20 64 inkedList ul { d
60b0: 69 73 70 6c 61 79 3a 20 6e 6f 6e 65 3b 20 7d 20 isplay: none; }
60c0: 2a 2f 0a 2e 48 61 6e 64 43 75 72 73 6f 72 53 74 */..HandCursorSt
60d0: 79 6c 65 20 7b 20 63 75 72 73 6f 72 3a 20 70 6f yle { cursor: po
60e0: 69 6e 74 65 72 3b 20 63 75 72 73 6f 72 3a 20 68 inter; cursor: h
60f0: 61 6e 64 3b 20 7d 20 20 2f 2a 20 46 6f 72 20 49 and; } /* For I
6100: 45 20 2a 2f 0a 20 20 3c 2f 73 74 79 6c 65 3e 0a E */. </style>.
6110: 0a 20 20 3c 73 63 72 69 70 74 20 74 79 70 65 3d . <script type=
6120: 22 74 65 78 74 2f 4a 61 76 61 53 63 72 69 70 74 "text/JavaScript
6130: 22 3e 0a 20 20 20 20 2f 2f 20 41 64 64 20 74 68 ">. // Add th
6140: 69 73 20 74 6f 20 74 68 65 20 6f 6e 6c 6f 61 64 is to the onload
6150: 20 65 76 65 6e 74 20 6f 66 20 74 68 65 20 42 4f event of the BO
6160: 44 59 20 65 6c 65 6d 65 6e 74 0a 20 20 20 20 66 DY element. f
6170: 75 6e 63 74 69 6f 6e 20 61 64 64 45 76 65 6e 74 unction addEvent
6180: 73 28 29 20 7b 0a 20 20 20 20 20 20 61 63 74 69 s() {. acti
6190: 76 61 74 65 54 72 65 65 28 64 6f 63 75 6d 65 6e vateTree(documen
61a0: 74 2e 67 65 74 45 6c 65 6d 65 6e 74 42 79 49 64 t.getElementById
61b0: 28 22 4c 69 6e 6b 65 64 4c 69 73 74 31 22 29 29 ("LinkedList1"))
61c0: 3b 0a 20 20 20 20 7d 0a 0a 20 20 20 20 2f 2f 20 ;. }.. //
61d0: 54 68 69 73 20 66 75 6e 63 74 69 6f 6e 20 74 72 This function tr
61e0: 61 76 65 72 73 65 73 20 74 68 65 20 6c 69 73 74 averses the list
61f0: 20 61 6e 64 20 61 64 64 20 6c 69 6e 6b 73 20 0a and add links .
6200: 20 20 20 20 2f 2f 20 74 6f 20 6e 65 73 74 65 64 // to nested
6210: 20 6c 69 73 74 20 69 74 65 6d 73 0a 20 20 20 20 list items.
6220: 66 75 6e 63 74 69 6f 6e 20 61 63 74 69 76 61 74 function activat
6230: 65 54 72 65 65 28 6f 4c 69 73 74 29 20 7b 0a 20 eTree(oList) {.
6240: 20 20 20 20 20 2f 2f 20 43 6f 6c 6c 61 70 73 65 // Collapse
6250: 20 74 68 65 20 74 72 65 65 0a 20 20 20 20 20 20 the tree.
6260: 66 6f 72 20 28 76 61 72 20 69 3d 30 3b 20 69 20 for (var i=0; i
6270: 3c 20 6f 4c 69 73 74 2e 67 65 74 45 6c 65 6d 65 < oList.getEleme
6280: 6e 74 73 42 79 54 61 67 4e 61 6d 65 28 22 75 6c ntsByTagName("ul
6290: 22 29 2e 6c 65 6e 67 74 68 3b 20 69 2b 2b 29 20 ").length; i++)
62a0: 7b 0a 20 20 20 20 20 20 20 20 6f 4c 69 73 74 2e {. oList.
62b0: 67 65 74 45 6c 65 6d 65 6e 74 73 42 79 54 61 67 getElementsByTag
62c0: 4e 61 6d 65 28 22 75 6c 22 29 5b 69 5d 2e 73 74 Name("ul")[i].st
62d0: 79 6c 65 2e 64 69 73 70 6c 61 79 3d 22 6e 6f 6e yle.display="non
62e0: 65 22 3b 20 20 20 20 20 20 20 20 20 20 20 20 0a e"; .
62f0: 20 20 20 20 20 20 7d 20 20 20 20 20 20 20 20 20 }
6300: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
6310: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
6320: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
6330: 20 20 20 20 20 20 20 20 20 0a 20 20 20 20 20 20 .
6340: 2f 2f 20 41 64 64 20 74 68 65 20 63 6c 69 63 6b // Add the click
6350: 2d 65 76 65 6e 74 20 68 61 6e 64 6c 65 72 20 74 -event handler t
6360: 6f 20 74 68 65 20 6c 69 73 74 20 69 74 65 6d 73 o the list items
6370: 0a 20 20 20 20 20 20 69 66 20 28 6f 4c 69 73 74 . if (oList
6380: 2e 61 64 64 45 76 65 6e 74 4c 69 73 74 65 6e 65 .addEventListene
6390: 72 29 20 7b 0a 20 20 20 20 20 20 20 20 6f 4c 69 r) {. oLi
63a0: 73 74 2e 61 64 64 45 76 65 6e 74 4c 69 73 74 65 st.addEventListe
63b0: 6e 65 72 28 22 63 6c 69 63 6b 22 2c 20 74 6f 67 ner("click", tog
63c0: 67 6c 65 42 72 61 6e 63 68 2c 20 66 61 6c 73 65 gleBranch, false
63d0: 29 3b 0a 20 20 20 20 20 20 7d 20 65 6c 73 65 20 );. } else
63e0: 69 66 20 28 6f 4c 69 73 74 2e 61 74 74 61 63 68 if (oList.attach
63f0: 45 76 65 6e 74 29 20 7b 20 2f 2f 20 46 6f 72 20 Event) { // For
6400: 49 45 0a 20 20 20 20 20 20 20 20 6f 4c 69 73 74 IE. oList
6410: 2e 61 74 74 61 63 68 45 76 65 6e 74 28 22 6f 6e .attachEvent("on
6420: 63 6c 69 63 6b 22 2c 20 74 6f 67 67 6c 65 42 72 click", toggleBr
6430: 61 6e 63 68 29 3b 0a 20 20 20 20 20 20 7d 0a 20 anch);. }.
6440: 20 20 20 20 20 2f 2f 20 4d 61 6b 65 20 74 68 65 // Make the
6450: 20 6e 65 73 74 65 64 20 69 74 65 6d 73 20 6c 6f nested items lo
6460: 6f 6b 20 6c 69 6b 65 20 6c 69 6e 6b 73 0a 20 20 ok like links.
6470: 20 20 20 20 61 64 64 4c 69 6e 6b 73 54 6f 42 72 addLinksToBr
6480: 61 6e 63 68 65 73 28 6f 4c 69 73 74 29 3b 0a 20 anches(oList);.
6490: 20 20 20 7d 0a 0a 20 20 20 20 2f 2f 20 54 68 69 }.. // Thi
64a0: 73 20 69 73 20 74 68 65 20 63 6c 69 63 6b 2d 65 s is the click-e
64b0: 76 65 6e 74 20 68 61 6e 64 6c 65 72 0a 20 20 20 vent handler.
64c0: 20 66 75 6e 63 74 69 6f 6e 20 74 6f 67 67 6c 65 function toggle
64d0: 42 72 61 6e 63 68 28 65 76 65 6e 74 29 20 7b 0a Branch(event) {.
64e0: 20 20 20 20 20 20 76 61 72 20 6f 42 72 61 6e 63 var oBranc
64f0: 68 2c 20 63 53 75 62 42 72 61 6e 63 68 65 73 3b h, cSubBranches;
6500: 0a 20 20 20 20 20 20 69 66 20 28 65 76 65 6e 74 . if (event
6510: 2e 74 61 72 67 65 74 29 20 7b 0a 20 20 20 20 20 .target) {.
6520: 20 20 20 6f 42 72 61 6e 63 68 20 3d 20 65 76 65 oBranch = eve
6530: 6e 74 2e 74 61 72 67 65 74 3b 0a 20 20 20 20 20 nt.target;.
6540: 20 7d 20 65 6c 73 65 20 69 66 20 28 65 76 65 6e } else if (even
6550: 74 2e 73 72 63 45 6c 65 6d 65 6e 74 29 20 7b 20 t.srcElement) {
6560: 2f 2f 20 46 6f 72 20 49 45 0a 20 20 20 20 20 20 // For IE.
6570: 20 20 6f 42 72 61 6e 63 68 20 3d 20 65 76 65 6e oBranch = even
6580: 74 2e 73 72 63 45 6c 65 6d 65 6e 74 3b 0a 20 20 t.srcElement;.
6590: 20 20 20 20 7d 0a 20 20 20 20 20 20 63 53 75 62 }. cSub
65a0: 42 72 61 6e 63 68 65 73 20 3d 20 6f 42 72 61 6e Branches = oBran
65b0: 63 68 2e 67 65 74 45 6c 65 6d 65 6e 74 73 42 79 ch.getElementsBy
65c0: 54 61 67 4e 61 6d 65 28 22 75 6c 22 29 3b 0a 20 TagName("ul");.
65d0: 20 20 20 20 20 69 66 20 28 63 53 75 62 42 72 61 if (cSubBra
65e0: 6e 63 68 65 73 2e 6c 65 6e 67 74 68 20 3e 20 30 nches.length > 0
65f0: 29 20 7b 0a 20 20 20 20 20 20 20 20 69 66 20 28 ) {. if (
6600: 63 53 75 62 42 72 61 6e 63 68 65 73 5b 30 5d 2e cSubBranches[0].
6610: 73 74 79 6c 65 2e 64 69 73 70 6c 61 79 20 3d 3d style.display ==
6620: 20 22 62 6c 6f 63 6b 22 29 20 7b 0a 20 20 20 20 "block") {.
6630: 20 20 20 20 20 20 63 53 75 62 42 72 61 6e 63 68 cSubBranch
6640: 65 73 5b 30 5d 2e 73 74 79 6c 65 2e 64 69 73 70 es[0].style.disp
6650: 6c 61 79 20 3d 20 22 6e 6f 6e 65 22 3b 0a 20 20 lay = "none";.
6660: 20 20 20 20 20 20 7d 20 65 6c 73 65 20 7b 0a 20 } else {.
6670: 20 20 20 20 20 20 20 20 20 63 53 75 62 42 72 61 cSubBra
6680: 6e 63 68 65 73 5b 30 5d 2e 73 74 79 6c 65 2e 64 nches[0].style.d
6690: 69 73 70 6c 61 79 20 3d 20 22 62 6c 6f 63 6b 22 isplay = "block"
66a0: 3b 0a 20 20 20 20 20 20 20 20 7d 0a 20 20 20 20 ;. }.
66b0: 20 20 7d 0a 20 20 20 20 7d 0a 0a 20 20 20 20 2f }. }.. /
66c0: 2f 20 54 68 69 73 20 66 75 6e 63 74 69 6f 6e 20 / This function
66d0: 6d 61 6b 65 73 20 6e 65 73 74 65 64 20 6c 69 73 makes nested lis
66e0: 74 20 69 74 65 6d 73 20 6c 6f 6f 6b 20 6c 69 6b t items look lik
66f0: 65 20 6c 69 6e 6b 73 0a 20 20 20 20 66 75 6e 63 e links. func
6700: 74 69 6f 6e 20 61 64 64 4c 69 6e 6b 73 54 6f 42 tion addLinksToB
6710: 72 61 6e 63 68 65 73 28 6f 4c 69 73 74 29 20 7b ranches(oList) {
6720: 0a 20 20 20 20 20 20 76 61 72 20 63 42 72 61 6e . var cBran
6730: 63 68 65 73 20 3d 20 6f 4c 69 73 74 2e 67 65 74 ches = oList.get
6740: 45 6c 65 6d 65 6e 74 73 42 79 54 61 67 4e 61 6d ElementsByTagNam
6750: 65 28 22 6c 69 22 29 3b 0a 20 20 20 20 20 20 76 e("li");. v
6760: 61 72 20 69 2c 20 6e 2c 20 63 53 75 62 42 72 61 ar i, n, cSubBra
6770: 6e 63 68 65 73 3b 0a 20 20 20 20 20 20 69 66 20 nches;. if
6780: 28 63 42 72 61 6e 63 68 65 73 2e 6c 65 6e 67 74 (cBranches.lengt
6790: 68 20 3e 20 30 29 20 7b 0a 20 20 20 20 20 20 20 h > 0) {.
67a0: 20 66 6f 72 20 28 69 3d 30 2c 20 6e 20 3d 20 63 for (i=0, n = c
67b0: 42 72 61 6e 63 68 65 73 2e 6c 65 6e 67 74 68 3b Branches.length;
67c0: 20 69 20 3c 20 6e 3b 20 69 2b 2b 29 20 7b 0a 20 i < n; i++) {.
67d0: 20 20 20 20 20 20 20 20 20 63 53 75 62 42 72 61 cSubBra
67e0: 6e 63 68 65 73 20 3d 20 63 42 72 61 6e 63 68 65 nches = cBranche
67f0: 73 5b 69 5d 2e 67 65 74 45 6c 65 6d 65 6e 74 73 s[i].getElements
6800: 42 79 54 61 67 4e 61 6d 65 28 22 75 6c 22 29 3b ByTagName("ul");
6810: 0a 20 20 20 20 20 20 20 20 20 20 69 66 20 28 63 . if (c
6820: 53 75 62 42 72 61 6e 63 68 65 73 2e 6c 65 6e 67 SubBranches.leng
6830: 74 68 20 3e 20 30 29 20 7b 0a 20 20 20 20 20 20 th > 0) {.
6840: 20 20 20 20 20 20 61 64 64 4c 69 6e 6b 73 54 6f addLinksTo
6850: 42 72 61 6e 63 68 65 73 28 63 53 75 62 42 72 61 Branches(cSubBra
6860: 6e 63 68 65 73 5b 30 5d 29 3b 0a 20 20 20 20 20 nches[0]);.
6870: 20 20 20 20 20 20 20 63 42 72 61 6e 63 68 65 73 cBranches
6880: 5b 69 5d 2e 63 6c 61 73 73 4e 61 6d 65 20 3d 20 [i].className =
6890: 22 48 61 6e 64 43 75 72 73 6f 72 53 74 79 6c 65 "HandCursorStyle
68a0: 22 3b 0a 20 20 20 20 20 20 20 20 20 20 20 20 63 ";. c
68b0: 42 72 61 6e 63 68 65 73 5b 69 5d 2e 73 74 79 6c Branches[i].styl
68c0: 65 2e 63 6f 6c 6f 72 20 3d 20 22 62 6c 75 65 22 e.color = "blue"
68d0: 3b 0a 20 20 20 20 20 20 20 20 20 20 20 20 63 53 ;. cS
68e0: 75 62 42 72 61 6e 63 68 65 73 5b 30 5d 2e 73 74 ubBranches[0].st
68f0: 79 6c 65 2e 63 6f 6c 6f 72 20 3d 20 22 62 6c 61 yle.color = "bla
6900: 63 6b 22 3b 0a 20 20 20 20 20 20 20 20 20 20 20 ck";.
6910: 20 63 53 75 62 42 72 61 6e 63 68 65 73 5b 30 5d cSubBranches[0]
6920: 2e 73 74 79 6c 65 2e 63 75 72 73 6f 72 20 3d 20 .style.cursor =
6930: 22 61 75 74 6f 22 3b 0a 20 20 20 20 20 20 20 20 "auto";.
6940: 20 20 7d 0a 20 20 20 20 20 20 20 20 7d 0a 20 20 }. }.
6950: 20 20 20 20 7d 0a 20 20 20 20 7d 0a 20 20 3c 2f }. }. </
6960: 73 63 72 69 70 74 3e 0a 45 4f 46 0a 29 0a 0a 28 script>.EOF.)..(
6970: 64 65 66 69 6e 65 20 28 74 65 73 74 73 3a 72 75 define (tests:ru
6980: 6e 2d 72 65 63 6f 72 64 2d 3e 74 65 73 74 2d 70 n-record->test-p
6990: 61 74 68 20 72 75 6e 20 6e 75 6d 6b 65 79 73 29 ath run numkeys)
69a0: 0a 20 20 20 28 61 70 70 65 6e 64 20 28 74 61 6b . (append (tak
69b0: 65 20 28 76 65 63 74 6f 72 2d 3e 6c 69 73 74 20 e (vector->list
69c0: 72 75 6e 29 20 6e 75 6d 6b 65 79 73 29 0a 09 20 run) numkeys)..
69d0: 20 20 28 6c 69 73 74 20 28 76 65 63 74 6f 72 2d (list (vector-
69e0: 72 65 66 20 72 75 6e 20 28 2b 20 31 20 6e 75 6d ref run (+ 1 num
69f0: 6b 65 79 73 29 29 29 29 29 0a 0a 3b 3b 20 28 74 keys)))))..;; (t
6a00: 65 73 74 73 3a 63 72 65 61 74 65 2d 68 74 6d 6c ests:create-html
6a10: 2d 74 72 65 65 20 22 74 65 73 74 2d 69 6e 64 65 -tree "test-inde
6a20: 78 2e 68 74 6d 6c 22 29 0a 3b 3b 0a 28 64 65 66 x.html").;;.(def
6a30: 69 6e 65 20 28 74 65 73 74 73 3a 63 72 65 61 74 ine (tests:creat
6a40: 65 2d 68 74 6d 6c 2d 74 72 65 65 20 6f 75 74 66 e-html-tree outf
6a50: 29 0a 20 20 28 6c 65 74 2a 20 28 28 6c 6f 63 6b ). (let* ((lock
6a60: 66 69 6c 65 20 20 28 63 6f 6e 63 20 6f 75 74 66 file (conc outf
6a70: 20 22 2e 6c 6f 63 6b 22 29 29 0a 09 20 28 72 75 ".lock")).. (ru
6a80: 6e 73 2d 74 6f 2d 70 72 6f 63 65 73 73 20 27 28 ns-to-process '(
6a90: 29 29 29 0a 20 20 20 20 28 69 66 20 28 63 6f 6d ))). (if (com
6aa0: 6d 6f 6e 3a 73 69 6d 70 6c 65 2d 66 69 6c 65 2d mon:simple-file-
6ab0: 6c 6f 63 6b 20 6c 6f 63 6b 66 69 6c 65 29 0a 09 lock lockfile)..
6ac0: 28 6c 65 74 2a 20 28 28 6c 69 6e 6b 74 72 65 65 (let* ((linktree
6ad0: 20 20 28 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 6c 69 (common:get-li
6ae0: 6e 6b 74 72 65 65 29 29 0a 09 20 20 20 20 20 20 nktree))..
6af0: 20 28 6f 75 70 20 20 20 20 20 20 20 28 6f 70 65 (oup (ope
6b00: 6e 2d 6f 75 74 70 75 74 2d 66 69 6c 65 20 28 6f n-output-file (o
6b10: 72 20 6f 75 74 66 20 28 63 6f 6e 63 20 6c 69 6e r outf (conc lin
6b20: 6b 74 72 65 65 20 22 2f 72 75 6e 73 2d 69 6e 64 ktree "/runs-ind
6b30: 65 78 2e 68 74 6d 6c 22 29 29 29 29 0a 09 20 20 ex.html"))))..
6b40: 20 20 20 20 20 28 61 72 65 61 2d 6e 61 6d 65 20 (area-name
6b50: 28 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 74 65 73 74 (common:get-test
6b60: 73 75 69 74 65 2d 6e 61 6d 65 29 29 0a 09 20 20 suite-name))..
6b70: 20 20 20 20 20 28 6b 65 79 73 20 20 20 20 20 20 (keys
6b80: 28 72 6d 74 3a 67 65 74 2d 6b 65 79 73 29 29 0a (rmt:get-keys)).
6b90: 09 20 20 20 20 20 20 20 28 6e 75 6d 6b 65 79 73 . (numkeys
6ba0: 20 20 20 28 6c 65 6e 67 74 68 20 6b 65 79 73 29 (length keys)
6bb0: 29 0a 09 20 20 20 20 20 20 20 28 72 75 6e 73 64 ).. (runsd
6bc0: 61 74 20 20 20 28 72 6d 74 3a 67 65 74 2d 72 75 at (rmt:get-ru
6bd0: 6e 73 20 22 25 22 20 23 66 20 23 66 20 28 6d 61 ns "%" #f #f (ma
6be0: 70 20 28 6c 61 6d 62 64 61 20 28 78 29 28 6c 69 p (lambda (x)(li
6bf0: 73 74 20 78 20 22 25 22 29 29 20 6b 65 79 73 29 st x "%")) keys)
6c00: 29 29 0a 09 20 20 20 20 20 20 20 28 68 65 61 64 )).. (head
6c10: 65 72 20 20 20 20 28 76 65 63 74 6f 72 2d 72 65 er (vector-re
6c20: 66 20 72 75 6e 73 64 61 74 20 30 29 29 0a 09 20 f runsdat 0))..
6c30: 20 20 20 20 20 20 28 72 75 6e 73 20 20 20 20 20 (runs
6c40: 20 28 76 65 63 74 6f 72 2d 72 65 66 20 72 75 6e (vector-ref run
6c50: 73 64 61 74 20 31 29 29 0a 09 20 20 20 20 20 20 sdat 1))..
6c60: 20 28 72 75 6e 74 72 65 65 64 61 74 20 28 6d 61 (runtreedat (ma
6c70: 70 20 28 6c 61 6d 62 64 61 20 28 78 29 0a 09 09 p (lambda (x)...
6c80: 09 09 20 20 28 74 65 73 74 73 3a 72 75 6e 2d 72 .. (tests:run-r
6c90: 65 63 6f 72 64 2d 3e 74 65 73 74 2d 70 61 74 68 ecord->test-path
6ca0: 20 78 20 6e 75 6d 6b 65 79 73 29 29 0a 09 09 09 x numkeys))....
6cb0: 09 72 75 6e 73 29 29 0a 09 20 20 20 20 20 20 20 .runs))..
6cc0: 28 72 75 6e 73 2d 68 74 72 65 65 20 28 63 6f 6d (runs-htree (com
6cd0: 6d 6f 6e 3a 6c 69 73 74 2d 3e 68 74 72 65 65 20 mon:list->htree
6ce0: 72 75 6e 74 72 65 65 64 61 74 29 29 29 0a 09 20 runtreedat)))..
6cf0: 20 28 73 65 74 21 20 72 75 6e 73 2d 74 6f 2d 70 (set! runs-to-p
6d00: 72 6f 63 65 73 73 20 72 75 6e 73 29 0a 09 20 20 rocess runs)..
6d10: 28 73 3a 6f 75 74 70 75 74 2d 6e 65 77 0a 09 20 (s:output-new..
6d20: 20 20 6f 75 70 0a 09 20 20 20 28 73 3a 68 74 6d oup.. (s:htm
6d30: 6c 20 74 65 73 74 73 3a 63 73 73 2d 6a 73 63 72 l tests:css-jscr
6d40: 69 70 74 2d 62 6c 6f 63 6b 0a 09 09 20 20 20 28 ipt-block... (
6d50: 73 3a 74 69 74 6c 65 20 22 53 75 6d 6d 61 72 79 s:title "Summary
6d60: 20 66 6f 72 20 22 20 61 72 65 61 2d 6e 61 6d 65 for " area-name
6d70: 29 0a 09 09 20 20 20 28 73 3a 62 6f 64 79 20 27 )... (s:body '
6d80: 6f 6e 6c 6f 61 64 20 22 61 64 64 45 76 65 6e 74 onload "addEvent
6d90: 73 28 29 3b 22 0a 09 09 09 20 20 20 28 73 3a 68 s();".... (s:h
6da0: 31 20 22 53 75 6d 6d 61 72 79 20 66 6f 72 20 22 1 "Summary for "
6db0: 20 61 72 65 61 2d 6e 61 6d 65 29 0a 09 09 09 20 area-name)....
6dc0: 20 20 3b 3b 20 74 6f 70 20 6c 69 73 74 0a 09 09 ;; top list...
6dd0: 09 20 20 20 28 73 3a 75 6c 20 27 69 64 20 22 4c . (s:ul 'id "L
6de0: 69 6e 6b 65 64 4c 69 73 74 31 22 20 27 63 6c 61 inkedList1" 'cla
6df0: 73 73 20 22 4c 69 6e 6b 65 64 4c 69 73 74 22 0a ss "LinkedList".
6e00: 09 09 09 09 20 28 73 3a 6c 69 0a 09 09 09 09 20 .... (s:li.....
6e10: 20 22 52 75 6e 73 22 0a 09 09 09 09 20 20 28 63 "Runs"..... (c
6e20: 6f 6d 6d 6f 6e 3a 68 74 72 65 65 2d 3e 68 74 6d ommon:htree->htm
6e30: 6c 20 72 75 6e 73 2d 68 74 72 65 65 0a 09 09 09 l runs-htree....
6e40: 09 09 09 20 20 20 20 20 20 27 28 29 0a 09 09 09 ... '()....
6e50: 09 09 09 20 20 20 20 20 20 28 6c 61 6d 62 64 61 ... (lambda
6e60: 20 28 78 20 70 29 0a 09 09 09 09 09 09 09 28 6c (x p)........(l
6e70: 65 74 2a 20 28 28 74 61 72 67 2d 70 61 74 68 20 et* ((targ-path
6e80: 28 73 74 72 69 6e 67 2d 69 6e 74 65 72 73 70 65 (string-interspe
6e90: 72 73 65 20 70 20 22 2f 22 29 29 0a 20 20 20 20 rse p "/")).
6ea0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
6eb0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
6ec0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
6ed0: 20 20 20 20 20 20 20 20 20 20 20 28 66 75 6c 6c (full
6ee0: 2d 70 61 74 68 20 28 63 6f 6e 63 20 6c 69 6e 6b -path (conc link
6ef0: 74 72 65 65 20 22 2f 22 20 74 61 72 67 2d 70 61 tree "/" targ-pa
6f00: 74 68 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 th)).
6f10: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
6f20: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
6f30: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
6f40: 20 20 20 20 28 72 75 6e 2d 6e 61 6d 65 20 20 28 (run-name (
6f50: 63 61 72 20 28 72 65 76 65 72 73 65 20 70 29 29 car (reverse p))
6f60: 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 )).
6f70: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
6f80: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
6f90: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 69 66 (if
6fa0: 20 28 61 6e 64 20 28 66 69 6c 65 2d 65 78 69 73 (and (file-exis
6fb0: 74 73 3f 20 66 75 6c 6c 2d 70 61 74 68 29 0a 20 ts? full-path).
6fc0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
6fd0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
6fe0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
6ff0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7000: 20 20 28 64 69 72 65 63 74 6f 72 79 3f 20 20 20 (directory?
7010: 66 75 6c 6c 2d 70 61 74 68 29 0a 20 20 20 20 20 full-path).
7020: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7030: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7040: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7050: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 66 (f
7060: 69 6c 65 2d 77 72 69 74 65 2d 61 63 63 65 73 73 ile-write-access
7070: 3f 20 66 75 6c 6c 2d 70 61 74 68 29 29 0a 20 20 ? full-path)).
7080: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7090: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
70a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
70b0: 20 20 20 20 20 20 20 20 20 20 20 20 28 73 3a 61 (s:a
70c0: 20 72 75 6e 2d 6e 61 6d 65 20 27 68 72 65 66 20 run-name 'href
70d0: 28 63 6f 6e 63 20 74 61 72 67 2d 70 61 74 68 20 (conc targ-path
70e0: 22 2f 72 75 6e 2d 73 75 6d 6d 61 72 79 2e 68 74 "/run-summary.ht
70f0: 6d 6c 22 29 29 0a 20 20 20 20 20 20 20 20 20 20 ml")).
7100: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7110: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7120: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7130: 20 20 20 20 28 62 65 67 69 6e 0a 20 20 20 20 20 (begin.
7140: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7150: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7160: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7170: 20 20 20 20 20 20 20 20 20 20 20 28 64 65 62 75 (debu
7180: 67 3a 70 72 69 6e 74 20 30 20 2a 64 65 66 61 75 g:print 0 *defau
7190: 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 49 4e lt-log-port* "IN
71a0: 46 4f 3a 20 43 61 6e 27 74 20 63 72 65 61 74 65 FO: Can't create
71b0: 20 22 20 74 61 72 67 2d 70 61 74 68 20 22 2f 72 " targ-path "/r
71c0: 75 6e 2d 73 75 6d 6d 61 72 79 2e 68 74 6d 6c 22 un-summary.html"
71d0: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
71e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
71f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7200: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7210: 20 20 28 63 6f 6e 63 20 72 75 6e 2d 6e 61 6d 65 (conc run-name
7220: 20 22 20 28 4e 6f 74 20 61 62 6c 65 20 74 6f 20 " (Not able to
7230: 63 72 65 61 74 65 20 73 75 6d 6d 61 72 79 20 61 create summary a
7240: 74 20 22 20 74 61 72 67 2d 70 61 74 68 20 22 29 t " targ-path ")
7250: 22 29 29 29 29 29 29 29 29 29 29 29 0a 20 20 20 "))))))))))).
7260: 20 20 20 20 20 20 20 28 63 6c 6f 73 65 2d 6f 75 (close-ou
7270: 74 70 75 74 2d 70 6f 72 74 20 6f 75 70 29 0a 09 tput-port oup)..
7280: 20 20 28 63 6f 6d 6d 6f 6e 3a 73 69 6d 70 6c 65 (common:simple
7290: 2d 66 69 6c 65 2d 72 65 6c 65 61 73 65 2d 6c 6f -file-release-lo
72a0: 63 6b 20 6c 6f 63 6b 66 69 6c 65 29 0a 09 20 20 ck lockfile)..
72b0: 28 66 6f 72 2d 65 61 63 68 0a 09 20 20 20 28 6c (for-each.. (l
72c0: 61 6d 62 64 61 20 28 72 75 6e 29 0a 09 20 20 20 ambda (run)..
72d0: 20 20 28 6c 65 74 2a 20 28 28 74 65 73 74 2d 73 (let* ((test-s
72e0: 75 62 70 61 74 68 20 28 74 65 73 74 73 3a 72 75 ubpath (tests:ru
72f0: 6e 2d 72 65 63 6f 72 64 2d 3e 74 65 73 74 2d 70 n-record->test-p
7300: 61 74 68 20 72 75 6e 20 6e 75 6d 6b 65 79 73 29 ath run numkeys)
7310: 29 0a 09 09 20 20 20 20 28 72 75 6e 2d 69 64 20 )... (run-id
7320: 20 20 20 20 20 20 28 64 62 3a 67 65 74 2d 76 61 (db:get-va
7330: 6c 75 65 2d 62 79 2d 68 65 61 64 65 72 20 72 75 lue-by-header ru
7340: 6e 20 68 65 61 64 65 72 20 22 69 64 22 29 29 0a n header "id")).
7350: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7360: 20 20 20 20 28 72 75 6e 2d 64 69 72 20 20 20 20 (run-dir
7370: 20 20 28 74 65 73 74 73 3a 72 75 6e 2d 72 65 63 (tests:run-rec
7380: 6f 72 64 2d 3e 74 65 73 74 2d 70 61 74 68 20 72 ord->test-path r
7390: 75 6e 20 6e 75 6d 6b 65 79 73 29 29 0a 09 09 20 un numkeys))...
73a0: 20 20 20 28 74 65 73 74 2d 64 61 74 73 20 20 20 (test-dats
73b0: 20 28 72 6d 74 3a 67 65 74 2d 74 65 73 74 73 2d (rmt:get-tests-
73c0: 66 6f 72 2d 72 75 6e 0a 09 09 09 09 20 20 20 72 for-run..... r
73d0: 75 6e 2d 69 64 0a 20 20 20 20 20 20 20 20 20 20 un-id.
73e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
73f0: 20 20 20 20 20 20 20 20 20 22 25 2f 22 20 20 20 "%/"
7400: 20 20 20 20 3b 3b 20 74 65 73 74 6e 61 6d 65 70 ;; testnamep
7410: 61 74 74 0a 09 09 09 09 20 20 20 27 28 29 20 20 att..... '()
7420: 20 20 20 20 20 20 3b 3b 20 73 74 61 74 65 73 0a ;; states.
7430: 09 09 09 09 20 20 20 27 28 29 20 20 20 20 20 20 .... '()
7440: 20 20 3b 3b 20 73 74 61 74 75 73 65 73 0a 09 09 ;; statuses...
7450: 09 09 20 20 20 23 66 20 20 20 20 20 20 20 20 20 .. #f
7460: 3b 3b 20 6f 66 66 73 65 74 0a 09 09 09 09 20 20 ;; offset.....
7470: 20 23 66 20 20 20 20 20 20 20 20 20 3b 3b 20 6e #f ;; n
7480: 75 6d 2d 74 6f 2d 67 65 74 0a 09 09 09 09 20 20 um-to-get.....
7490: 20 23 66 20 20 20 20 20 20 20 20 20 3b 3b 20 68 #f ;; h
74a0: 69 64 65 2f 6e 6f 74 2d 68 69 64 65 0a 09 09 09 ide/not-hide....
74b0: 09 20 20 20 23 66 20 20 20 20 20 20 20 20 20 3b . #f ;
74c0: 3b 20 73 6f 72 74 2d 62 79 0a 09 09 09 09 20 20 ; sort-by.....
74d0: 20 23 66 20 20 20 20 20 20 20 20 20 3b 3b 20 73 #f ;; s
74e0: 6f 72 74 2d 6f 72 64 65 72 0a 09 09 09 09 20 20 ort-order.....
74f0: 20 23 66 20 20 20 20 20 20 20 20 20 3b 3b 20 27 #f ;; '
7500: 73 68 6f 72 74 6c 69 73 74 20 20 20 20 20 20 20 shortlist
7510: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7520: 20 20 20 20 3b 3b 20 71 72 79 74 79 70 65 0a 20 ;; qrytype.
7530: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7540: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7550: 20 20 30 20 20 20 20 20 20 20 20 20 3b 3b 20 6c 0 ;; l
7560: 61 73 74 20 75 70 64 61 74 65 0a 09 09 09 09 20 ast update.....
7570: 20 20 23 66 29 29 0a 20 20 20 20 20 20 20 20 20 #f)).
7580: 20 20 20 20 20 20 20 20 20 20 20 28 74 65 73 74 (test
7590: 73 2d 74 72 65 65 2d 64 61 74 20 28 6d 61 70 20 s-tree-dat (map
75a0: 28 6c 61 6d 62 64 61 20 28 74 65 73 74 2d 64 61 (lambda (test-da
75b0: 74 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 t).
75c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
75d0: 20 20 20 20 20 20 20 20 20 20 20 20 3b 3b 20 28 ;; (
75e0: 74 65 73 74 73 3a 72 75 6e 2d 72 65 63 6f 72 64 tests:run-record
75f0: 2d 3e 74 65 73 74 2d 70 61 74 68 20 78 20 6e 75 ->test-path x nu
7600: 6d 6b 65 79 73 29 29 0a 20 20 20 20 20 20 20 20 mkeys)).
7610: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7620: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7630: 20 28 6c 65 74 2a 20 28 28 74 65 73 74 2d 6e 61 (let* ((test-na
7640: 6d 65 20 20 28 64 62 3a 74 65 73 74 2d 67 65 74 me (db:test-get
7650: 2d 74 65 73 74 6e 61 6d 65 20 74 65 73 74 2d 64 -testname test-d
7660: 61 74 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 at)).
7670: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7680: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7690: 20 20 20 20 20 28 69 74 65 6d 2d 70 61 74 68 20 (item-path
76a0: 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 69 74 (db:test-get-it
76b0: 65 6d 2d 70 61 74 68 20 74 65 73 74 2d 64 61 74 em-path test-dat
76c0: 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 )).
76d0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
76e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
76f0: 20 20 20 28 66 75 6c 6c 2d 6e 61 6d 65 20 20 28 (full-name (
7700: 64 62 3a 74 65 73 74 2d 6d 61 6b 65 2d 66 75 6c db:test-make-ful
7710: 6c 2d 6e 61 6d 65 20 74 65 73 74 2d 6e 61 6d 65 l-name test-name
7720: 20 69 74 65 6d 2d 70 61 74 68 29 29 0a 20 20 20 item-path)).
7730: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7740: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7750: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 70 61 (pa
7760: 74 68 2d 70 61 72 74 73 20 28 73 74 72 69 6e 67 th-parts (string
7770: 2d 73 70 6c 69 74 20 66 75 6c 6c 2d 6e 61 6d 65 -split full-name
7780: 29 29 29 0a 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 20 20 20 20 20 20 20 20 20 70 p
77b0: 61 74 68 2d 70 61 72 74 73 29 29 0a 20 20 20 20 ath-parts)).
77c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
77d0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
77e0: 20 20 20 74 65 73 74 2d 64 61 74 73 29 29 0a 20 test-dats)).
77f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7800: 20 20 20 28 74 65 73 74 73 2d 68 74 72 65 65 20 (tests-htree
7810: 28 63 6f 6d 6d 6f 6e 3a 6c 69 73 74 2d 3e 68 74 (common:list->ht
7820: 72 65 65 20 74 65 73 74 73 2d 74 72 65 65 2d 64 ree tests-tree-d
7830: 61 74 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 at)).
7840: 20 20 20 20 20 20 20 20 20 28 68 74 6d 6c 2d 64 (html-d
7850: 69 72 20 20 20 20 28 63 6f 6e 63 20 6c 69 6e 6b ir (conc link
7860: 74 72 65 65 20 22 2f 22 20 28 73 74 72 69 6e 67 tree "/" (string
7870: 2d 69 6e 74 65 72 73 70 65 72 73 65 20 72 75 6e -intersperse run
7880: 2d 64 69 72 20 22 2f 22 29 29 29 0a 20 20 20 20 -dir "/"))).
7890: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
78a0: 28 68 74 6d 6c 2d 70 61 74 68 20 20 20 28 63 6f (html-path (co
78b0: 6e 63 20 68 74 6d 6c 2d 64 69 72 20 22 2f 72 75 nc html-dir "/ru
78c0: 6e 2d 73 75 6d 6d 61 72 79 2e 68 74 6d 6c 22 29 n-summary.html")
78d0: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
78e0: 20 20 20 20 20 20 28 6f 75 70 20 20 20 20 20 20 (oup
78f0: 20 20 20 28 69 66 20 28 61 6e 64 20 28 66 69 6c (if (and (fil
7900: 65 2d 65 78 69 73 74 73 3f 20 68 74 6d 6c 2d 64 e-exists? html-d
7910: 69 72 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 ir).
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 28 64 (d
7940: 69 72 65 63 74 6f 72 79 3f 20 20 20 68 74 6d 6c irectory? html
7950: 2d 64 69 72 29 0a 20 20 20 20 20 20 20 20 20 20 -dir).
7960: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7970: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7980: 28 66 69 6c 65 2d 77 72 69 74 65 2d 61 63 63 65 (file-write-acce
7990: 73 73 3f 20 68 74 6d 6c 2d 64 69 72 29 29 0a 20 ss? html-dir)).
79a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
79b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
79c0: 20 20 20 20 28 6f 70 65 6e 2d 6f 75 74 70 75 74 (open-output
79d0: 2d 66 69 6c 65 20 20 68 74 6d 6c 2d 70 61 74 68 -file html-path
79e0: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
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 23 66 29 29 29 0a 20 20 20 #f))).
7a10: 20 20 20 20 20 20 20 20 20 20 20 20 3b 3b 20 28 ;; (
7a20: 70 72 69 6e 74 20 22 72 75 6e 2d 64 69 72 3a 20 print "run-dir:
7a30: 22 20 72 75 6e 2d 64 69 72 20 22 2c 20 74 65 73 " run-dir ", tes
7a40: 74 73 2d 74 72 65 65 2d 64 61 74 3a 20 22 20 74 ts-tree-dat: " t
7a50: 65 73 74 73 2d 74 72 65 65 2d 64 61 74 29 0a 20 ests-tree-dat).
7a60: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 69 (i
7a70: 66 20 6f 75 70 0a 20 20 20 20 20 20 20 20 20 20 f oup.
7a80: 20 20 20 20 20 20 20 20 20 28 62 65 67 69 6e 0a (begin.
7a90: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7aa0: 20 20 20 20 20 28 73 3a 6f 75 74 70 75 74 2d 6e (s:output-n
7ab0: 65 77 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 ew.
7ac0: 20 20 20 20 20 20 20 20 20 6f 75 70 0a 20 20 20 oup.
7ad0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7ae0: 20 20 20 28 73 3a 68 74 6d 6c 20 74 65 73 74 73 (s:html tests
7af0: 3a 63 73 73 2d 6a 73 63 72 69 70 74 2d 62 6c 6f :css-jscript-blo
7b00: 63 6b 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 ck.
7b10: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7b20: 20 28 73 3a 74 69 74 6c 65 20 22 53 75 6d 6d 61 (s:title "Summa
7b30: 72 79 20 66 6f 72 20 22 20 61 72 65 61 2d 6e 61 ry for " area-na
7b40: 6d 65 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 me).
7b50: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7b60: 20 20 28 73 3a 62 6f 64 79 20 27 6f 6e 6c 6f 61 (s:body 'onloa
7b70: 64 20 22 61 64 64 45 76 65 6e 74 73 28 29 3b 22 d "addEvents();"
7b80: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
7b90: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7ba0: 20 20 20 20 20 20 20 28 73 3a 68 31 20 22 53 75 (s:h1 "Su
7bb0: 6d 6d 61 72 79 20 66 6f 72 20 22 20 28 73 74 72 mmary for " (str
7bc0: 69 6e 67 2d 69 6e 74 65 72 73 70 65 72 73 65 20 ing-intersperse
7bd0: 72 75 6e 2d 64 69 72 20 22 2f 22 29 29 0a 20 20 run-dir "/")).
7be0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7bf0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7c00: 20 20 20 20 3b 3b 20 74 6f 70 20 6c 69 73 74 0a ;; top list.
7c10: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7c20: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7c30: 20 20 20 20 20 20 28 73 3a 75 6c 20 27 69 64 20 (s:ul 'id
7c40: 22 4c 69 6e 6b 65 64 4c 69 73 74 31 22 20 27 63 "LinkedList1" 'c
7c50: 6c 61 73 73 20 22 4c 69 6e 6b 65 64 4c 69 73 74 lass "LinkedList
7c60: 22 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ".
7c70: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7c80: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 73 (s
7c90: 3a 6c 69 0a 20 20 20 20 20 20 20 20 20 20 20 20 :li.
7ca0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7cb0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7cc0: 20 22 54 65 73 74 73 22 0a 20 20 20 20 20 20 20 "Tests".
7cd0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7ce0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7cf0: 20 20 20 20 20 20 28 63 6f 6d 6d 6f 6e 3a 68 74 (common:ht
7d00: 72 65 65 2d 3e 68 74 6d 6c 20 74 65 73 74 73 2d ree->html tests-
7d10: 68 74 72 65 65 0a 20 20 20 20 20 20 20 20 20 20 htree.
7d20: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
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 20 20 20 20 20 20 20 20
7d50: 20 20 20 20 20 20 20 27 28 29 0a 20 20 20 20 20 '().
7d60: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7d70: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7d80: 20 20 20 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 28 6c 61 6d (lam
7da0: 62 64 61 20 28 78 20 70 29 0a 20 20 20 20 20 20 bda (x p).
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 20 20 20 20 20 20 20 20 20
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 20 28 6c 65 (le
7df0: 74 2a 20 28 28 74 61 72 67 2d 70 61 74 68 20 28 t* ((targ-path (
7e00: 73 74 72 69 6e 67 2d 69 6e 74 65 72 73 70 65 72 string-intersper
7e10: 73 65 20 70 20 22 2f 22 29 29 0a 20 20 20 20 20 se p "/")).
7e20: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7e30: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
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 20 20 20 20 28 74 65 73 74 2d 6e 61 6d 65 20 (test-name
7e70: 28 63 61 72 20 70 29 29 0a 20 20 20 20 20 20 20 (car p)).
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 20
7ea0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7eb0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7ec0: 20 20 20 28 69 74 65 6d 2d 70 61 74 68 20 3b 3b (item-path ;;
7ed0: 20 28 69 66 20 28 3e 20 28 6c 65 6e 67 74 68 20 (if (> (length
7ee0: 70 29 20 32 29 20 3b 3b 20 74 65 73 74 2d 6e 61 p) 2) ;; test-na
7ef0: 6d 65 20 2b 20 72 75 6e 2d 6e 61 6d 65 0a 20 20 me + run-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 20 20
7f20: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7f30: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7f40: 20 20 20 20 20 20 20 20 20 28 73 74 72 69 6e 67 (string
7f50: 2d 69 6e 74 65 72 73 70 65 72 73 65 20 70 20 22 -intersperse p "
7f60: 2f 22 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 /")).
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: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7fa0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
7fb0: 66 75 6c 6c 2d 74 61 72 67 20 28 63 6f 6e 63 20 full-targ (conc
7fc0: 68 74 6d 6c 2d 64 69 72 20 22 2f 22 20 74 61 72 html-dir "/" tar
7fd0: 67 2d 70 61 74 68 29 29 0a 20 20 20 20 20 20 20 g-path)).
7fe0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7ff0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8000: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8010: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8020: 20 20 20 28 73 74 64 2d 66 69 6c 65 20 20 28 63 (std-file (c
8030: 6f 6e 63 20 66 75 6c 6c 2d 74 61 72 67 20 22 2f onc full-targ "/
8040: 74 65 73 74 2d 73 75 6d 6d 61 72 79 2e 68 74 6d test-summary.htm
8050: 6c 22 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 l")).
8060: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8070: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8080: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8090: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
80a0: 61 6c 74 2d 66 69 6c 65 20 20 28 63 6f 6e 63 20 alt-file (conc
80b0: 66 75 6c 6c 2d 74 61 72 67 20 22 2f 6d 65 67 61 full-targ "/mega
80c0: 74 65 73 74 2d 72 6f 6c 6c 75 70 2d 22 20 74 65 test-rollup-" te
80d0: 73 74 2d 6e 61 6d 65 20 22 2e 68 74 6d 6c 22 29 st-name ".html")
80e0: 29 0a 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: 20 20 20 20 20 20 20 20 20 20 20 20 28 68 74 6d (htm
8130: 6c 2d 66 69 6c 65 20 28 69 66 20 28 66 69 6c 65 l-file (if (file
8140: 2d 65 78 69 73 74 73 3f 20 61 6c 74 2d 66 69 6c -exists? alt-fil
8150: 65 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 e).
8160: 20 20 20 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 20 20 20 61 6c 74 2d alt-
81b0: 66 69 6c 65 0a 20 20 20 20 20 20 20 20 20 20 20 file.
81c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
81d0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
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 73 74 st
8210: 64 2d 66 69 6c 65 29 29 0a 20 20 20 20 20 20 20 d-file)).
8220: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8230: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8240: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8250: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8260: 20 20 20 28 72 75 6e 2d 6e 61 6d 65 20 20 28 63 (run-name (c
8270: 61 72 20 28 72 65 76 65 72 73 65 20 70 29 29 29 ar (reverse p)))
8280: 29 0a 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 20
82a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
82b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
82c0: 20 20 20 20 20 20 20 28 69 66 20 28 61 6e 64 20 (if (and
82d0: 28 6e 6f 74 20 28 66 69 6c 65 2d 65 78 69 73 74 (not (file-exist
82e0: 73 3f 20 66 75 6c 6c 2d 74 61 72 67 29 29 0a 20 s? full-targ)).
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 20 20 20
8310: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
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 28 64 69 (di
8340: 72 65 63 74 6f 72 79 3f 20 66 75 6c 6c 2d 74 61 rectory? full-ta
8350: 72 67 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 rg).
8360: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8370: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8380: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8390: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
83a0: 20 20 28 66 69 6c 65 2d 77 72 69 74 65 2d 61 63 (file-write-ac
83b0: 63 65 73 73 3f 20 66 75 6c 6c 2d 74 61 72 67 29 cess? full-targ)
83c0: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
83d0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
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 28 74 65 73 74 (test
8410: 73 3a 73 75 6d 6d 61 72 69 7a 65 2d 74 65 73 74 s:summarize-test
8420: 20 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
8430: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
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 72 75 6e 2d run-
8470: 69 64 20 0a 20 20 20 20 20 20 20 20 20 20 20 20 id .
8480: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8490: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
84a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
84b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 72 (r
84c0: 6d 74 3a 67 65 74 2d 74 65 73 74 2d 69 64 20 72 mt:get-test-id r
84d0: 75 6e 2d 69 64 20 74 65 73 74 2d 6e 61 6d 65 20 un-id test-name
84e0: 69 74 65 6d 2d 70 61 74 68 29 29 29 0a 20 20 20 item-path))).
84f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8500: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
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 28 69 66 20 28 66 69 6c 65 2d 65 78 69 73 (if (file-exis
8540: 74 73 3f 20 66 75 6c 6c 2d 74 61 72 67 29 0a 20 ts? full-targ).
8550: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8560: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8570: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8580: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8590: 20 20 20 20 20 20 20 20 28 73 3a 61 20 72 75 6e (s:a run
85a0: 2d 6e 61 6d 65 20 27 68 72 65 66 20 68 74 6d 6c -name 'href html
85b0: 2d 66 69 6c 65 29 0a 20 20 20 20 20 20 20 20 20 -file).
85c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
85d0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
85e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
85f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8600: 28 62 65 67 69 6e 0a 20 20 20 20 20 20 20 20 20 (begin.
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 20 20 20 20
8630: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8640: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8650: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 (debug:print 0
8660: 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f *default-log-po
8670: 72 74 2a 20 22 45 52 52 4f 52 3a 20 63 61 6e 27 rt* "ERROR: can'
8680: 74 20 61 63 63 65 73 73 20 22 20 66 75 6c 6c 2d t access " full-
8690: 74 61 72 67 29 0a 20 20 20 20 20 20 20 20 20 20 targ).
86a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
86b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
86c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
86d0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
86e0: 20 28 63 6f 6e 63 20 22 4e 6f 20 73 75 6d 6d 61 (conc "No summa
86f0: 72 79 20 66 6f 72 20 22 20 72 75 6e 2d 6e 61 6d ry for " run-nam
8700: 65 29 29 29 29 29 0a 20 20 20 20 20 20 20 20 20 e))))).
8710: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8720: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8730: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8740: 20 20 20 20 20 20 20 20 29 29 29 29 29 29 0a 20 )))))).
8750: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8760: 20 20 20 20 28 63 6c 6f 73 65 2d 6f 75 74 70 75 (close-outpu
8770: 74 2d 70 6f 72 74 20 6f 75 70 29 29 29 29 29 0a t-port oup))))).
8780: 20 20 20 20 20 20 20 20 20 20 20 72 75 6e 73 29 runs)
8790: 0a 20 20 20 20 20 20 20 20 20 20 23 74 29 0a 09 . #t)..
87a0: 23 66 29 29 29 0a 0a 0a 3b 3b 20 43 48 45 43 4b #f)))...;; CHECK
87b0: 20 2d 20 57 41 53 20 54 48 49 53 20 41 44 44 45 - WAS THIS ADDE
87c0: 44 20 4f 52 20 52 45 4d 4f 56 45 44 3f 20 4d 41 D OR REMOVED? MA
87d0: 4e 55 41 4c 20 4d 45 52 47 45 20 57 49 54 48 20 NUAL MERGE WITH
87e0: 41 50 49 20 53 54 55 46 46 21 21 21 0a 3b 3b 0a API STUFF!!!.;;.
87f0: 3b 3b 20 67 65 74 20 61 20 70 72 65 74 74 79 20 ;; get a pretty
8800: 74 61 62 6c 65 20 74 6f 20 73 75 6d 6d 61 72 69 table to summari
8810: 7a 65 20 73 74 65 70 73 0a 3b 3b 0a 3b 3b 20 28 ze steps.;;.;; (
8820: 64 65 66 69 6e 65 20 28 64 63 6f 6d 6d 6f 6e 3a define (dcommon:
8830: 70 72 6f 63 65 73 73 2d 73 74 65 70 73 2d 74 61 process-steps-ta
8840: 62 6c 65 20 73 74 65 70 73 29 3b 3b 20 64 62 20 ble steps);; db
8850: 74 65 73 74 2d 69 64 20 23 21 6b 65 79 20 28 77 test-id #!key (w
8860: 6f 72 6b 2d 61 72 65 61 20 23 66 29 29 0a 28 64 ork-area #f)).(d
8870: 65 66 69 6e 65 20 28 74 65 73 74 73 3a 70 72 6f efine (tests:pro
8880: 63 65 73 73 2d 73 74 65 70 73 2d 74 61 62 6c 65 cess-steps-table
8890: 20 73 74 65 70 73 29 3b 3b 20 64 62 20 74 65 73 steps);; db tes
88a0: 74 2d 69 64 20 23 21 6b 65 79 20 28 77 6f 72 6b t-id #!key (work
88b0: 2d 61 72 65 61 20 23 66 29 29 0a 3b 3b 20 20 28 -area #f)).;; (
88c0: 6c 65 74 20 28 28 73 74 65 70 73 20 20 20 28 64 let ((steps (d
88d0: 62 3a 67 65 74 2d 73 74 65 70 73 2d 66 6f 72 2d b:get-steps-for-
88e0: 74 65 73 74 20 64 62 20 74 65 73 74 2d 69 64 20 test db test-id
88f0: 77 6f 72 6b 2d 61 72 65 61 3a 20 77 6f 72 6b 2d work-area: work-
8900: 61 72 65 61 29 29 29 0a 20 20 20 20 3b 3b 20 6f area))). ;; o
8910: 72 67 61 6e 69 73 65 20 74 68 65 20 73 74 65 70 rganise the step
8920: 73 20 66 6f 72 20 62 65 74 74 65 72 20 72 65 61 s for better rea
8930: 64 61 62 69 6c 69 74 79 0a 20 20 20 20 28 6c 65 dability. (le
8940: 74 20 28 28 72 65 73 20 28 6d 61 6b 65 2d 68 61 t ((res (make-ha
8950: 73 68 2d 74 61 62 6c 65 29 29 29 0a 20 20 20 20 sh-table))).
8960: 20 20 28 66 6f 72 2d 65 61 63 68 20 0a 20 20 20 (for-each .
8970: 20 20 20 20 28 6c 61 6d 62 64 61 20 28 73 74 65 (lambda (ste
8980: 70 29 0a 09 20 28 64 65 62 75 67 3a 70 72 69 6e p).. (debug:prin
8990: 74 20 36 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 t 6 *default-log
89a0: 2d 70 6f 72 74 2a 20 22 73 74 65 70 3d 22 20 73 -port* "step=" s
89b0: 74 65 70 29 0a 09 20 28 6c 65 74 20 28 28 72 65 tep).. (let ((re
89c0: 63 6f 72 64 20 28 68 61 73 68 2d 74 61 62 6c 65 cord (hash-table
89d0: 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 0a 09 09 -ref/default ...
89e0: 09 72 65 73 20 0a 09 09 09 28 74 64 62 3a 73 74 .res ....(tdb:st
89f0: 65 70 2d 67 65 74 2d 73 74 65 70 6e 61 6d 65 20 ep-get-stepname
8a00: 73 74 65 70 29 20 0a 09 09 09 3b 3b 20 20 20 20 step) ....;;
8a10: 20 20 20 20 73 74 65 70 6e 61 6d 65 20 20 20 20 stepname
8a20: 20 20 20 20 20 20 20 20 20 20 20 20 73 74 61 72 star
8a30: 74 20 65 6e 64 20 73 74 61 74 75 73 20 44 75 72 t end status Dur
8a40: 61 74 69 6f 6e 20 20 4c 6f 67 66 69 6c 65 20 43 ation Logfile C
8a50: 6f 6d 6d 65 6e 74 0a 09 09 09 28 76 65 63 74 6f omment....(vecto
8a60: 72 20 28 74 64 62 3a 73 74 65 70 2d 67 65 74 2d r (tdb:step-get-
8a70: 73 74 65 70 6e 61 6d 65 20 73 74 65 70 29 20 22 stepname step) "
8a80: 22 20 20 20 22 22 20 22 22 20 20 20 20 20 22 22 " "" "" ""
8a90: 20 20 20 20 20 20 20 20 22 22 20 20 20 20 20 22 "" "
8aa0: 22 29 29 29 29 0a 09 20 20 20 28 64 65 62 75 67 ")))).. (debug
8ab0: 3a 70 72 69 6e 74 20 36 20 2a 64 65 66 61 75 6c :print 6 *defaul
8ac0: 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 72 65 63 t-log-port* "rec
8ad0: 6f 72 64 28 62 65 66 6f 72 65 29 20 3d 20 22 20 ord(before) = "
8ae0: 72 65 63 6f 72 64 20 0a 09 09 09 22 5c 6e 69 64 record ...."\nid
8af0: 3a 20 20 20 20 20 20 20 22 20 28 74 64 62 3a 73 : " (tdb:s
8b00: 74 65 70 2d 67 65 74 2d 69 64 20 73 74 65 70 29 tep-get-id step)
8b10: 0a 09 09 09 22 5c 6e 73 74 65 70 6e 61 6d 65 3a ...."\nstepname:
8b20: 20 22 20 28 74 64 62 3a 73 74 65 70 2d 67 65 74 " (tdb:step-get
8b30: 2d 73 74 65 70 6e 61 6d 65 20 73 74 65 70 29 0a -stepname step).
8b40: 09 09 09 22 5c 6e 73 74 61 74 65 3a 20 20 20 20 ..."\nstate:
8b50: 22 20 28 74 64 62 3a 73 74 65 70 2d 67 65 74 2d " (tdb:step-get-
8b60: 73 74 61 74 65 20 73 74 65 70 29 0a 09 09 09 22 state step)...."
8b70: 5c 6e 73 74 61 74 75 73 3a 20 20 20 22 20 28 74 \nstatus: " (t
8b80: 64 62 3a 73 74 65 70 2d 67 65 74 2d 73 74 61 74 db:step-get-stat
8b90: 75 73 20 73 74 65 70 29 0a 09 09 09 22 5c 6e 74 us step)...."\nt
8ba0: 69 6d 65 3a 20 20 20 20 20 22 20 28 74 64 62 3a ime: " (tdb:
8bb0: 73 74 65 70 2d 67 65 74 2d 65 76 65 6e 74 5f 74 step-get-event_t
8bc0: 69 6d 65 20 73 74 65 70 29 29 0a 09 20 20 20 28 ime step)).. (
8bd0: 63 61 73 65 20 28 73 74 72 69 6e 67 2d 3e 73 79 case (string->sy
8be0: 6d 62 6f 6c 20 28 74 64 62 3a 73 74 65 70 2d 67 mbol (tdb:step-g
8bf0: 65 74 2d 73 74 61 74 65 20 73 74 65 70 29 29 0a et-state step)).
8c00: 09 20 20 20 20 20 28 28 73 74 61 72 74 29 28 76 . ((start)(v
8c10: 65 63 74 6f 72 2d 73 65 74 21 20 72 65 63 6f 72 ector-set! recor
8c20: 64 20 31 20 28 74 64 62 3a 73 74 65 70 2d 67 65 d 1 (tdb:step-ge
8c30: 74 2d 65 76 65 6e 74 5f 74 69 6d 65 20 73 74 65 t-event_time ste
8c40: 70 29 29 0a 09 20 20 20 20 20 20 28 76 65 63 74 p)).. (vect
8c50: 6f 72 2d 73 65 74 21 20 72 65 63 6f 72 64 20 33 or-set! record 3
8c60: 20 28 69 66 20 28 65 71 75 61 6c 3f 20 28 76 65 (if (equal? (ve
8c70: 63 74 6f 72 2d 72 65 66 20 72 65 63 6f 72 64 20 ctor-ref record
8c80: 33 29 20 22 22 29 0a 09 09 09 09 09 28 74 64 62 3) "")......(tdb
8c90: 3a 73 74 65 70 2d 67 65 74 2d 73 74 61 74 75 73 :step-get-status
8ca0: 20 73 74 65 70 29 29 29 0a 09 20 20 20 20 20 20 step)))..
8cb0: 28 69 66 20 28 3e 20 28 73 74 72 69 6e 67 2d 6c (if (> (string-l
8cc0: 65 6e 67 74 68 20 28 74 64 62 3a 73 74 65 70 2d ength (tdb:step-
8cd0: 67 65 74 2d 6c 6f 67 66 69 6c 65 20 73 74 65 70 get-logfile step
8ce0: 29 29 0a 09 09 20 20 20 20 20 30 29 0a 09 09 20 ))... 0)...
8cf0: 20 28 76 65 63 74 6f 72 2d 73 65 74 21 20 72 65 (vector-set! re
8d00: 63 6f 72 64 20 35 20 28 74 64 62 3a 73 74 65 70 cord 5 (tdb:step
8d10: 2d 67 65 74 2d 6c 6f 67 66 69 6c 65 20 73 74 65 -get-logfile ste
8d20: 70 29 29 29 29 0a 09 20 20 20 20 20 28 28 65 6e p)))).. ((en
8d30: 64 29 20 20 0a 09 20 20 20 20 20 20 28 76 65 63 d) .. (vec
8d40: 74 6f 72 2d 73 65 74 21 20 72 65 63 6f 72 64 20 tor-set! record
8d50: 32 20 28 61 6e 79 2d 3e 6e 75 6d 62 65 72 20 28 2 (any->number (
8d60: 74 64 62 3a 73 74 65 70 2d 67 65 74 2d 65 76 65 tdb:step-get-eve
8d70: 6e 74 5f 74 69 6d 65 20 73 74 65 70 29 29 29 0a nt_time step))).
8d80: 09 20 20 20 20 20 20 28 76 65 63 74 6f 72 2d 73 . (vector-s
8d90: 65 74 21 20 72 65 63 6f 72 64 20 33 20 28 74 64 et! record 3 (td
8da0: 62 3a 73 74 65 70 2d 67 65 74 2d 73 74 61 74 75 b:step-get-statu
8db0: 73 20 73 74 65 70 29 29 0a 09 20 20 20 20 20 20 s step))..
8dc0: 28 76 65 63 74 6f 72 2d 73 65 74 21 20 72 65 63 (vector-set! rec
8dd0: 6f 72 64 20 34 20 28 6c 65 74 20 28 28 73 74 61 ord 4 (let ((sta
8de0: 72 74 74 20 28 61 6e 79 2d 3e 6e 75 6d 62 65 72 rtt (any->number
8df0: 20 28 76 65 63 74 6f 72 2d 72 65 66 20 72 65 63 (vector-ref rec
8e00: 6f 72 64 20 31 29 29 29 0a 09 09 09 09 09 20 20 ord 1)))......
8e10: 28 65 6e 64 74 20 20 20 28 61 6e 79 2d 3e 6e 75 (endt (any->nu
8e20: 6d 62 65 72 20 28 76 65 63 74 6f 72 2d 72 65 66 mber (vector-ref
8e30: 20 72 65 63 6f 72 64 20 32 29 29 29 29 0a 09 09 record 2))))...
8e40: 09 09 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 .. (debug:p
8e50: 72 69 6e 74 20 34 20 2a 64 65 66 61 75 6c 74 2d rint 4 *default-
8e60: 6c 6f 67 2d 70 6f 72 74 2a 20 22 72 65 63 6f 72 log-port* "recor
8e70: 64 5b 31 5d 3d 22 20 28 76 65 63 74 6f 72 2d 72 d[1]=" (vector-r
8e80: 65 66 20 72 65 63 6f 72 64 20 31 29 20 0a 09 09 ef record 1) ...
8e90: 09 09 09 09 20 20 20 22 2c 20 73 74 61 72 74 74 .... ", startt
8ea0: 3d 22 20 73 74 61 72 74 74 20 22 2c 20 65 6e 64 =" startt ", end
8eb0: 74 3d 22 20 65 6e 64 74 0a 09 09 09 09 09 09 20 t=" endt.......
8ec0: 20 20 22 2c 20 67 65 74 2d 73 74 61 74 75 73 3a ", get-status:
8ed0: 20 22 20 28 74 64 62 3a 73 74 65 70 2d 67 65 74 " (tdb:step-get
8ee0: 2d 73 74 61 74 75 73 20 73 74 65 70 29 29 0a 09 -status step))..
8ef0: 09 09 09 20 20 20 20 20 20 28 69 66 20 28 61 6e ... (if (an
8f00: 64 20 28 6e 75 6d 62 65 72 3f 20 73 74 61 72 74 d (number? start
8f10: 74 29 28 6e 75 6d 62 65 72 3f 20 65 6e 64 74 29 t)(number? endt)
8f20: 29 0a 09 09 09 09 09 20 20 28 73 65 63 6f 6e 64 )...... (second
8f30: 73 2d 3e 68 72 2d 6d 69 6e 2d 73 65 63 20 28 2d s->hr-min-sec (-
8f40: 20 65 6e 64 74 20 73 74 61 72 74 74 29 29 20 22 endt startt)) "
8f50: 2d 31 22 29 29 29 0a 09 20 20 20 20 20 20 28 69 -1"))).. (i
8f60: 66 20 28 3e 20 28 73 74 72 69 6e 67 2d 6c 65 6e f (> (string-len
8f70: 67 74 68 20 28 74 64 62 3a 73 74 65 70 2d 67 65 gth (tdb:step-ge
8f80: 74 2d 6c 6f 67 66 69 6c 65 20 73 74 65 70 29 29 t-logfile step))
8f90: 0a 09 09 20 20 20 20 20 30 29 0a 09 09 20 20 28 ... 0)... (
8fa0: 76 65 63 74 6f 72 2d 73 65 74 21 20 72 65 63 6f vector-set! reco
8fb0: 72 64 20 35 20 28 74 64 62 3a 73 74 65 70 2d 67 rd 5 (tdb:step-g
8fc0: 65 74 2d 6c 6f 67 66 69 6c 65 20 73 74 65 70 29 et-logfile step)
8fd0: 29 29 0a 09 20 20 20 20 20 20 28 69 66 20 28 3e )).. (if (>
8fe0: 20 28 73 74 72 69 6e 67 2d 6c 65 6e 67 74 68 20 (string-length
8ff0: 28 74 64 62 3a 73 74 65 70 2d 67 65 74 2d 63 6f (tdb:step-get-co
9000: 6d 6d 65 6e 74 20 73 74 65 70 29 29 0a 09 09 20 mment step))...
9010: 20 20 20 20 30 29 0a 09 09 20 20 28 76 65 63 74 0)... (vect
9020: 6f 72 2d 73 65 74 21 20 72 65 63 6f 72 64 20 36 or-set! record 6
9030: 20 28 74 64 62 3a 73 74 65 70 2d 67 65 74 2d 63 (tdb:step-get-c
9040: 6f 6d 6d 65 6e 74 20 73 74 65 70 29 29 29 29 0a omment step)))).
9050: 09 20 20 20 20 20 28 65 6c 73 65 0a 09 20 20 20 . (else..
9060: 20 20 20 28 76 65 63 74 6f 72 2d 73 65 74 21 20 (vector-set!
9070: 72 65 63 6f 72 64 20 32 20 28 74 64 62 3a 73 74 record 2 (tdb:st
9080: 65 70 2d 67 65 74 2d 73 74 61 74 65 20 73 74 65 ep-get-state ste
9090: 70 29 29 0a 09 20 20 20 20 20 20 28 76 65 63 74 p)).. (vect
90a0: 6f 72 2d 73 65 74 21 20 72 65 63 6f 72 64 20 33 or-set! record 3
90b0: 20 28 74 64 62 3a 73 74 65 70 2d 67 65 74 2d 73 (tdb:step-get-s
90c0: 74 61 74 75 73 20 73 74 65 70 29 29 0a 09 20 20 tatus step))..
90d0: 20 20 20 20 28 76 65 63 74 6f 72 2d 73 65 74 21 (vector-set!
90e0: 20 72 65 63 6f 72 64 20 34 20 28 74 64 62 3a 73 record 4 (tdb:s
90f0: 74 65 70 2d 67 65 74 2d 65 76 65 6e 74 5f 74 69 tep-get-event_ti
9100: 6d 65 20 73 74 65 70 29 29 0a 09 20 20 20 20 20 me step))..
9110: 20 28 76 65 63 74 6f 72 2d 73 65 74 21 20 72 65 (vector-set! re
9120: 63 6f 72 64 20 36 20 28 74 64 62 3a 73 74 65 70 cord 6 (tdb:step
9130: 2d 67 65 74 2d 63 6f 6d 6d 65 6e 74 20 73 74 65 -get-comment ste
9140: 70 29 29 29 29 0a 09 20 20 20 28 68 61 73 68 2d p)))).. (hash-
9150: 74 61 62 6c 65 2d 73 65 74 21 20 72 65 73 20 28 table-set! res (
9160: 74 64 62 3a 73 74 65 70 2d 67 65 74 2d 73 74 65 tdb:step-get-ste
9170: 70 6e 61 6d 65 20 73 74 65 70 29 20 72 65 63 6f pname step) reco
9180: 72 64 29 0a 09 20 20 20 28 64 65 62 75 67 3a 70 rd).. (debug:p
9190: 72 69 6e 74 20 36 20 2a 64 65 66 61 75 6c 74 2d rint 6 *default-
91a0: 6c 6f 67 2d 70 6f 72 74 2a 20 22 72 65 63 6f 72 log-port* "recor
91b0: 64 28 61 66 74 65 72 29 20 20 3d 20 22 20 72 65 d(after) = " re
91c0: 63 6f 72 64 20 0a 09 09 09 22 5c 6e 69 64 3a 20 cord ...."\nid:
91d0: 20 20 20 20 20 20 22 20 28 74 64 62 3a 73 74 65 " (tdb:ste
91e0: 70 2d 67 65 74 2d 69 64 20 73 74 65 70 29 0a 09 p-get-id step)..
91f0: 09 09 22 5c 6e 73 74 65 70 6e 61 6d 65 3a 20 22 .."\nstepname: "
9200: 20 28 74 64 62 3a 73 74 65 70 2d 67 65 74 2d 73 (tdb:step-get-s
9210: 74 65 70 6e 61 6d 65 20 73 74 65 70 29 0a 09 09 tepname step)...
9220: 09 22 5c 6e 73 74 61 74 65 3a 20 20 20 20 22 20 ."\nstate: "
9230: 28 74 64 62 3a 73 74 65 70 2d 67 65 74 2d 73 74 (tdb:step-get-st
9240: 61 74 65 20 73 74 65 70 29 0a 09 09 09 22 5c 6e ate step)...."\n
9250: 73 74 61 74 75 73 3a 20 20 20 22 20 28 74 64 62 status: " (tdb
9260: 3a 73 74 65 70 2d 67 65 74 2d 73 74 61 74 75 73 :step-get-status
9270: 20 73 74 65 70 29 0a 09 09 09 22 5c 6e 74 69 6d step)...."\ntim
9280: 65 3a 20 20 20 20 20 22 20 28 74 64 62 3a 73 74 e: " (tdb:st
9290: 65 70 2d 67 65 74 2d 65 76 65 6e 74 5f 74 69 6d ep-get-event_tim
92a0: 65 20 73 74 65 70 29 29 29 29 0a 20 20 20 20 20 e step)))).
92b0: 20 20 3b 3b 20 28 65 6c 73 65 20 20 20 28 76 65 ;; (else (ve
92c0: 63 74 6f 72 2d 73 65 74 21 20 72 65 63 6f 72 64 ctor-set! record
92d0: 20 31 20 28 74 64 62 3a 73 74 65 70 2d 67 65 74 1 (tdb:step-get
92e0: 2d 65 76 65 6e 74 5f 74 69 6d 65 20 73 74 65 70 -event_time step
92f0: 29 29 29 0a 20 20 20 20 20 20 20 28 73 6f 72 74 ))). (sort
9300: 20 73 74 65 70 73 20 28 6c 61 6d 62 64 61 20 28 steps (lambda (
9310: 61 20 62 29 0a 09 09 20 20 20 20 20 28 63 6f 6e a b)... (con
9320: 64 0a 09 09 20 20 20 20 20 20 28 28 3c 20 20 20 d... ((<
9330: 28 74 64 62 3a 73 74 65 70 2d 67 65 74 2d 65 76 (tdb:step-get-ev
9340: 65 6e 74 5f 74 69 6d 65 20 61 29 28 74 64 62 3a ent_time a)(tdb:
9350: 73 74 65 70 2d 67 65 74 2d 65 76 65 6e 74 5f 74 step-get-event_t
9360: 69 6d 65 20 62 29 29 20 23 74 29 0a 09 09 20 20 ime b)) #t)...
9370: 20 20 20 20 28 28 65 71 3f 20 28 74 64 62 3a 73 ((eq? (tdb:s
9380: 74 65 70 2d 67 65 74 2d 65 76 65 6e 74 5f 74 69 tep-get-event_ti
9390: 6d 65 20 61 29 28 74 64 62 3a 73 74 65 70 2d 67 me a)(tdb:step-g
93a0: 65 74 2d 65 76 65 6e 74 5f 74 69 6d 65 20 62 29 et-event_time b)
93b0: 29 20 0a 09 09 20 20 20 20 20 20 20 28 3c 20 20 ) ... (<
93c0: 20 28 74 64 62 3a 73 74 65 70 2d 67 65 74 2d 69 (tdb:step-get-i
93d0: 64 20 61 29 20 20 20 20 20 20 20 20 28 74 64 62 d a) (tdb
93e0: 3a 73 74 65 70 2d 67 65 74 2d 69 64 20 62 29 29 :step-get-id b))
93f0: 29 0a 09 09 20 20 20 20 20 20 28 65 6c 73 65 20 )... (else
9400: 23 66 29 29 29 29 29 0a 20 20 20 20 20 20 72 65 #f))))). re
9410: 73 29 29 0a 0a 3b 3b 20 0a 3b 3b 0a 28 64 65 66 s))..;; .;;.(def
9420: 69 6e 65 20 28 74 65 73 74 73 3a 67 65 74 2d 63 ine (tests:get-c
9430: 6f 6d 70 72 65 73 73 65 64 2d 73 74 65 70 73 20 ompressed-steps
9440: 72 75 6e 2d 69 64 20 74 65 73 74 2d 69 64 29 0a run-id test-id).
9450: 20 20 28 6c 65 74 2a 20 28 28 73 74 65 70 73 2d (let* ((steps-
9460: 64 61 74 61 20 20 28 72 6d 74 3a 67 65 74 2d 73 data (rmt:get-s
9470: 74 65 70 73 2d 66 6f 72 2d 74 65 73 74 20 72 75 teps-for-test ru
9480: 6e 2d 69 64 20 74 65 73 74 2d 69 64 29 29 0a 09 n-id test-id))..
9490: 20 28 63 6f 6d 70 72 73 74 65 70 73 20 20 28 74 (comprsteps (t
94a0: 65 73 74 73 3a 70 72 6f 63 65 73 73 2d 73 74 65 ests:process-ste
94b0: 70 73 2d 74 61 62 6c 65 20 73 74 65 70 73 2d 64 ps-table steps-d
94c0: 61 74 61 29 29 29 20 3b 3b 20 28 6f 70 65 6e 2d ata))) ;; (open-
94d0: 72 75 6e 2d 63 6c 6f 73 65 20 64 62 3a 67 65 74 run-close db:get
94e0: 2d 73 74 65 70 73 2d 74 61 62 6c 65 20 23 66 20 -steps-table #f
94f0: 74 65 73 74 2d 69 64 20 77 6f 72 6b 2d 61 72 65 test-id work-are
9500: 61 3a 20 77 6f 72 6b 2d 61 72 65 61 29 29 29 0a a: work-area))).
9510: 20 20 20 20 28 6d 61 70 20 28 6c 61 6d 62 64 61 (map (lambda
9520: 20 28 78 29 0a 09 20 20 20 3b 3b 20 74 61 6b 65 (x).. ;; take
9530: 20 61 64 76 61 6e 74 61 67 65 20 6f 66 20 74 68 advantage of th
9540: 65 20 5c 6e 20 6f 6e 20 74 69 6d 65 2d 3e 73 74 e \n on time->st
9550: 72 69 6e 67 0a 09 20 20 20 28 76 65 63 74 6f 72 ring.. (vector
9560: 0a 09 20 20 20 20 28 76 65 63 74 6f 72 2d 72 65 .. (vector-re
9570: 66 20 78 20 30 29 0a 09 20 20 20 20 28 6c 65 74 f x 0).. (let
9580: 20 28 28 73 20 28 76 65 63 74 6f 72 2d 72 65 66 ((s (vector-ref
9590: 20 78 20 31 29 29 29 0a 09 20 20 20 20 20 20 28 x 1))).. (
95a0: 69 66 20 28 6e 75 6d 62 65 72 3f 20 73 29 28 73 if (number? s)(s
95b0: 65 63 6f 6e 64 73 2d 3e 74 69 6d 65 2d 73 74 72 econds->time-str
95c0: 69 6e 67 20 73 29 20 73 29 29 0a 09 20 20 20 20 ing s) s))..
95d0: 28 6c 65 74 20 28 28 73 20 28 76 65 63 74 6f 72 (let ((s (vector
95e0: 2d 72 65 66 20 78 20 32 29 29 29 0a 09 20 20 20 -ref x 2)))..
95f0: 20 20 20 28 69 66 20 28 6e 75 6d 62 65 72 3f 20 (if (number?
9600: 73 29 28 73 65 63 6f 6e 64 73 2d 3e 74 69 6d 65 s)(seconds->time
9610: 2d 73 74 72 69 6e 67 20 73 29 20 73 29 29 0a 09 -string s) s))..
9620: 20 20 20 20 28 76 65 63 74 6f 72 2d 72 65 66 20 (vector-ref
9630: 78 20 33 29 20 20 20 20 3b 3b 20 73 74 61 74 75 x 3) ;; statu
9640: 73 0a 09 20 20 20 20 28 76 65 63 74 6f 72 2d 72 s.. (vector-r
9650: 65 66 20 78 20 34 29 0a 09 20 20 20 20 28 76 65 ef x 4).. (ve
9660: 63 74 6f 72 2d 72 65 66 20 78 20 35 29 20 20 3b ctor-ref x 5) ;
9670: 3b 20 74 69 6d 65 20 64 65 6c 74 61 0a 09 20 20 ; time delta..
9680: 20 20 28 76 65 63 74 6f 72 2d 72 65 66 20 78 20 (vector-ref x
9690: 36 29 29 29 0a 09 20 28 73 6f 72 74 20 28 68 61 6))).. (sort (ha
96a0: 73 68 2d 74 61 62 6c 65 2d 76 61 6c 75 65 73 20 sh-table-values
96b0: 63 6f 6d 70 72 73 74 65 70 73 29 0a 09 20 20 20 comprsteps)..
96c0: 20 20 20 20 28 6c 61 6d 62 64 61 20 28 61 20 62 (lambda (a b
96d0: 29 0a 09 09 20 28 6c 65 74 20 28 28 74 69 6d 65 )... (let ((time
96e0: 2d 61 20 28 76 65 63 74 6f 72 2d 72 65 66 20 61 -a (vector-ref a
96f0: 20 31 29 29 0a 09 09 20 20 20 20 20 20 20 28 74 1))... (t
9700: 69 6d 65 2d 62 20 28 76 65 63 74 6f 72 2d 72 65 ime-b (vector-re
9710: 66 20 62 20 31 29 29 29 0a 09 09 20 20 20 28 69 f b 1)))... (i
9720: 66 20 28 61 6e 64 20 28 6e 75 6d 62 65 72 3f 20 f (and (number?
9730: 74 69 6d 65 2d 61 29 28 6e 75 6d 62 65 72 3f 20 time-a)(number?
9740: 74 69 6d 65 2d 62 29 29 0a 09 09 20 20 20 20 20 time-b))...
9750: 20 20 28 69 66 20 28 3c 20 74 69 6d 65 2d 61 20 (if (< time-a
9760: 74 69 6d 65 2d 62 29 0a 09 09 09 20 20 20 23 74 time-b).... #t
9770: 0a 09 09 09 20 20 20 28 69 66 20 28 65 71 3f 20 .... (if (eq?
9780: 74 69 6d 65 2d 61 20 74 69 6d 65 2d 62 29 0a 09 time-a time-b)..
9790: 09 09 20 20 20 20 20 20 20 28 73 74 72 69 6e 67 .. (string
97a0: 3c 3f 20 28 63 6f 6e 63 20 28 76 65 63 74 6f 72 <? (conc (vector
97b0: 2d 72 65 66 20 61 20 32 29 29 0a 09 09 09 09 09 -ref a 2))......
97c0: 20 28 63 6f 6e 63 20 28 76 65 63 74 6f 72 2d 72 (conc (vector-r
97d0: 65 66 20 62 20 32 29 29 29 0a 09 09 09 20 20 20 ef b 2)))....
97e0: 20 20 20 20 23 66 29 29 0a 09 09 20 20 20 20 20 #f))...
97f0: 20 20 28 73 74 72 69 6e 67 3c 3f 20 28 63 6f 6e (string<? (con
9800: 63 20 74 69 6d 65 2d 61 29 28 63 6f 6e 63 20 74 c time-a)(conc t
9810: 69 6d 65 2d 62 29 29 29 29 29 29 29 29 29 0a 0a ime-b)))))))))..
9820: 0a 3b 3b 20 73 75 6d 6d 61 72 69 7a 65 20 74 65 .;; summarize te
9830: 73 74 20 69 6e 20 74 6f 20 61 20 66 69 6c 65 20 st in to a file
9840: 74 65 73 74 2d 73 75 6d 6d 61 72 79 2e 68 74 6d test-summary.htm
9850: 6c 20 69 6e 20 74 68 65 20 74 65 73 74 20 64 69 l in the test di
9860: 72 65 63 74 6f 72 79 0a 3b 3b 0a 28 64 65 66 69 rectory.;;.(defi
9870: 6e 65 20 28 74 65 73 74 73 3a 73 75 6d 6d 61 72 ne (tests:summar
9880: 69 7a 65 2d 74 65 73 74 20 72 75 6e 2d 69 64 20 ize-test run-id
9890: 74 65 73 74 2d 69 64 29 0a 20 20 28 6c 65 74 2a test-id). (let*
98a0: 20 28 28 74 65 73 74 2d 64 61 74 20 20 28 72 6d ((test-dat (rm
98b0: 74 3a 67 65 74 2d 74 65 73 74 2d 69 6e 66 6f 2d t:get-test-info-
98c0: 62 79 2d 69 64 20 72 75 6e 2d 69 64 20 74 65 73 by-id run-id tes
98d0: 74 2d 69 64 29 29 0a 09 20 28 73 74 65 70 73 2d t-id)).. (steps-
98e0: 64 61 74 20 28 72 6d 74 3a 67 65 74 2d 73 74 65 dat (rmt:get-ste
98f0: 70 73 2d 66 6f 72 2d 74 65 73 74 20 72 75 6e 2d ps-for-test run-
9900: 69 64 20 74 65 73 74 2d 69 64 29 29 0a 09 20 28 id test-id)).. (
9910: 74 65 73 74 2d 6e 61 6d 65 20 28 64 62 3a 74 65 test-name (db:te
9920: 73 74 2d 67 65 74 2d 74 65 73 74 6e 61 6d 65 20 st-get-testname
9930: 74 65 73 74 2d 64 61 74 29 29 0a 09 20 28 69 74 test-dat)).. (it
9940: 65 6d 2d 70 61 74 68 20 28 64 62 3a 74 65 73 74 em-path (db:test
9950: 2d 67 65 74 2d 69 74 65 6d 2d 70 61 74 68 20 74 -get-item-path t
9960: 65 73 74 2d 64 61 74 29 29 0a 09 20 28 66 75 6c est-dat)).. (ful
9970: 6c 2d 6e 61 6d 65 20 28 64 62 3a 74 65 73 74 2d l-name (db:test-
9980: 6d 61 6b 65 2d 66 75 6c 6c 2d 6e 61 6d 65 20 74 make-full-name t
9990: 65 73 74 2d 6e 61 6d 65 20 69 74 65 6d 2d 70 61 est-name item-pa
99a0: 74 68 29 29 0a 09 20 28 6f 75 70 20 20 20 20 20 th)).. (oup
99b0: 20 20 28 6f 70 65 6e 2d 6f 75 74 70 75 74 2d 66 (open-output-f
99c0: 69 6c 65 20 28 63 6f 6e 63 20 28 64 62 3a 74 65 ile (conc (db:te
99d0: 73 74 2d 67 65 74 2d 72 75 6e 64 69 72 20 74 65 st-get-rundir te
99e0: 73 74 2d 64 61 74 29 20 22 2f 74 65 73 74 2d 73 st-dat) "/test-s
99f0: 75 6d 6d 61 72 79 2e 68 74 6d 6c 22 29 29 29 0a ummary.html"))).
9a00: 09 20 28 73 74 61 74 75 73 20 20 20 20 28 64 62 . (status (db
9a10: 3a 74 65 73 74 2d 67 65 74 2d 73 74 61 74 75 73 :test-get-status
9a20: 20 20 20 74 65 73 74 2d 64 61 74 29 29 0a 09 20 test-dat))..
9a30: 28 63 6f 6c 6f 72 20 20 20 20 20 28 63 6f 6d 6d (color (comm
9a40: 6f 6e 3a 67 65 74 2d 63 6f 6c 6f 72 2d 66 72 6f on:get-color-fro
9a50: 6d 2d 73 74 61 74 75 73 20 73 74 61 74 75 73 29 m-status status)
9a60: 29 0a 09 20 28 6c 6f 67 66 20 20 20 20 20 20 28 ).. (logf (
9a70: 64 62 3a 74 65 73 74 2d 67 65 74 2d 66 69 6e 61 db:test-get-fina
9a80: 6c 5f 6c 6f 67 66 20 74 65 73 74 2d 64 61 74 29 l_logf test-dat)
9a90: 29 0a 09 20 28 73 74 65 70 73 2d 64 61 74 20 28 ).. (steps-dat (
9aa0: 74 65 73 74 73 3a 67 65 74 2d 63 6f 6d 70 72 65 tests:get-compre
9ab0: 73 73 65 64 2d 73 74 65 70 73 20 72 75 6e 2d 69 ssed-steps run-i
9ac0: 64 20 74 65 73 74 2d 69 64 29 29 29 0a 20 20 20 d test-id))).
9ad0: 20 3b 3b 20 28 64 63 6f 6d 6d 6f 6e 3a 67 65 74 ;; (dcommon:get
9ae0: 2d 63 6f 6d 70 72 65 73 73 65 64 2d 73 74 65 70 -compressed-step
9af0: 73 20 23 66 20 31 20 33 30 30 34 35 29 0a 20 20 s #f 1 30045).
9b00: 20 20 3b 3b 20 28 23 28 22 77 61 73 74 69 6e 67 ;; (#("wasting
9b10: 5f 74 69 6d 65 22 20 22 32 33 3a 33 36 3a 31 33 _time" "23:36:13
9b20: 22 20 22 32 33 3a 33 36 3a 32 31 22 20 22 30 22 " "23:36:21" "0"
9b30: 20 22 38 2e 30 73 22 20 22 77 61 73 74 69 6e 67 "8.0s" "wasting
9b40: 5f 74 69 6d 65 2e 6c 6f 67 22 29 29 0a 0a 20 20 _time.log"))..
9b50: 20 20 28 73 3a 6f 75 74 70 75 74 2d 6e 65 77 0a (s:output-new.
9b60: 20 20 20 20 20 6f 75 70 0a 20 20 20 20 20 28 73 oup. (s
9b70: 3a 68 74 6d 6c 0a 20 20 20 20 20 20 28 73 3a 74 :html. (s:t
9b80: 69 74 6c 65 20 22 53 75 6d 6d 61 72 79 20 66 6f itle "Summary fo
9b90: 72 20 22 20 66 75 6c 6c 2d 6e 61 6d 65 29 0a 20 r " full-name).
9ba0: 20 20 20 20 20 28 73 3a 62 6f 64 79 20 0a 20 20 (s:body .
9bb0: 20 20 20 20 20 28 73 3a 68 32 20 22 53 75 6d 6d (s:h2 "Summ
9bc0: 61 72 79 20 66 6f 72 20 22 20 66 75 6c 6c 2d 6e ary for " full-n
9bd0: 61 6d 65 29 0a 20 20 20 20 20 20 20 28 73 3a 74 ame). (s:t
9be0: 61 62 6c 65 20 27 63 65 6c 6c 73 70 61 63 69 6e able 'cellspacin
9bf0: 67 20 22 30 22 20 27 62 6f 72 64 65 72 20 22 31 g "0" 'border "1
9c00: 22 0a 09 28 73 3a 74 72 20 28 73 3a 74 64 20 22 "..(s:tr (s:td "
9c10: 72 75 6e 20 69 64 22 29 20 20 20 28 73 3a 74 64 run id") (s:td
9c20: 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 72 75 (db:test-get-ru
9c30: 6e 5f 69 64 20 20 20 74 65 73 74 2d 64 61 74 29 n_id test-dat)
9c40: 29 0a 09 20 20 20 20 20 20 28 73 3a 74 64 20 22 ).. (s:td "
9c50: 74 65 73 74 20 69 64 22 29 20 20 28 73 3a 74 64 test id") (s:td
9c60: 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 69 64 (db:test-get-id
9c70: 20 20 20 20 20 20 20 74 65 73 74 2d 64 61 74 29 test-dat)
9c80: 29 29 0a 09 28 73 3a 74 72 20 28 73 3a 74 64 20 ))..(s:tr (s:td
9c90: 22 74 65 73 74 6e 61 6d 65 22 29 20 28 73 3a 74 "testname") (s:t
9ca0: 64 20 74 65 73 74 2d 6e 61 6d 65 29 0a 09 20 20 d test-name)..
9cb0: 20 20 20 20 28 73 3a 74 64 20 22 69 74 65 6d 70 (s:td "itemp
9cc0: 61 74 68 22 29 20 28 73 3a 74 64 20 69 74 65 6d ath") (s:td item
9cd0: 2d 70 61 74 68 29 29 0a 09 28 73 3a 74 72 20 28 -path))..(s:tr (
9ce0: 73 3a 74 64 20 22 73 74 61 74 65 22 29 20 20 20 s:td "state")
9cf0: 20 28 73 3a 74 64 20 28 64 62 3a 74 65 73 74 2d (s:td (db:test-
9d00: 67 65 74 2d 73 74 61 74 65 20 20 20 20 74 65 73 get-state tes
9d10: 74 2d 64 61 74 29 29 0a 09 20 20 20 20 20 20 28 t-dat)).. (
9d20: 73 3a 74 64 20 22 73 74 61 74 75 73 22 29 20 20 s:td "status")
9d30: 20 28 73 3a 74 64 20 28 73 3a 61 20 27 68 72 65 (s:td (s:a 'hre
9d40: 66 20 6c 6f 67 66 20 28 73 3a 66 6f 6e 74 20 27 f logf (s:font '
9d50: 63 6f 6c 6f 72 20 63 6f 6c 6f 72 20 73 74 61 74 color color stat
9d60: 75 73 29 29 29 29 0a 09 28 73 3a 74 72 20 28 73 us))))..(s:tr (s
9d70: 3a 74 64 20 22 54 65 73 74 44 61 74 65 22 29 20 :td "TestDate")
9d80: 28 73 3a 74 64 20 28 73 65 63 6f 6e 64 73 2d 3e (s:td (seconds->
9d90: 77 6f 72 6b 2d 77 65 65 6b 2f 64 61 79 2d 74 69 work-week/day-ti
9da0: 6d 65 20 0a 09 09 09 09 20 20 20 20 20 20 20 28 me ..... (
9db0: 64 62 3a 74 65 73 74 2d 67 65 74 2d 65 76 65 6e db:test-get-even
9dc0: 74 5f 74 69 6d 65 20 74 65 73 74 2d 64 61 74 29 t_time test-dat)
9dd0: 29 29 0a 09 20 20 20 20 20 20 28 73 3a 74 64 20 )).. (s:td
9de0: 22 44 75 72 61 74 69 6f 6e 22 29 20 28 73 3a 74 "Duration") (s:t
9df0: 64 20 28 73 65 63 6f 6e 64 73 2d 3e 68 72 2d 6d d (seconds->hr-m
9e00: 69 6e 2d 73 65 63 20 28 64 62 3a 74 65 73 74 2d in-sec (db:test-
9e10: 67 65 74 2d 72 75 6e 5f 64 75 72 61 74 69 6f 6e get-run_duration
9e20: 20 74 65 73 74 2d 64 61 74 29 29 29 29 29 0a 20 test-dat))))).
9e30: 20 20 20 20 20 20 28 73 3a 68 33 20 22 4c 6f 67 (s:h3 "Log
9e40: 20 66 69 6c 65 73 22 29 0a 20 20 20 20 20 20 20 files").
9e50: 28 73 3a 74 61 62 6c 65 0a 09 27 63 65 6c 6c 73 (s:table..'cells
9e60: 70 61 63 69 6e 67 20 22 30 22 20 27 62 6f 72 64 pacing "0" 'bord
9e70: 65 72 20 22 31 22 0a 09 28 73 3a 74 72 20 28 73 er "1"..(s:tr (s
9e80: 3a 74 64 20 22 46 69 6e 61 6c 20 6c 6f 67 22 29 :td "Final log")
9e90: 28 73 3a 74 64 20 28 73 3a 61 20 27 68 72 65 66 (s:td (s:a 'href
9ea0: 20 6c 6f 67 66 20 6c 6f 67 66 29 29 29 29 0a 20 logf logf)))).
9eb0: 20 20 20 20 20 20 28 73 3a 74 61 62 6c 65 0a 09 (s:table..
9ec0: 27 63 65 6c 6c 73 70 61 63 69 6e 67 20 22 30 22 'cellspacing "0"
9ed0: 20 27 62 6f 72 64 65 72 20 22 31 22 0a 09 28 73 'border "1"..(s
9ee0: 3a 74 72 20 28 73 3a 74 64 20 22 53 74 65 70 20 :tr (s:td "Step
9ef0: 4e 61 6d 65 22 29 28 73 3a 74 64 20 22 53 74 61 Name")(s:td "Sta
9f00: 72 74 22 29 28 73 3a 74 64 20 22 45 6e 64 22 29 rt")(s:td "End")
9f10: 28 73 3a 74 64 20 22 53 74 61 74 75 73 22 29 28 (s:td "Status")(
9f20: 73 3a 74 64 20 22 44 75 72 61 74 69 6f 6e 22 29 s:td "Duration")
9f30: 28 73 3a 74 64 20 22 4c 6f 67 20 46 69 6c 65 22 (s:td "Log File"
9f40: 29 29 0a 09 28 6d 61 70 20 28 6c 61 6d 62 64 61 ))..(map (lambda
9f50: 20 28 73 74 65 70 2d 64 61 74 29 0a 09 20 20 20 (step-dat)..
9f60: 20 20 20 20 28 73 3a 74 72 20 28 73 3a 74 64 20 (s:tr (s:td
9f70: 28 74 64 62 3a 73 74 65 70 73 2d 74 61 62 6c 65 (tdb:steps-table
9f80: 2d 67 65 74 2d 73 74 65 70 6e 61 6d 65 20 73 74 -get-stepname st
9f90: 65 70 2d 64 61 74 29 29 0a 09 09 20 20 20 20 20 ep-dat))...
9fa0: 28 73 3a 74 64 20 28 74 64 62 3a 73 74 65 70 73 (s:td (tdb:steps
9fb0: 2d 74 61 62 6c 65 2d 67 65 74 2d 73 74 61 72 74 -table-get-start
9fc0: 20 20 20 20 73 74 65 70 2d 64 61 74 29 29 0a 09 step-dat))..
9fd0: 09 20 20 20 20 20 28 73 3a 74 64 20 28 74 64 62 . (s:td (tdb
9fe0: 3a 73 74 65 70 73 2d 74 61 62 6c 65 2d 67 65 74 :steps-table-get
9ff0: 2d 65 6e 64 20 20 20 20 20 20 73 74 65 70 2d 64 -end step-d
a000: 61 74 29 29 0a 09 09 20 20 20 20 20 28 73 3a 74 at))... (s:t
a010: 64 20 28 74 64 62 3a 73 74 65 70 73 2d 74 61 62 d (tdb:steps-tab
a020: 6c 65 2d 67 65 74 2d 73 74 61 74 75 73 20 20 20 le-get-status
a030: 73 74 65 70 2d 64 61 74 29 29 0a 09 09 20 20 20 step-dat))...
a040: 20 20 28 73 3a 74 64 20 28 74 64 62 3a 73 74 65 (s:td (tdb:ste
a050: 70 73 2d 74 61 62 6c 65 2d 67 65 74 2d 72 75 6e ps-table-get-run
a060: 74 69 6d 65 20 20 73 74 65 70 2d 64 61 74 29 29 time step-dat))
a070: 0a 09 09 20 20 20 20 20 28 73 3a 74 64 20 28 6c ... (s:td (l
a080: 65 74 20 28 28 73 74 65 70 2d 6c 6f 67 20 28 74 et ((step-log (t
a090: 64 62 3a 73 74 65 70 73 2d 74 61 62 6c 65 2d 67 db:steps-table-g
a0a0: 65 74 2d 6c 6f 67 2d 66 69 6c 65 20 73 74 65 70 et-log-file step
a0b0: 2d 64 61 74 29 29 29 0a 09 09 09 20 20 20 20 20 -dat)))....
a0c0: 28 73 3a 61 20 27 68 72 65 66 20 73 74 65 70 2d (s:a 'href step-
a0d0: 6c 6f 67 20 73 74 65 70 2d 6c 6f 67 29 29 29 29 log step-log))))
a0e0: 29 0a 09 20 20 20 20 20 73 74 65 70 73 2d 64 61 ).. steps-da
a0f0: 74 29 29 0a 09 29 29 29 0a 20 20 20 20 28 63 6c t))..))). (cl
a100: 6f 73 65 2d 6f 75 74 70 75 74 2d 70 6f 72 74 20 ose-output-port
a110: 6f 75 70 29 29 29 0a 09 20 20 0a 09 20 20 0a 3b oup))).. .. .;
a120: 3b 20 4d 55 53 54 20 42 45 20 43 41 4c 4c 45 44 ; MUST BE CALLED
a130: 20 6c 6f 63 61 6c 21 0a 3b 3b 0a 28 64 65 66 69 local!.;;.(defi
a140: 6e 65 20 28 74 65 73 74 73 3a 74 65 73 74 2d 67 ne (tests:test-g
a150: 65 74 2d 70 61 74 68 73 2d 6d 61 74 63 68 69 6e et-paths-matchin
a160: 67 20 6b 65 79 6e 61 6d 65 73 20 74 61 72 67 65 g keynames targe
a170: 74 20 66 6e 61 6d 65 70 61 74 74 20 23 21 6b 65 t fnamepatt #!ke
a180: 79 20 28 72 65 73 20 27 28 29 29 29 0a 20 20 3b y (res '())). ;
a190: 3b 20 42 55 47 3a 20 4d 6f 76 65 20 74 68 65 20 ; BUG: Move the
a1a0: 76 61 6c 75 65 73 20 64 65 72 69 76 65 64 20 66 values derived f
a1b0: 72 6f 6d 20 61 72 67 73 20 74 6f 20 70 61 72 61 rom args to para
a1c0: 6d 65 74 65 72 73 20 61 6e 64 20 70 75 73 68 20 meters and push
a1d0: 74 6f 20 6d 65 67 61 74 65 73 74 2e 73 63 6d 0a to megatest.scm.
a1e0: 20 20 28 6c 65 74 2a 20 28 28 74 65 73 74 70 61 (let* ((testpa
a1f0: 74 74 20 20 20 28 69 66 20 28 61 72 67 73 3a 67 tt (if (args:g
a200: 65 74 2d 61 72 67 20 22 2d 74 65 73 74 70 61 74 et-arg "-testpat
a210: 74 22 29 28 61 72 67 73 3a 67 65 74 2d 61 72 67 t")(args:get-arg
a220: 20 22 2d 74 65 73 74 70 61 74 74 22 29 20 22 25 "-testpatt") "%
a230: 22 29 29 0a 09 20 28 73 74 61 74 65 70 61 74 74 ")).. (statepatt
a240: 20 20 28 69 66 20 28 61 72 67 73 3a 67 65 74 2d (if (args:get-
a250: 61 72 67 20 22 3a 73 74 61 74 65 22 29 20 20 20 arg ":state")
a260: 28 61 72 67 73 3a 67 65 74 2d 61 72 67 20 22 3a (args:get-arg ":
a270: 73 74 61 74 65 22 29 20 20 20 20 22 25 22 29 29 state") "%"))
a280: 0a 09 20 28 73 74 61 74 75 73 70 61 74 74 20 28 .. (statuspatt (
a290: 69 66 20 28 61 72 67 73 3a 67 65 74 2d 61 72 67 if (args:get-arg
a2a0: 20 22 3a 73 74 61 74 75 73 22 29 20 20 28 61 72 ":status") (ar
a2b0: 67 73 3a 67 65 74 2d 61 72 67 20 22 3a 73 74 61 gs:get-arg ":sta
a2c0: 74 75 73 22 29 20 20 20 22 25 22 29 29 0a 09 20 tus") "%"))..
a2d0: 28 72 75 6e 6e 61 6d 65 20 20 20 20 28 69 66 20 (runname (if
a2e0: 28 61 72 67 73 3a 67 65 74 2d 61 72 67 20 22 3a (args:get-arg ":
a2f0: 72 75 6e 6e 61 6d 65 22 29 20 28 61 72 67 73 3a runname") (args:
a300: 67 65 74 2d 61 72 67 20 22 3a 72 75 6e 6e 61 6d get-arg ":runnam
a310: 65 22 29 20 20 22 25 22 29 29 0a 09 20 28 70 61 e") "%")).. (pa
a320: 74 68 73 2d 66 72 6f 6d 2d 64 62 20 28 72 6d 74 ths-from-db (rmt
a330: 3a 74 65 73 74 2d 67 65 74 2d 70 61 74 68 73 2d :test-get-paths-
a340: 6d 61 74 63 68 69 6e 67 2d 6b 65 79 6e 61 6d 65 matching-keyname
a350: 73 2d 74 61 72 67 65 74 2d 6e 65 77 20 6b 65 79 s-target-new key
a360: 6e 61 6d 65 73 20 74 61 72 67 65 74 20 72 65 73 names target res
a370: 0a 09 09 09 09 09 74 65 73 74 70 61 74 74 0a 09 ......testpatt..
a380: 09 09 09 09 73 74 61 74 65 70 61 74 74 0a 09 09 ....statepatt...
a390: 09 09 09 73 74 61 74 75 73 70 61 74 74 0a 09 09 ...statuspatt...
a3a0: 09 09 09 72 75 6e 6e 61 6d 65 29 29 29 0a 20 20 ...runname))).
a3b0: 20 20 28 69 66 20 66 6e 61 6d 65 70 61 74 74 0a (if fnamepatt.
a3c0: 09 28 61 70 70 6c 79 20 61 70 70 65 6e 64 20 0a .(apply append .
a3d0: 09 20 20 20 20 20 20 20 28 6d 61 70 20 28 6c 61 . (map (la
a3e0: 6d 62 64 61 20 28 70 29 0a 09 09 20 20 20 20 20 mbda (p)...
a3f0: 20 28 69 66 20 28 64 69 72 65 63 74 6f 72 79 2d (if (directory-
a400: 65 78 69 73 74 73 3f 20 70 29 0a 09 09 09 20 20 exists? p)....
a410: 28 67 6c 6f 62 20 28 63 6f 6e 63 20 70 20 22 2f (glob (conc p "/
a420: 22 20 66 6e 61 6d 65 70 61 74 74 29 29 0a 09 09 " fnamepatt))...
a430: 09 20 20 27 28 29 29 29 0a 09 09 20 20 20 20 70 . '()))... p
a440: 61 74 68 73 2d 66 72 6f 6d 2d 64 62 29 29 0a 09 aths-from-db))..
a450: 70 61 74 68 73 2d 66 72 6f 6d 2d 64 62 29 29 29 paths-from-db)))
a460: 0a 0a 09 09 09 20 20 20 20 20 20 0a 3b 3b 3d 3d ..... .;;==
a470: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
a480: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
a490: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
a4a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
a4b0: 3d 3d 3d 3d 0a 3b 3b 20 47 61 74 68 65 72 20 64 ====.;; Gather d
a4c0: 61 74 61 20 66 72 6f 6d 20 74 65 73 74 2f 74 61 ata from test/ta
a4d0: 73 6b 20 73 70 65 63 69 66 69 63 61 74 69 6f 6e sk specification
a4e0: 73 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d s.;;============
a4f0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
a500: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
a510: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
a520: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 3b 3b 20 28 ==========..;; (
a530: 64 65 66 69 6e 65 20 28 74 65 73 74 73 3a 67 65 define (tests:ge
a540: 74 2d 76 61 6c 69 64 2d 74 65 73 74 73 20 74 65 t-valid-tests te
a550: 73 74 73 64 69 72 20 74 65 73 74 2d 70 61 74 74 stsdir test-patt
a560: 73 29 20 3b 3b 20 20 23 21 6b 65 79 20 28 74 65 s) ;; #!key (te
a570: 73 74 2d 6e 61 6d 65 73 20 27 28 29 29 29 0a 3b st-names '())).;
a580: 3b 20 20 20 28 6c 65 74 20 28 28 74 65 73 74 73 ; (let ((tests
a590: 20 28 67 6c 6f 62 20 28 63 6f 6e 63 20 74 65 73 (glob (conc tes
a5a0: 74 73 64 69 72 20 22 2f 74 65 73 74 73 2f 2a 22 tsdir "/tests/*"
a5b0: 29 29 29 29 20 3b 3b 20 22 20 28 73 74 72 69 6e )))) ;; " (strin
a5c0: 67 2d 74 72 61 6e 73 6c 61 74 65 20 70 61 74 74 g-translate patt
a5d0: 20 22 25 22 20 22 2a 22 29 29 29 29 29 0a 3b 3b "%" "*"))))).;;
a5e0: 20 20 20 20 20 28 73 65 74 21 20 74 65 73 74 73 (set! tests
a5f0: 20 28 66 69 6c 74 65 72 20 28 6c 61 6d 62 64 61 (filter (lambda
a600: 20 28 74 65 73 74 29 28 66 69 6c 65 2d 65 78 69 (test)(file-exi
a610: 73 74 73 3f 20 28 63 6f 6e 63 20 74 65 73 74 20 sts? (conc test
a620: 22 2f 74 65 73 74 63 6f 6e 66 69 67 22 29 29 29 "/testconfig")))
a630: 20 74 65 73 74 73 29 29 0a 3b 3b 20 20 20 20 20 tests)).;;
a640: 28 64 65 6c 65 74 65 2d 64 75 70 6c 69 63 61 74 (delete-duplicat
a650: 65 73 0a 3b 3b 20 20 20 20 20 20 28 66 69 6c 74 es.;; (filt
a660: 65 72 20 28 6c 61 6d 62 64 61 20 28 74 65 73 74 er (lambda (test
a670: 6e 61 6d 65 29 0a 3b 3b 20 09 20 20 20 20 20 20 name).;; .
a680: 20 28 74 65 73 74 73 3a 6d 61 74 63 68 20 74 65 (tests:match te
a690: 73 74 2d 70 61 74 74 73 20 74 65 73 74 6e 61 6d st-patts testnam
a6a0: 65 20 23 66 29 29 0a 3b 3b 20 09 20 20 20 20 20 e #f)).;; .
a6b0: 28 6d 61 70 20 28 6c 61 6d 62 64 61 20 28 74 65 (map (lambda (te
a6c0: 73 74 70 29 0a 3b 3b 20 09 09 20 20 20 20 28 6c stp).;; .. (l
a6d0: 61 73 74 20 28 73 74 72 69 6e 67 2d 73 70 6c 69 ast (string-spli
a6e0: 74 20 74 65 73 74 70 20 22 2f 22 29 29 29 0a 3b t testp "/"))).;
a6f0: 3b 20 09 09 20 20 74 65 73 74 73 29 29 29 29 29 ; .. tests)))))
a700: 0a 0a 28 64 65 66 69 6e 65 20 28 74 65 73 74 73 ..(define (tests
a710: 3a 67 65 74 2d 74 65 73 74 2d 70 61 74 68 2d 66 :get-test-path-f
a720: 72 6f 6d 2d 65 6e 76 69 72 6f 6e 6d 65 6e 74 29 rom-environment)
a730: 0a 20 20 28 69 66 20 28 61 6e 64 20 28 67 65 74 . (if (and (get
a740: 65 6e 76 20 22 4d 54 5f 4c 49 4e 4b 54 52 45 45 env "MT_LINKTREE
a750: 22 29 0a 09 20 20 20 28 67 65 74 65 6e 76 20 22 ").. (getenv "
a760: 4d 54 5f 54 41 52 47 45 54 22 29 0a 09 20 20 20 MT_TARGET")..
a770: 28 67 65 74 65 6e 76 20 22 4d 54 5f 52 55 4e 4e (getenv "MT_RUNN
a780: 41 4d 45 22 29 0a 09 20 20 20 28 67 65 74 65 6e AME").. (geten
a790: 76 20 22 4d 54 5f 54 45 53 54 5f 4e 41 4d 45 22 v "MT_TEST_NAME"
a7a0: 29 0a 09 20 20 20 28 67 65 74 65 6e 76 20 22 4d ).. (getenv "M
a7b0: 54 5f 49 54 45 4d 50 41 54 48 22 29 29 0a 20 20 T_ITEMPATH")).
a7c0: 20 20 20 20 28 63 6f 6e 63 20 28 67 65 74 65 6e (conc (geten
a7d0: 76 20 22 4d 54 5f 4c 49 4e 4b 54 52 45 45 22 29 v "MT_LINKTREE")
a7e0: 20 20 22 2f 22 0a 09 20 20 20 20 28 67 65 74 65 "/".. (gete
a7f0: 6e 76 20 22 4d 54 5f 54 41 52 47 45 54 22 29 20 nv "MT_TARGET")
a800: 20 20 20 22 2f 22 0a 09 20 20 20 20 28 67 65 74 "/".. (get
a810: 65 6e 76 20 22 4d 54 5f 52 55 4e 4e 41 4d 45 22 env "MT_RUNNAME"
a820: 29 20 20 20 22 2f 22 0a 09 20 20 20 20 28 67 65 ) "/".. (ge
a830: 74 65 6e 76 20 22 4d 54 5f 54 45 53 54 5f 4e 41 tenv "MT_TEST_NA
a840: 4d 45 22 29 20 22 2f 22 0a 09 20 20 20 20 28 69 ME") "/".. (i
a850: 66 20 28 6f 72 20 28 67 65 74 65 6e 76 20 22 4d f (or (getenv "M
a860: 54 5f 49 54 45 4d 50 41 54 48 22 29 0a 09 09 20 T_ITEMPATH")...
a870: 20 20 20 28 6e 6f 74 20 28 73 74 72 69 6e 67 3d (not (string=
a880: 3f 20 22 22 20 28 67 65 74 65 6e 76 20 22 4d 54 ? "" (getenv "MT
a890: 5f 49 54 45 4d 50 41 54 48 22 29 29 29 29 0a 09 _ITEMPATH"))))..
a8a0: 09 28 63 6f 6e 63 20 22 2f 22 20 28 67 65 74 65 .(conc "/" (gete
a8b0: 6e 76 20 22 4d 54 5f 49 54 45 4d 50 41 54 48 22 nv "MT_ITEMPATH"
a8c0: 29 29 29 29 0a 20 20 20 20 20 20 23 66 29 29 0a )))). #f)).
a8d0: 0a 3b 3b 20 69 66 20 2e 74 65 73 74 63 6f 6e 66 .;; if .testconf
a8e0: 69 67 20 65 78 69 73 74 73 20 69 6e 20 74 65 73 ig exists in tes
a8f0: 74 20 64 69 72 65 63 74 6f 72 79 20 72 65 61 64 t directory read
a900: 20 61 6e 64 20 72 65 74 75 72 6e 20 69 74 0a 3b and return it.;
a910: 3b 20 65 6c 73 65 20 69 66 20 68 61 76 65 20 63 ; else if have c
a920: 61 63 68 65 64 20 63 6f 70 79 20 69 6e 20 2a 74 ached copy in *t
a930: 65 73 74 63 6f 6e 66 69 67 73 2a 20 72 65 74 75 estconfigs* retu
a940: 72 6e 20 69 74 20 49 46 46 20 74 68 65 72 65 20 rn it IFF there
a950: 69 73 20 61 20 73 65 63 74 69 6f 6e 20 22 68 61 is a section "ha
a960: 76 65 20 66 75 6c 6c 64 61 74 61 22 0a 3b 3b 20 ve fulldata".;;
a970: 65 6c 73 65 20 72 65 61 64 20 74 68 65 20 74 65 else read the te
a980: 73 74 63 6f 6e 66 69 67 20 66 69 6c 65 0a 3b 3b stconfig file.;;
a990: 20 20 20 69 66 20 68 61 76 65 20 70 61 74 68 20 if have path
a9a0: 74 6f 20 74 65 73 74 20 64 69 72 65 63 74 6f 72 to test director
a9b0: 79 20 73 61 76 65 20 74 68 65 20 63 6f 6e 66 69 y save the confi
a9c0: 67 20 61 73 20 2e 74 65 73 74 63 6f 6e 66 69 67 g as .testconfig
a9d0: 20 61 6e 64 20 72 65 74 75 72 6e 20 69 74 0a 3b and return it.;
a9e0: 3b 0a 28 64 65 66 69 6e 65 20 28 74 65 73 74 73 ;.(define (tests
a9f0: 3a 67 65 74 2d 74 65 73 74 63 6f 6e 66 69 67 20 :get-testconfig
aa00: 74 65 73 74 2d 6e 61 6d 65 20 74 65 73 74 2d 72 test-name test-r
aa10: 65 67 69 73 74 72 79 20 73 79 73 74 65 6d 2d 61 egistry system-a
aa20: 6c 6c 6f 77 65 64 20 23 21 6b 65 79 20 28 66 6f llowed #!key (fo
aa30: 72 63 65 2d 63 72 65 61 74 65 20 23 66 29 29 0a rce-create #f)).
aa40: 20 20 28 6c 65 74 2a 20 28 28 63 61 63 68 65 2d (let* ((cache-
aa50: 70 61 74 68 20 20 20 28 74 65 73 74 73 3a 67 65 path (tests:ge
aa60: 74 2d 74 65 73 74 2d 70 61 74 68 2d 66 72 6f 6d t-test-path-from
aa70: 2d 65 6e 76 69 72 6f 6e 6d 65 6e 74 29 29 0a 09 -environment))..
aa80: 20 28 63 61 63 68 65 2d 66 69 6c 65 20 20 20 28 (cache-file (
aa90: 61 6e 64 20 63 61 63 68 65 2d 70 61 74 68 20 28 and cache-path (
aaa0: 63 6f 6e 63 20 63 61 63 68 65 2d 70 61 74 68 20 conc cache-path
aab0: 22 2f 2e 74 65 73 74 63 6f 6e 66 69 67 22 29 29 "/.testconfig"))
aac0: 29 0a 09 20 28 63 61 63 68 65 2d 65 78 69 73 74 ).. (cache-exist
aad0: 73 20 28 61 6e 64 20 63 61 63 68 65 2d 66 69 6c s (and cache-fil
aae0: 65 0a 09 09 09 20 20 20 20 28 6e 6f 74 20 66 6f e.... (not fo
aaf0: 72 63 65 2d 63 72 65 61 74 65 29 20 20 3b 3b 20 rce-create) ;;
ab00: 69 66 20 66 6f 72 63 65 2d 63 72 65 61 74 65 20 if force-create
ab10: 74 68 65 6e 20 70 72 65 74 65 6e 64 20 74 68 65 then pretend the
ab20: 72 65 20 69 73 20 6e 6f 20 63 61 63 68 65 20 74 re is no cache t
ab30: 6f 20 72 65 61 64 0a 09 09 09 20 20 20 20 28 66 o read.... (f
ab40: 69 6c 65 2d 65 78 69 73 74 73 3f 20 63 61 63 68 ile-exists? cach
ab50: 65 2d 66 69 6c 65 29 29 29 0a 09 20 28 63 61 63 e-file))).. (cac
ab60: 68 65 64 2d 64 61 74 20 20 20 28 69 66 20 28 61 hed-dat (if (a
ab70: 6e 64 20 28 6e 6f 74 20 66 6f 72 63 65 2d 63 72 nd (not force-cr
ab80: 65 61 74 65 29 0a 09 09 09 09 63 61 63 68 65 2d eate).....cache-
ab90: 65 78 69 73 74 73 29 0a 09 09 09 20 20 20 28 68 exists).... (h
aba0: 61 6e 64 6c 65 2d 65 78 63 65 70 74 69 6f 6e 73 andle-exceptions
abb0: 0a 09 09 09 20 20 20 20 65 78 6e 0a 09 09 09 20 .... exn....
abc0: 20 20 20 23 66 20 3b 3b 20 61 6e 79 20 69 73 73 #f ;; any iss
abd0: 75 65 73 2c 20 6a 75 73 74 20 67 69 76 65 20 75 ues, just give u
abe0: 70 20 77 69 74 68 20 74 68 65 20 63 61 63 68 65 p with the cache
abf0: 64 20 76 65 72 73 69 6f 6e 20 61 6e 64 20 72 65 d version and re
ac00: 2d 72 65 61 64 0a 09 09 09 20 20 20 20 28 63 6f -read.... (co
ac10: 6e 66 69 67 66 3a 72 65 61 64 2d 61 6c 69 73 74 nfigf:read-alist
ac20: 20 63 61 63 68 65 2d 66 69 6c 65 29 29 0a 09 09 cache-file))...
ac30: 09 20 20 20 23 66 29 29 29 0a 20 20 20 20 28 69 . #f))). (i
ac40: 66 20 63 61 63 68 65 64 2d 64 61 74 0a 09 63 61 f cached-dat..ca
ac50: 63 68 65 64 2d 64 61 74 0a 09 28 6c 65 74 20 28 ched-dat..(let (
ac60: 28 64 61 74 20 28 68 61 73 68 2d 74 61 62 6c 65 (dat (hash-table
ac70: 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 2a 74 65 -ref/default *te
ac80: 73 74 63 6f 6e 66 69 67 73 2a 20 74 65 73 74 2d stconfigs* test-
ac90: 6e 61 6d 65 20 23 66 29 29 29 0a 09 20 20 28 69 name #f))).. (i
aca0: 66 20 28 61 6e 64 20 20 64 61 74 20 3b 3b 20 68 f (and dat ;; h
acb0: 61 76 65 20 61 20 6c 6f 63 61 6c 6c 79 20 63 61 ave a locally ca
acc0: 63 68 65 64 20 76 65 72 73 69 6f 6e 0a 09 09 20 ched version...
acd0: 20 20 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 (hash-table-r
ace0: 65 66 2f 64 65 66 61 75 6c 74 20 64 61 74 20 22 ef/default dat "
acf0: 68 61 76 65 20 66 75 6c 6c 64 61 74 61 22 20 23 have fulldata" #
ad00: 66 29 29 20 3b 3b 20 6d 61 72 6b 65 64 20 61 73 f)) ;; marked as
ad10: 20 67 6f 6f 64 20 64 61 74 61 3f 0a 09 20 20 20 good data?..
ad20: 20 20 20 64 61 74 0a 09 20 20 20 20 20 20 3b 3b dat.. ;;
ad30: 20 6e 6f 20 63 61 63 68 65 64 20 64 61 74 61 20 no cached data
ad40: 61 76 61 69 6c 61 62 6c 65 0a 09 20 20 20 20 20 available..
ad50: 20 28 6c 65 74 2a 20 28 28 74 72 65 67 20 20 20 (let* ((treg
ad60: 20 20 20 20 20 20 28 6f 72 20 74 65 73 74 2d 72 (or test-r
ad70: 65 67 69 73 74 72 79 0a 09 09 09 09 20 20 20 20 egistry.....
ad80: 20 20 20 28 74 65 73 74 73 3a 67 65 74 2d 61 6c (tests:get-al
ad90: 6c 29 29 29 0a 09 09 20 20 20 20 20 28 74 65 73 l)))... (tes
ada0: 74 2d 70 61 74 68 20 20 20 20 28 6f 72 20 28 68 t-path (or (h
adb0: 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 ash-table-ref/de
adc0: 66 61 75 6c 74 20 74 72 65 67 20 74 65 73 74 2d fault treg test-
add0: 6e 61 6d 65 20 23 66 29 0a 09 09 09 09 20 20 20 name #f).....
ade0: 20 20 20 20 28 63 6f 6e 63 20 2a 74 6f 70 70 61 (conc *toppa
adf0: 74 68 2a 20 22 2f 74 65 73 74 73 2f 22 20 74 65 th* "/tests/" te
ae00: 73 74 2d 6e 61 6d 65 29 29 29 0a 09 09 20 20 20 st-name)))...
ae10: 20 20 28 74 65 73 74 2d 63 6f 6e 66 69 67 66 20 (test-configf
ae20: 28 63 6f 6e 63 20 74 65 73 74 2d 70 61 74 68 20 (conc test-path
ae30: 22 2f 74 65 73 74 63 6f 6e 66 69 67 22 29 29 0a "/testconfig")).
ae40: 09 09 20 20 20 20 20 28 74 65 73 74 65 78 69 73 .. (testexis
ae50: 74 73 20 20 20 28 61 6e 64 20 28 66 69 6c 65 2d ts (and (file-
ae60: 65 78 69 73 74 73 3f 20 74 65 73 74 2d 63 6f 6e exists? test-con
ae70: 66 69 67 66 29 28 66 69 6c 65 2d 72 65 61 64 2d figf)(file-read-
ae80: 61 63 63 65 73 73 3f 20 74 65 73 74 2d 63 6f 6e access? test-con
ae90: 66 69 67 66 29 29 29 0a 09 09 20 20 20 20 20 28 figf)))... (
aea0: 74 63 66 67 20 20 20 20 20 20 20 20 20 28 69 66 tcfg (if
aeb0: 20 74 65 73 74 65 78 69 73 74 73 0a 09 09 09 09 testexists.....
aec0: 20 20 20 20 20 20 20 28 72 65 61 64 2d 63 6f 6e (read-con
aed0: 66 69 67 20 74 65 73 74 2d 63 6f 6e 66 69 67 66 fig test-configf
aee0: 20 23 66 20 73 79 73 74 65 6d 2d 61 6c 6c 6f 77 #f system-allow
aef0: 65 64 0a 09 09 09 09 09 09 20 20 20 20 65 6e 76 ed....... env
af00: 69 72 6f 6e 2d 70 61 74 74 3a 20 28 69 66 20 73 iron-patt: (if s
af10: 79 73 74 65 6d 2d 61 6c 6c 6f 77 65 64 0a 09 09 ystem-allowed...
af20: 09 09 09 09 09 09 20 20 20 20 20 20 22 70 72 65 ...... "pre
af30: 2d 6c 61 75 6e 63 68 2d 65 6e 76 2d 76 61 72 73 -launch-env-vars
af40: 22 0a 09 09 09 09 09 09 09 09 20 20 20 20 20 20 ".........
af50: 23 66 29 29 0a 09 09 09 09 20 20 20 20 20 20 20 #f)).....
af60: 23 66 29 29 29 0a 09 09 28 69 66 20 28 61 6e 64 #f)))...(if (and
af70: 20 74 63 66 67 20 63 61 63 68 65 2d 66 69 6c 65 tcfg cache-file
af80: 29 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 ) (hash-table-se
af90: 74 21 20 74 63 66 67 20 22 68 61 76 65 20 66 75 t! tcfg "have fu
afa0: 6c 6c 64 61 74 61 22 20 23 74 29 29 20 3b 3b 20 lldata" #t)) ;;
afb0: 6d 61 72 6b 20 74 68 69 73 20 61 73 20 66 75 6c mark this as ful
afc0: 6c 79 20 72 65 61 64 20 64 61 74 61 0a 09 09 28 ly read data...(
afd0: 69 66 20 74 63 66 67 20 28 68 61 73 68 2d 74 61 if tcfg (hash-ta
afe0: 62 6c 65 2d 73 65 74 21 20 2a 74 65 73 74 63 6f ble-set! *testco
aff0: 6e 66 69 67 73 2a 20 74 65 73 74 2d 6e 61 6d 65 nfigs* test-name
b000: 20 74 63 66 67 29 29 0a 09 09 28 69 66 20 28 61 tcfg))...(if (a
b010: 6e 64 20 74 65 73 74 65 78 69 73 74 73 0a 09 09 nd testexists...
b020: 09 20 63 61 63 68 65 2d 66 69 6c 65 0a 09 09 09 . cache-file....
b030: 20 28 66 69 6c 65 2d 77 72 69 74 65 2d 61 63 63 (file-write-acc
b040: 65 73 73 3f 20 63 61 63 68 65 2d 70 61 74 68 29 ess? cache-path)
b050: 29 0a 09 09 20 20 20 20 28 6c 65 74 20 28 28 74 )... (let ((t
b060: 70 61 74 68 20 28 63 6f 6e 63 20 63 61 63 68 65 path (conc cache
b070: 2d 70 61 74 68 20 22 2f 2e 74 65 73 74 63 6f 6e -path "/.testcon
b080: 66 69 67 22 29 29 29 0a 09 09 20 20 20 20 20 20 fig")))...
b090: 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 (debug:print-inf
b0a0: 6f 20 31 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 o 1 *default-log
b0b0: 2d 70 6f 72 74 2a 20 22 43 61 63 68 69 6e 67 20 -port* "Caching
b0c0: 74 65 73 74 63 6f 6e 66 69 67 20 66 6f 72 20 22 testconfig for "
b0d0: 20 74 65 73 74 2d 6e 61 6d 65 20 22 20 69 6e 20 test-name " in
b0e0: 22 20 74 70 61 74 68 29 0a 09 09 20 20 20 20 20 " tpath)...
b0f0: 20 28 63 6f 6e 66 69 67 66 3a 77 72 69 74 65 2d (configf:write-
b100: 61 6c 69 73 74 20 74 63 66 67 20 74 70 61 74 68 alist tcfg tpath
b110: 29 29 29 0a 09 09 74 63 66 67 29 29 29 29 29 29 )))...tcfg))))))
b120: 0a 20 20 0a 3b 3b 20 73 6f 72 74 20 74 65 73 74 . .;; sort test
b130: 73 20 62 79 20 70 72 69 6f 72 69 74 79 20 61 6e s by priority an
b140: 64 20 77 61 69 74 6f 6e 0a 3b 3b 20 4d 6f 76 65 d waiton.;; Move
b150: 20 74 65 73 74 20 73 70 65 63 69 66 69 63 20 73 test specific s
b160: 74 75 66 66 20 74 6f 20 61 20 74 65 73 74 20 75 tuff to a test u
b170: 6e 69 74 20 46 49 58 4d 45 20 6f 6e 65 20 6f 66 nit FIXME one of
b180: 20 74 68 65 73 65 20 64 61 79 73 0a 28 64 65 66 these days.(def
b190: 69 6e 65 20 28 74 65 73 74 73 3a 73 6f 72 74 2d ine (tests:sort-
b1a0: 62 79 2d 70 72 69 6f 72 69 74 79 2d 61 6e 64 2d by-priority-and-
b1b0: 77 61 69 74 6f 6e 20 74 65 73 74 2d 72 65 63 6f waiton test-reco
b1c0: 72 64 73 29 0a 20 20 28 6c 65 74 2a 20 28 28 6d rds). (let* ((m
b1d0: 75 6e 67 65 70 72 69 6f 72 69 74 79 20 28 6c 61 ungepriority (la
b1e0: 6d 62 64 61 20 28 70 72 69 6f 72 69 74 79 29 0a mbda (priority).
b1f0: 09 09 09 20 20 28 69 66 20 70 72 69 6f 72 69 74 ... (if priorit
b200: 79 0a 09 09 09 20 20 20 20 20 20 28 6c 65 74 20 y.... (let
b210: 28 28 74 6d 70 20 28 61 6e 79 2d 3e 6e 75 6d 62 ((tmp (any->numb
b220: 65 72 20 70 72 69 6f 72 69 74 79 29 29 29 0a 09 er priority)))..
b230: 09 09 09 28 69 66 20 74 6d 70 20 74 6d 70 20 28 ...(if tmp tmp (
b240: 62 65 67 69 6e 20 28 64 65 62 75 67 3a 70 72 69 begin (debug:pri
b250: 6e 74 2d 65 72 72 6f 72 20 30 20 2a 64 65 66 61 nt-error 0 *defa
b260: 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 62 ult-log-port* "b
b270: 61 64 20 70 72 69 6f 72 69 74 79 20 76 61 6c 75 ad priority valu
b280: 65 20 22 20 70 72 69 6f 72 69 74 79 20 22 2c 20 e " priority ",
b290: 75 73 69 6e 67 20 30 22 29 20 30 29 29 29 0a 09 using 0") 0)))..
b2a0: 09 09 20 20 20 20 20 20 30 29 29 29 0a 09 20 28 .. 0))).. (
b2b0: 61 6c 6c 2d 74 65 73 74 73 20 20 20 20 20 20 28 all-tests (
b2c0: 68 61 73 68 2d 74 61 62 6c 65 2d 6b 65 79 73 20 hash-table-keys
b2d0: 74 65 73 74 2d 72 65 63 6f 72 64 73 29 29 0a 09 test-records))..
b2e0: 20 28 61 6c 6c 2d 77 61 69 74 65 64 2d 6f 6e 20 (all-waited-on
b2f0: 20 28 6c 65 74 20 6c 6f 6f 70 20 28 28 68 65 64 (let loop ((hed
b300: 20 28 63 61 72 20 61 6c 6c 2d 74 65 73 74 73 29 (car all-tests)
b310: 29 0a 09 09 09 09 20 20 20 20 28 74 61 6c 20 28 )..... (tal (
b320: 63 64 72 20 61 6c 6c 2d 74 65 73 74 73 29 29 0a cdr all-tests)).
b330: 09 09 09 09 20 20 20 20 28 72 65 73 20 27 28 29 .... (res '()
b340: 29 29 0a 09 09 09 20 20 20 28 6c 65 74 2a 20 28 )).... (let* (
b350: 28 74 72 65 63 20 20 20 20 28 68 61 73 68 2d 74 (trec (hash-t
b360: 61 62 6c 65 2d 72 65 66 20 74 65 73 74 2d 72 65 able-ref test-re
b370: 63 6f 72 64 73 20 68 65 64 29 29 0a 09 09 09 09 cords hed)).....
b380: 20 20 28 77 61 69 74 6f 6e 73 20 28 6f 72 20 28 (waitons (or (
b390: 74 65 73 74 73 3a 74 65 73 74 71 75 65 75 65 2d tests:testqueue-
b3a0: 67 65 74 2d 77 61 69 74 6f 6e 73 20 74 72 65 63 get-waitons trec
b3b0: 29 20 27 28 29 29 29 29 0a 09 09 09 20 20 20 20 ) '())))....
b3c0: 20 28 69 66 20 28 6e 75 6c 6c 3f 20 74 61 6c 29 (if (null? tal)
b3d0: 0a 09 09 09 09 20 28 61 70 70 65 6e 64 20 72 65 ..... (append re
b3e0: 73 20 77 61 69 74 6f 6e 73 29 0a 09 09 09 09 20 s waitons).....
b3f0: 28 6c 6f 6f 70 20 28 63 61 72 20 74 61 6c 29 28 (loop (car tal)(
b400: 63 64 72 20 74 61 6c 29 28 61 70 70 65 6e 64 20 cdr tal)(append
b410: 72 65 73 20 77 61 69 74 6f 6e 73 29 29 29 29 29 res waitons)))))
b420: 29 0a 09 20 28 73 6f 72 74 2d 66 6e 31 20 0a 09 ).. (sort-fn1 ..
b430: 20 20 28 6c 61 6d 62 64 61 20 28 61 20 62 29 0a (lambda (a b).
b440: 09 20 20 20 20 28 6c 65 74 2a 20 28 28 61 2d 72 . (let* ((a-r
b450: 65 63 6f 72 64 20 20 20 28 68 61 73 68 2d 74 61 ecord (hash-ta
b460: 62 6c 65 2d 72 65 66 20 74 65 73 74 2d 72 65 63 ble-ref test-rec
b470: 6f 72 64 73 20 61 29 29 0a 09 09 20 20 20 28 62 ords a))... (b
b480: 2d 72 65 63 6f 72 64 20 20 20 28 68 61 73 68 2d -record (hash-
b490: 74 61 62 6c 65 2d 72 65 66 20 74 65 73 74 2d 72 table-ref test-r
b4a0: 65 63 6f 72 64 73 20 62 29 29 0a 09 09 20 20 20 ecords b))...
b4b0: 28 61 2d 77 61 69 74 6f 6e 73 20 20 28 6f 72 20 (a-waitons (or
b4c0: 28 74 65 73 74 73 3a 74 65 73 74 71 75 65 75 65 (tests:testqueue
b4d0: 2d 67 65 74 2d 77 61 69 74 6f 6e 73 20 61 2d 72 -get-waitons a-r
b4e0: 65 63 6f 72 64 29 20 27 28 29 29 29 0a 09 09 20 ecord) '()))...
b4f0: 20 20 28 62 2d 77 61 69 74 6f 6e 73 20 20 28 6f (b-waitons (o
b500: 72 20 28 74 65 73 74 73 3a 74 65 73 74 71 75 65 r (tests:testque
b510: 75 65 2d 67 65 74 2d 77 61 69 74 6f 6e 73 20 62 ue-get-waitons b
b520: 2d 72 65 63 6f 72 64 29 20 27 28 29 29 29 0a 09 -record) '()))..
b530: 09 20 20 20 28 61 2d 63 6f 6e 66 69 67 20 20 20 . (a-config
b540: 28 74 65 73 74 73 3a 74 65 73 74 71 75 65 75 65 (tests:testqueue
b550: 2d 67 65 74 2d 74 65 73 74 63 6f 6e 66 69 67 20 -get-testconfig
b560: 20 61 2d 72 65 63 6f 72 64 29 29 0a 09 09 20 20 a-record))...
b570: 20 28 62 2d 63 6f 6e 66 69 67 20 20 20 28 74 65 (b-config (te
b580: 73 74 73 3a 74 65 73 74 71 75 65 75 65 2d 67 65 sts:testqueue-ge
b590: 74 2d 74 65 73 74 63 6f 6e 66 69 67 20 20 62 2d t-testconfig b-
b5a0: 72 65 63 6f 72 64 29 29 0a 09 09 20 20 20 28 61 record))... (a
b5b0: 2d 72 61 77 2d 70 72 69 20 20 28 63 6f 6e 66 69 -raw-pri (confi
b5c0: 67 2d 6c 6f 6f 6b 75 70 20 61 2d 63 6f 6e 66 69 g-lookup a-confi
b5d0: 67 20 22 72 65 71 75 69 72 65 6d 65 6e 74 73 22 g "requirements"
b5e0: 20 22 70 72 69 6f 72 69 74 79 22 29 29 0a 09 09 "priority"))...
b5f0: 20 20 20 28 62 2d 72 61 77 2d 70 72 69 20 20 28 (b-raw-pri (
b600: 63 6f 6e 66 69 67 2d 6c 6f 6f 6b 75 70 20 62 2d config-lookup b-
b610: 63 6f 6e 66 69 67 20 22 72 65 71 75 69 72 65 6d config "requirem
b620: 65 6e 74 73 22 20 22 70 72 69 6f 72 69 74 79 22 ents" "priority"
b630: 29 29 0a 09 09 20 20 20 28 61 2d 70 72 69 6f 72 ))... (a-prior
b640: 69 74 79 20 28 6d 75 6e 67 65 70 72 69 6f 72 69 ity (mungepriori
b650: 74 79 20 61 2d 72 61 77 2d 70 72 69 29 29 0a 09 ty a-raw-pri))..
b660: 09 20 20 20 28 62 2d 70 72 69 6f 72 69 74 79 20 . (b-priority
b670: 28 6d 75 6e 67 65 70 72 69 6f 72 69 74 79 20 62 (mungepriority b
b680: 2d 72 61 77 2d 70 72 69 29 29 29 0a 09 20 20 20 -raw-pri)))..
b690: 20 20 20 28 74 65 73 74 73 3a 74 65 73 74 71 75 (tests:testqu
b6a0: 65 75 65 2d 73 65 74 2d 70 72 69 6f 72 69 74 79 eue-set-priority
b6b0: 21 20 61 2d 72 65 63 6f 72 64 20 61 2d 70 72 69 ! a-record a-pri
b6c0: 6f 72 69 74 79 29 0a 09 20 20 20 20 20 20 28 74 ority).. (t
b6d0: 65 73 74 73 3a 74 65 73 74 71 75 65 75 65 2d 73 ests:testqueue-s
b6e0: 65 74 2d 70 72 69 6f 72 69 74 79 21 20 62 2d 72 et-priority! b-r
b6f0: 65 63 6f 72 64 20 62 2d 70 72 69 6f 72 69 74 79 ecord b-priority
b700: 29 0a 09 20 20 20 20 20 20 3b 3b 20 28 64 65 62 ).. ;; (deb
b710: 75 67 3a 70 72 69 6e 74 20 30 20 2a 64 65 66 61 ug:print 0 *defa
b720: 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 61 ult-log-port* "a
b730: 3d 22 20 61 20 22 2c 20 62 3d 22 20 62 20 22 2c =" a ", b=" b ",
b740: 20 61 2d 77 61 69 74 6f 6e 73 3d 22 20 61 2d 77 a-waitons=" a-w
b750: 61 69 74 6f 6e 73 20 22 2c 20 62 2d 77 61 69 74 aitons ", b-wait
b760: 6f 6e 73 3d 22 20 62 2d 77 61 69 74 6f 6e 73 29 ons=" b-waitons)
b770: 0a 09 20 20 20 20 20 20 28 63 6f 6e 64 0a 09 20 .. (cond..
b780: 20 20 20 20 20 20 3b 3b 20 69 73 20 0a 09 20 20 ;; is ..
b790: 20 20 20 20 20 28 28 6d 65 6d 62 65 72 20 61 20 ((member a
b7a0: 62 2d 77 61 69 74 6f 6e 73 29 20 20 20 20 20 20 b-waitons)
b7b0: 20 20 20 20 3b 3b 20 69 73 20 62 20 77 61 69 74 ;; is b wait
b7c0: 69 6e 67 20 6f 6e 20 61 3f 0a 09 09 3b 3b 20 28 ing on a?...;; (
b7d0: 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 2a 64 debug:print 0 *d
b7e0: 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a efault-log-port*
b7f0: 20 22 63 61 73 65 31 22 29 0a 09 09 23 74 29 0a "case1")...#t).
b800: 09 20 20 20 20 20 20 20 28 28 6d 65 6d 62 65 72 . ((member
b810: 20 62 20 61 2d 77 61 69 74 6f 6e 73 29 20 20 20 b a-waitons)
b820: 20 20 20 20 20 20 20 3b 3b 20 69 73 20 61 20 77 ;; is a w
b830: 61 69 74 69 6e 67 20 6f 6e 20 62 3f 0a 09 09 3b aiting on b?...;
b840: 3b 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 ; (debug:print 0
b850: 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f *default-log-po
b860: 72 74 2a 20 22 63 61 73 65 32 22 29 0a 09 09 23 rt* "case2")...#
b870: 66 29 0a 09 20 20 20 20 20 20 20 28 28 61 6e 64 f).. ((and
b880: 20 28 6e 6f 74 20 28 6e 75 6c 6c 3f 20 61 2d 77 (not (null? a-w
b890: 61 69 74 6f 6e 73 29 29 20 20 3b 3b 20 62 6f 74 aitons)) ;; bot
b8a0: 68 20 68 61 76 65 20 77 61 69 74 6f 6e 73 20 2d h have waitons -
b8b0: 20 64 6f 20 6e 6f 74 20 64 69 73 74 75 72 62 0a do not disturb.
b8c0: 09 09 20 20 20 20 20 28 6e 6f 74 20 28 6e 75 6c .. (not (nul
b8d0: 6c 3f 20 62 2d 77 61 69 74 6f 6e 73 29 29 29 0a l? b-waitons))).
b8e0: 09 09 3b 3b 20 28 64 65 62 75 67 3a 70 72 69 6e ..;; (debug:prin
b8f0: 74 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 t 0 *default-log
b900: 2d 70 6f 72 74 2a 20 22 63 61 73 65 32 2e 31 22 -port* "case2.1"
b910: 29 0a 09 09 23 74 29 0a 09 20 20 20 20 20 20 20 )...#t)..
b920: 28 28 61 6e 64 20 28 6e 75 6c 6c 3f 20 61 2d 77 ((and (null? a-w
b930: 61 69 74 6f 6e 73 29 20 20 20 20 20 20 20 20 3b aitons) ;
b940: 3b 20 6e 6f 20 77 61 69 74 6f 6e 73 20 66 6f 72 ; no waitons for
b950: 20 61 20 62 75 74 20 62 20 68 61 73 20 77 61 69 a but b has wai
b960: 74 6f 6e 73 0a 09 09 20 20 20 20 20 28 6e 6f 74 tons... (not
b970: 20 28 6e 75 6c 6c 3f 20 62 2d 77 61 69 74 6f 6e (null? b-waiton
b980: 73 29 29 29 0a 09 09 3b 3b 20 28 64 65 62 75 67 s)))...;; (debug
b990: 3a 70 72 69 6e 74 20 30 20 2a 64 65 66 61 75 6c :print 0 *defaul
b9a0: 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 63 61 73 t-log-port* "cas
b9b0: 65 33 22 29 0a 09 09 23 66 29 0a 09 20 20 20 20 e3")...#f)..
b9c0: 20 20 20 28 28 61 6e 64 20 28 6e 6f 74 20 28 6e ((and (not (n
b9d0: 75 6c 6c 3f 20 61 2d 77 61 69 74 6f 6e 73 29 29 ull? a-waitons))
b9e0: 20 20 3b 3b 20 61 20 68 61 73 20 77 61 69 74 6f ;; a has waito
b9f0: 6e 73 20 62 75 74 20 62 20 64 6f 65 73 20 6e 6f ns but b does no
ba00: 74 0a 09 09 20 20 20 20 20 28 6e 75 6c 6c 3f 20 t... (null?
ba10: 62 2d 77 61 69 74 6f 6e 73 29 29 20 0a 09 09 3b b-waitons)) ...;
ba20: 3b 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 ; (debug:print 0
ba30: 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f *default-log-po
ba40: 72 74 2a 20 22 63 61 73 65 34 22 29 0a 09 09 23 rt* "case4")...#
ba50: 74 29 0a 09 20 20 20 20 20 20 20 28 28 6e 6f 74 t).. ((not
ba60: 20 28 65 71 3f 20 61 2d 70 72 69 6f 72 69 74 79 (eq? a-priority
ba70: 20 62 2d 70 72 69 6f 72 69 74 79 29 29 20 3b 3b b-priority)) ;;
ba80: 20 75 73 65 0a 09 09 28 3e 20 61 2d 70 72 69 6f use...(> a-prio
ba90: 72 69 74 79 20 62 2d 70 72 69 6f 72 69 74 79 29 rity b-priority)
baa0: 29 0a 09 20 20 20 20 20 20 20 28 65 6c 73 65 0a ).. (else.
bab0: 09 09 3b 3b 20 28 64 65 62 75 67 3a 70 72 69 6e ..;; (debug:prin
bac0: 74 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 t 0 *default-log
bad0: 2d 70 6f 72 74 2a 20 22 63 61 73 65 35 22 29 0a -port* "case5").
bae0: 09 09 28 73 74 72 69 6e 67 3e 3f 20 61 20 62 29 ..(string>? a b)
baf0: 29 29 29 29 29 0a 09 20 0a 09 20 28 73 6f 72 74 ))))).. .. (sort
bb00: 2d 66 6e 32 0a 09 20 20 28 6c 61 6d 62 64 61 20 -fn2.. (lambda
bb10: 28 61 20 62 29 0a 09 20 20 20 20 28 3e 20 28 6d (a b).. (> (m
bb20: 75 6e 67 65 70 72 69 6f 72 69 74 79 20 28 74 65 ungepriority (te
bb30: 73 74 73 3a 74 65 73 74 71 75 65 75 65 2d 67 65 sts:testqueue-ge
bb40: 74 2d 70 72 69 6f 72 69 74 79 20 28 68 61 73 68 t-priority (hash
bb50: 2d 74 61 62 6c 65 2d 72 65 66 20 74 65 73 74 2d -table-ref test-
bb60: 72 65 63 6f 72 64 73 20 61 29 29 29 0a 09 20 20 records a)))..
bb70: 20 20 20 20 20 28 6d 75 6e 67 65 70 72 69 6f 72 (mungeprior
bb80: 69 74 79 20 28 74 65 73 74 73 3a 74 65 73 74 71 ity (tests:testq
bb90: 75 65 75 65 2d 67 65 74 2d 70 72 69 6f 72 69 74 ueue-get-priorit
bba0: 79 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 y (hash-table-re
bbb0: 66 20 74 65 73 74 2d 72 65 63 6f 72 64 73 20 62 f test-records b
bbc0: 29 29 29 29 29 29 29 0a 20 20 20 20 3b 3b 20 28 ))))))). ;; (
bbd0: 6c 65 74 20 28 28 64 6f 74 2d 72 65 73 20 28 74 let ((dot-res (t
bbe0: 65 73 74 73 3a 72 75 6e 2d 64 6f 74 20 28 74 65 ests:run-dot (te
bbf0: 73 74 73 3a 74 65 73 74 73 2d 3e 64 6f 74 20 74 sts:tests->dot t
bc00: 65 73 74 2d 72 65 63 6f 72 64 73 29 20 22 70 6c est-records) "pl
bc10: 61 69 6e 22 29 29 29 0a 20 20 20 20 3b 3b 20 20 ain"))). ;;
bc20: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 22 64 (debug:print "d
bc30: 6f 74 2d 72 65 73 3d 22 20 64 6f 74 2d 72 65 73 ot-res=" dot-res
bc40: 29 29 0a 20 20 20 20 3b 3b 20 28 6c 65 74 20 28 )). ;; (let (
bc50: 28 64 61 74 61 20 28 6d 61 70 20 63 64 72 20 28 (data (map cdr (
bc60: 66 69 6c 74 65 72 0a 20 20 20 20 3b 3b 20 20 20 filter. ;;
bc70: 20 20 09 09 20 20 28 6c 61 6d 62 64 61 20 28 78 .. (lambda (x
bc80: 29 28 65 71 75 61 6c 3f 20 22 6e 6f 64 65 22 20 )(equal? "node"
bc90: 28 63 61 72 20 78 29 29 29 0a 20 20 20 20 3b 3b (car x))). ;;
bca0: 20 20 20 20 20 09 09 20 20 28 6d 61 70 20 73 74 .. (map st
bcb0: 72 69 6e 67 2d 73 70 6c 69 74 20 28 74 65 73 74 ring-split (test
bcc0: 73 3a 65 61 73 79 2d 64 6f 74 20 74 65 73 74 2d s:easy-dot test-
bcd0: 72 65 63 6f 72 64 73 20 22 70 6c 61 69 6e 22 29 records "plain")
bce0: 29 29 29 29 29 0a 20 20 20 20 3b 3b 20 20 20 28 ))))). ;; (
bcf0: 6d 61 70 20 63 61 72 20 28 73 6f 72 74 20 64 61 map car (sort da
bd00: 74 61 20 28 6c 61 6d 62 64 61 20 28 61 20 62 29 ta (lambda (a b)
bd10: 0a 20 20 20 20 3b 3b 20 20 20 20 20 09 09 20 20 . ;; ..
bd20: 20 20 28 3e 20 28 73 74 72 69 6e 67 2d 3e 6e 75 (> (string->nu
bd30: 6d 62 65 72 20 28 63 61 64 64 72 20 61 29 29 28 mber (caddr a))(
bd40: 73 74 72 69 6e 67 2d 3e 6e 75 6d 62 65 72 20 28 string->number (
bd50: 63 61 64 64 72 20 62 29 29 29 29 29 29 29 0a 20 caddr b))))))).
bd60: 20 20 20 3b 3b 20 29 29 0a 20 20 20 20 28 73 6f ;; )). (so
bd70: 72 74 20 61 6c 6c 2d 74 65 73 74 73 20 73 6f 72 rt all-tests sor
bd80: 74 2d 66 6e 31 29 29 29 20 3b 3b 20 61 76 6f 69 t-fn1))) ;; avoi
bd90: 64 20 64 65 61 6c 69 6e 67 20 77 69 74 68 20 64 d dealing with d
bda0: 65 6c 65 74 65 64 20 74 65 73 74 73 2c 20 6c 6f eleted tests, lo
bdb0: 6f 6b 20 61 74 20 74 68 65 20 68 61 73 68 20 74 ok at the hash t
bdc0: 61 62 6c 65 0a 0a 28 64 65 66 69 6e 65 20 28 74 able..(define (t
bdd0: 65 73 74 73 3a 65 61 73 79 2d 64 6f 74 20 74 65 ests:easy-dot te
bde0: 73 74 2d 72 65 63 6f 72 64 73 20 6f 75 74 74 79 st-records outty
bdf0: 70 65 29 0a 20 20 28 6c 65 74 2d 76 61 6c 75 65 pe). (let-value
be00: 73 20 28 28 28 66 64 20 74 65 6d 70 2d 70 61 74 s (((fd temp-pat
be10: 68 29 20 28 66 69 6c 65 2d 6d 6b 73 74 65 6d 70 h) (file-mkstemp
be20: 20 28 63 6f 6e 63 20 22 2f 74 6d 70 2f 22 20 28 (conc "/tmp/" (
be30: 63 75 72 72 65 6e 74 2d 75 73 65 72 2d 6e 61 6d current-user-nam
be40: 65 29 20 22 2e 58 58 58 58 58 58 22 29 29 29 29 e) ".XXXXXX"))))
be50: 0a 20 20 20 20 28 6c 65 74 20 28 28 61 6c 6c 2d . (let ((all-
be60: 74 65 73 74 6e 61 6d 65 73 20 28 68 61 73 68 2d testnames (hash-
be70: 74 61 62 6c 65 2d 6b 65 79 73 20 74 65 73 74 2d table-keys test-
be80: 72 65 63 6f 72 64 73 29 29 0a 09 20 20 28 74 65 records)).. (te
be90: 6d 70 2d 70 6f 72 74 20 20 20 20 20 28 6f 70 65 mp-port (ope
bea0: 6e 2d 6f 75 74 70 75 74 2d 66 69 6c 65 2a 20 66 n-output-file* f
beb0: 64 29 29 29 0a 20 20 20 20 20 20 3b 3b 20 28 66 d))). ;; (f
bec0: 6f 72 6d 61 74 20 74 65 6d 70 2d 70 6f 72 74 20 ormat temp-port
bed0: 22 54 68 69 73 20 66 69 6c 65 20 69 73 20 7e 41 "This file is ~A
bee0: 2e 7e 25 22 20 74 65 6d 70 2d 70 61 74 68 29 0a .~%" temp-path).
bef0: 20 20 20 20 20 20 28 66 6f 72 6d 61 74 20 74 65 (format te
bf00: 6d 70 2d 70 6f 72 74 20 22 64 69 67 72 61 70 68 mp-port "digraph
bf10: 20 74 65 73 74 73 20 7b 5c 6e 22 29 0a 20 20 20 tests {\n").
bf20: 20 20 20 28 66 6f 72 6d 61 74 20 74 65 6d 70 2d (format temp-
bf30: 70 6f 72 74 20 22 20 20 73 69 7a 65 3d 34 2c 38 port " size=4,8
bf40: 5c 6e 22 29 0a 20 20 20 20 20 20 3b 3b 20 28 66 \n"). ;; (f
bf50: 6f 72 6d 61 74 20 74 65 6d 70 2d 70 6f 72 74 20 ormat temp-port
bf60: 22 20 20 20 73 70 6c 69 6e 65 73 3d 6e 6f 6e 65 " splines=none
bf70: 5c 6e 22 29 0a 20 20 20 20 20 20 28 66 6f 72 2d \n"). (for-
bf80: 65 61 63 68 0a 20 20 20 20 20 20 20 28 6c 61 6d each. (lam
bf90: 62 64 61 20 28 74 65 73 74 6e 61 6d 65 29 0a 09 bda (testname)..
bfa0: 20 28 6c 65 74 2a 20 28 28 74 65 73 74 72 65 63 (let* ((testrec
bfb0: 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 (hash-table-ref
bfc0: 20 74 65 73 74 2d 72 65 63 6f 72 64 73 20 74 65 test-records te
bfd0: 73 74 6e 61 6d 65 29 29 0a 09 09 28 77 61 69 74 stname))...(wait
bfe0: 6f 6e 73 20 28 6f 72 20 28 74 65 73 74 73 3a 74 ons (or (tests:t
bff0: 65 73 74 71 75 65 75 65 2d 67 65 74 2d 77 61 69 estqueue-get-wai
c000: 74 6f 6e 73 20 74 65 73 74 72 65 63 29 20 27 28 tons testrec) '(
c010: 29 29 29 29 0a 09 20 20 20 28 66 6f 72 2d 65 61 )))).. (for-ea
c020: 63 68 0a 09 20 20 20 20 28 6c 61 6d 62 64 61 20 ch.. (lambda
c030: 28 77 61 69 74 6f 6e 29 0a 09 20 20 20 20 20 20 (waiton)..
c040: 28 66 6f 72 6d 61 74 20 74 65 6d 70 2d 70 6f 72 (format temp-por
c050: 74 20 28 63 6f 6e 63 20 22 20 20 20 22 20 77 61 t (conc " " wa
c060: 69 74 6f 6e 20 22 20 2d 3e 20 22 20 74 65 73 74 iton " -> " test
c070: 6e 61 6d 65 20 22 20 5b 73 70 6c 69 6e 65 73 3d name " [splines=
c080: 6f 72 74 68 6f 5d 5c 6e 22 29 29 29 0a 09 20 20 ortho]\n")))..
c090: 20 20 77 61 69 74 6f 6e 73 29 29 29 0a 20 20 20 waitons))).
c0a0: 20 20 20 20 61 6c 6c 2d 74 65 73 74 6e 61 6d 65 all-testname
c0b0: 73 29 0a 20 20 20 20 20 20 28 66 6f 72 6d 61 74 s). (format
c0c0: 20 74 65 6d 70 2d 70 6f 72 74 20 22 7d 5c 6e 22 temp-port "}\n"
c0d0: 29 0a 20 20 20 20 20 20 28 63 6c 6f 73 65 2d 6f ). (close-o
c0e0: 75 74 70 75 74 2d 70 6f 72 74 20 74 65 6d 70 2d utput-port temp-
c0f0: 70 6f 72 74 29 0a 20 20 20 20 20 20 28 77 69 74 port). (wit
c100: 68 2d 69 6e 70 75 74 2d 66 72 6f 6d 2d 70 69 70 h-input-from-pip
c110: 65 0a 20 20 20 20 20 20 20 28 63 6f 6e 63 20 22 e. (conc "
c120: 65 6e 76 20 2d 69 20 50 41 54 48 3d 24 50 41 54 env -i PATH=$PAT
c130: 48 20 64 6f 74 20 2d 54 22 20 6f 75 74 74 79 70 H dot -T" outtyp
c140: 65 20 22 20 3c 20 22 20 74 65 6d 70 2d 70 61 74 e " < " temp-pat
c150: 68 29 0a 20 20 20 20 20 20 20 28 6c 61 6d 62 64 h). (lambd
c160: 61 20 28 29 0a 09 20 28 6c 65 74 20 28 28 72 65 a ().. (let ((re
c170: 73 20 28 72 65 61 64 2d 6c 69 6e 65 73 29 29 29 s (read-lines)))
c180: 0a 09 20 20 20 3b 3b 20 28 64 65 6c 65 74 65 2d .. ;; (delete-
c190: 66 69 6c 65 20 74 65 6d 70 2d 70 61 74 68 29 0a file temp-path).
c1a0: 09 20 20 20 72 65 73 29 29 29 29 29 29 0a 0a 28 . res))))))..(
c1b0: 64 65 66 69 6e 65 20 28 74 65 73 74 73 3a 77 72 define (tests:wr
c1c0: 69 74 65 2d 64 6f 74 2d 66 69 6c 65 20 74 65 73 ite-dot-file tes
c1d0: 74 2d 72 65 63 6f 72 64 73 20 66 6e 61 6d 65 20 t-records fname
c1e0: 73 69 7a 65 78 20 73 69 7a 65 79 29 0a 20 20 28 sizex sizey). (
c1f0: 69 66 20 28 66 69 6c 65 2d 77 72 69 74 65 2d 61 if (file-write-a
c200: 63 63 65 73 73 3f 20 28 70 61 74 68 6e 61 6d 65 ccess? (pathname
c210: 2d 64 69 72 65 63 74 6f 72 79 20 66 6e 61 6d 65 -directory fname
c220: 29 29 0a 20 20 20 20 20 20 28 77 69 74 68 2d 6f )). (with-o
c230: 75 74 70 75 74 2d 74 6f 2d 66 69 6c 65 20 66 6e utput-to-file fn
c240: 61 6d 65 0a 09 28 6c 61 6d 62 64 61 20 28 29 0a ame..(lambda ().
c250: 09 20 20 28 6d 61 70 20 70 72 69 6e 74 20 28 74 . (map print (t
c260: 65 73 74 73 3a 74 65 73 74 73 2d 3e 64 6f 74 20 ests:tests->dot
c270: 74 65 73 74 2d 72 65 63 6f 72 64 73 20 73 69 7a test-records siz
c280: 65 78 20 73 69 7a 65 79 29 29 29 29 29 29 0a 0a ex sizey))))))..
c290: 28 64 65 66 69 6e 65 20 28 74 65 73 74 73 3a 74 (define (tests:t
c2a0: 65 73 74 73 2d 3e 64 6f 74 20 74 65 73 74 2d 72 ests->dot test-r
c2b0: 65 63 6f 72 64 73 20 73 69 7a 65 78 20 73 69 7a ecords sizex siz
c2c0: 65 79 29 0a 20 20 28 6c 65 74 20 28 28 61 6c 6c ey). (let ((all
c2d0: 2d 74 65 73 74 6e 61 6d 65 73 20 28 68 61 73 68 -testnames (hash
c2e0: 2d 74 61 62 6c 65 2d 6b 65 79 73 20 74 65 73 74 -table-keys test
c2f0: 2d 72 65 63 6f 72 64 73 29 29 29 0a 20 20 20 20 -records))).
c300: 28 69 66 20 28 6e 75 6c 6c 3f 20 61 6c 6c 2d 74 (if (null? all-t
c310: 65 73 74 6e 61 6d 65 73 29 0a 09 27 28 29 0a 09 estnames)..'()..
c320: 28 6c 65 74 20 6c 6f 6f 70 20 28 28 68 65 64 20 (let loop ((hed
c330: 28 63 61 72 20 61 6c 6c 2d 74 65 73 74 6e 61 6d (car all-testnam
c340: 65 73 29 29 0a 09 09 20 20 20 28 74 61 6c 20 28 es))... (tal (
c350: 63 64 72 20 61 6c 6c 2d 74 65 73 74 6e 61 6d 65 cdr all-testname
c360: 73 29 29 0a 09 09 20 20 20 28 72 65 73 20 28 6c s))... (res (l
c370: 69 73 74 20 22 64 69 67 72 61 70 68 20 74 65 73 ist "digraph tes
c380: 74 73 20 7b 22 0a 09 09 09 20 20 20 20 20 20 28 ts {".... (
c390: 63 6f 6e 63 20 22 20 73 69 7a 65 3d 5c 22 22 20 conc " size=\""
c3a0: 28 6f 72 20 73 69 7a 65 78 20 31 31 29 20 22 2c (or sizex 11) ",
c3b0: 22 20 28 6f 72 20 73 69 7a 65 79 20 31 31 29 20 " (or sizey 11)
c3c0: 22 5c 22 3b 22 29 0a 09 09 09 20 20 20 20 20 20 "\";")....
c3d0: 22 20 72 61 74 69 6f 3d 30 2e 39 35 3b 22 0a 09 " ratio=0.95;"..
c3e0: 09 09 20 20 20 20 20 20 29 29 29 0a 09 20 20 28 .. ))).. (
c3f0: 6c 65 74 2a 20 28 28 74 65 73 74 72 65 63 20 28 let* ((testrec (
c400: 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 20 74 hash-table-ref t
c410: 65 73 74 2d 72 65 63 6f 72 64 73 20 68 65 64 29 est-records hed)
c420: 29 0a 09 09 20 28 77 61 69 74 6f 6e 73 20 28 6f )... (waitons (o
c430: 72 20 28 74 65 73 74 73 3a 74 65 73 74 71 75 65 r (tests:testque
c440: 75 65 2d 67 65 74 2d 77 61 69 74 6f 6e 73 20 74 ue-get-waitons t
c450: 65 73 74 72 65 63 29 20 27 28 29 29 29 0a 09 09 estrec) '()))...
c460: 20 28 6e 65 77 72 65 73 20 20 28 61 70 70 65 6e (newres (appen
c470: 64 20 72 65 73 0a 09 09 09 09 20 20 28 69 66 20 d res..... (if
c480: 28 6e 75 6c 6c 3f 20 77 61 69 74 6f 6e 73 29 0a (null? waitons).
c490: 09 09 09 09 20 20 20 20 20 20 28 6c 69 73 74 20 .... (list
c4a0: 28 63 6f 6e 63 20 22 20 20 20 5c 22 22 20 68 65 (conc " \"" he
c4b0: 64 20 22 5c 22 20 5b 73 68 61 70 65 3d 62 6f 78 d "\" [shape=box
c4c0: 5d 3b 22 29 29 0a 09 09 09 09 20 20 20 20 20 20 ];")).....
c4d0: 28 6d 61 70 20 28 6c 61 6d 62 64 61 20 28 77 61 (map (lambda (wa
c4e0: 69 74 6f 6e 29 0a 09 09 09 09 09 20 20 20 20 20 iton)......
c4f0: 28 63 6f 6e 63 20 22 20 20 20 5c 22 22 20 77 61 (conc " \"" wa
c500: 69 74 6f 6e 20 22 5c 22 20 2d 3e 20 5c 22 22 20 iton "\" -> \""
c510: 68 65 64 20 22 5c 22 20 5b 73 68 61 70 65 3d 62 hed "\" [shape=b
c520: 6f 78 5d 3b 22 29 29 0a 09 09 09 09 09 20 20 20 ox];"))......
c530: 77 61 69 74 6f 6e 73 29 0a 09 09 09 09 20 20 20 waitons).....
c540: 20 20 20 29 29 29 29 0a 09 20 20 20 20 28 69 66 )))).. (if
c550: 20 28 6e 75 6c 6c 3f 20 74 61 6c 29 0a 09 09 28 (null? tal)...(
c560: 61 70 70 65 6e 64 20 6e 65 77 72 65 73 20 28 6c append newres (l
c570: 69 73 74 20 22 7d 22 29 29 0a 09 09 28 6c 6f 6f ist "}"))...(loo
c580: 70 20 28 63 61 72 20 74 61 6c 29 28 63 64 72 20 p (car tal)(cdr
c590: 74 61 6c 29 20 6e 65 77 72 65 73 29 0a 09 09 29 tal) newres)...)
c5a0: 29 29 29 29 29 0a 0a 3b 3b 20 28 74 65 73 74 73 )))))..;; (tests
c5b0: 3a 72 75 6e 2d 64 6f 74 20 28 6c 69 73 74 20 22 :run-dot (list "
c5c0: 64 69 67 72 61 70 68 20 74 65 73 74 73 20 7b 22 digraph tests {"
c5d0: 20 22 61 20 2d 3e 20 62 22 20 22 7d 22 29 20 22 "a -> b" "}") "
c5e0: 70 6c 61 69 6e 22 29 0a 0a 28 64 65 66 69 6e 65 plain")..(define
c5f0: 20 28 74 65 73 74 73 3a 72 75 6e 2d 64 6f 74 20 (tests:run-dot
c600: 69 6e 64 61 74 20 6f 75 74 74 79 70 65 29 20 3b indat outtype) ;
c610: 3b 20 6f 75 74 74 79 70 65 20 69 73 20 70 6c 61 ; outtype is pla
c620: 69 6e 2c 20 66 69 67 2c 20 64 6f 74 2c 20 65 74 in, fig, dot, et
c630: 63 2e 20 68 74 74 70 3a 2f 2f 77 77 77 2e 67 72 c. http://www.gr
c640: 61 70 68 76 69 7a 2e 6f 72 67 2f 63 6f 6e 74 65 aphviz.org/conte
c650: 6e 74 2f 6f 75 74 70 75 74 2d 66 6f 72 6d 61 74 nt/output-format
c660: 73 0a 20 20 28 6c 65 74 2d 76 61 6c 75 65 73 20 s. (let-values
c670: 28 28 28 69 6e 70 20 6f 75 70 20 70 69 64 29 28 (((inp oup pid)(
c680: 70 72 6f 63 65 73 73 20 22 65 6e 76 20 2d 69 20 process "env -i
c690: 50 41 54 48 3d 24 50 41 54 48 20 64 6f 74 22 20 PATH=$PATH dot"
c6a0: 28 6c 69 73 74 20 22 2d 54 22 20 6f 75 74 74 79 (list "-T" outty
c6b0: 70 65 29 29 29 29 0a 20 20 20 20 28 77 69 74 68 pe)))). (with
c6c0: 2d 6f 75 74 70 75 74 2d 74 6f 2d 70 6f 72 74 20 -output-to-port
c6d0: 6f 75 70 0a 20 20 20 20 20 20 28 6c 61 6d 62 64 oup. (lambd
c6e0: 61 20 28 29 0a 09 28 6d 61 70 20 70 72 69 6e 74 a ()..(map print
c6f0: 20 69 6e 64 61 74 29 29 29 0a 20 20 20 20 28 63 indat))). (c
c700: 6c 6f 73 65 2d 6f 75 74 70 75 74 2d 70 6f 72 74 lose-output-port
c710: 20 6f 75 70 29 0a 20 20 20 20 28 6c 65 74 20 28 oup). (let (
c720: 28 72 65 73 20 28 77 69 74 68 2d 69 6e 70 75 74 (res (with-input
c730: 2d 66 72 6f 6d 2d 70 6f 72 74 20 69 6e 70 0a 09 -from-port inp..
c740: 09 20 28 6c 61 6d 62 64 61 20 28 29 0a 09 09 20 . (lambda ()...
c750: 20 20 28 72 65 61 64 2d 6c 69 6e 65 73 29 29 29 (read-lines)))
c760: 29 29 0a 20 20 20 20 20 20 28 63 6c 6f 73 65 2d )). (close-
c770: 69 6e 70 75 74 2d 70 6f 72 74 20 69 6e 70 29 0a input-port inp).
c780: 20 20 20 20 20 20 72 65 73 29 29 29 0a 0a 3b 3b res)))..;;
c790: 20 72 65 61 64 20 64 61 74 61 20 66 72 6f 6d 20 read data from
c7a0: 74 6d 70 20 66 69 6c 65 20 6f 72 20 63 72 65 61 tmp file or crea
c7b0: 74 65 20 69 66 20 6e 6f 74 20 65 78 69 73 74 73 te if not exists
c7c0: 0a 3b 3b 20 69 66 20 65 78 69 73 74 73 20 72 65 .;; if exists re
c7d0: 67 65 6e 20 69 6e 20 62 61 63 6b 67 72 6f 75 6e gen in backgroun
c7e0: 64 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 74 65 d.;;.(define (te
c7f0: 73 74 73 3a 6c 61 7a 79 2d 64 6f 74 20 74 65 73 sts:lazy-dot tes
c800: 74 72 65 63 6f 72 64 73 20 20 6f 75 74 74 79 70 trecords outtyp
c810: 65 20 73 69 7a 65 78 20 73 69 7a 65 79 29 0a 20 e sizex sizey).
c820: 20 28 6c 65 74 20 28 28 64 66 69 6c 65 20 28 63 (let ((dfile (c
c830: 6f 6e 63 20 22 2f 74 6d 70 2f 2e 22 20 28 63 75 onc "/tmp/." (cu
c840: 72 72 65 6e 74 2d 75 73 65 72 2d 6e 61 6d 65 29 rrent-user-name)
c850: 20 22 2d 22 20 28 73 65 72 76 65 72 3a 6d 6b 2d "-" (server:mk-
c860: 73 69 67 6e 61 74 75 72 65 29 20 22 2e 64 6f 74 signature) ".dot
c870: 22 29 29 0a 09 28 66 6e 61 6d 65 20 28 63 6f 6e "))..(fname (con
c880: 63 20 22 2f 74 6d 70 2f 2e 22 20 28 63 75 72 72 c "/tmp/." (curr
c890: 65 6e 74 2d 75 73 65 72 2d 6e 61 6d 65 29 20 22 ent-user-name) "
c8a0: 2d 22 20 28 73 65 72 76 65 72 3a 6d 6b 2d 73 69 -" (server:mk-si
c8b0: 67 6e 61 74 75 72 65 29 20 22 2e 64 6f 74 64 61 gnature) ".dotda
c8c0: 74 22 29 29 29 0a 20 20 20 20 28 74 65 73 74 73 t"))). (tests
c8d0: 3a 77 72 69 74 65 2d 64 6f 74 2d 66 69 6c 65 20 :write-dot-file
c8e0: 74 65 73 74 72 65 63 6f 72 64 73 20 64 66 69 6c testrecords dfil
c8f0: 65 20 73 69 7a 65 78 20 73 69 7a 65 79 29 0a 20 e sizex sizey).
c900: 20 20 20 28 69 66 20 28 66 69 6c 65 2d 65 78 69 (if (file-exi
c910: 73 74 73 3f 20 66 6e 61 6d 65 29 0a 09 28 6c 65 sts? fname)..(le
c920: 74 20 28 28 72 65 73 20 28 77 69 74 68 2d 69 6e t ((res (with-in
c930: 70 75 74 2d 66 72 6f 6d 2d 66 69 6c 65 20 66 6e put-from-file fn
c940: 61 6d 65 0a 09 09 20 20 20 20 20 28 6c 61 6d 62 ame... (lamb
c950: 64 61 20 28 29 0a 09 09 20 20 20 20 20 20 20 28 da ()... (
c960: 72 65 61 64 2d 6c 69 6e 65 73 29 29 29 29 29 0a read-lines))))).
c970: 09 20 20 28 73 79 73 74 65 6d 20 28 63 6f 6e 63 . (system (conc
c980: 20 22 65 6e 76 20 2d 69 20 50 41 54 48 3d 24 50 "env -i PATH=$P
c990: 41 54 48 20 64 6f 74 20 2d 54 20 22 20 6f 75 74 ATH dot -T " out
c9a0: 74 79 70 65 20 22 20 3c 20 22 20 64 66 69 6c 65 type " < " dfile
c9b0: 20 22 20 3e 20 22 20 66 6e 61 6d 65 20 22 26 22 " > " fname "&"
c9c0: 29 29 0a 09 20 20 72 65 73 29 0a 09 28 62 65 67 )).. res)..(beg
c9d0: 69 6e 0a 09 20 20 28 73 79 73 74 65 6d 20 28 63 in.. (system (c
c9e0: 6f 6e 63 20 22 65 6e 76 20 2d 69 20 50 41 54 48 onc "env -i PATH
c9f0: 3d 24 50 41 54 48 20 64 6f 74 20 2d 54 20 22 20 =$PATH dot -T "
ca00: 6f 75 74 74 79 70 65 20 22 20 3c 20 22 20 64 66 outtype " < " df
ca10: 69 6c 65 20 22 20 3e 20 22 20 66 6e 61 6d 65 29 ile " > " fname)
ca20: 29 0a 09 20 20 28 77 69 74 68 2d 69 6e 70 75 74 ).. (with-input
ca30: 2d 66 72 6f 6d 2d 66 69 6c 65 20 66 6e 61 6d 65 -from-file fname
ca40: 0a 09 20 20 20 20 28 6c 61 6d 62 64 61 20 28 29 .. (lambda ()
ca50: 0a 09 20 20 20 20 20 20 28 72 65 61 64 2d 6c 69 .. (read-li
ca60: 6e 65 73 29 29 29 29 29 29 29 0a 09 20 20 0a 0a nes))))))).. ..
ca70: 3b 3b 20 66 6f 72 20 65 61 63 68 20 74 65 73 74 ;; for each test
ca80: 3a 0a 3b 3b 20 20 20 0a 28 64 65 66 69 6e 65 20 :.;; .(define
ca90: 28 74 65 73 74 73 3a 66 69 6c 74 65 72 2d 6e 6f (tests:filter-no
caa0: 6e 2d 72 75 6e 6e 61 62 6c 65 20 72 75 6e 2d 69 n-runnable run-i
cab0: 64 20 74 65 73 74 6b 65 79 6e 61 6d 65 73 20 74 d testkeynames t
cac0: 65 73 74 72 65 63 6f 72 64 73 68 61 73 68 29 0a estrecordshash).
cad0: 20 20 28 6c 65 74 20 28 28 72 75 6e 6e 61 62 6c (let ((runnabl
cae0: 65 73 20 27 28 29 29 29 0a 20 20 20 20 28 66 6f es '())). (fo
caf0: 72 2d 65 61 63 68 0a 20 20 20 20 20 28 6c 61 6d r-each. (lam
cb00: 62 64 61 20 28 74 65 73 74 6b 65 79 6e 61 6d 65 bda (testkeyname
cb10: 29 0a 20 20 20 20 20 20 20 28 6c 65 74 2a 20 28 ). (let* (
cb20: 28 74 65 73 74 2d 72 65 63 6f 72 64 20 28 68 61 (test-record (ha
cb30: 73 68 2d 74 61 62 6c 65 2d 72 65 66 20 74 65 73 sh-table-ref tes
cb40: 74 72 65 63 6f 72 64 73 68 61 73 68 20 74 65 73 trecordshash tes
cb50: 74 6b 65 79 6e 61 6d 65 29 29 0a 09 20 20 20 20 tkeyname))..
cb60: 20 20 28 74 65 73 74 2d 6e 61 6d 65 20 20 20 28 (test-name (
cb70: 74 65 73 74 73 3a 74 65 73 74 71 75 65 75 65 2d tests:testqueue-
cb80: 67 65 74 2d 74 65 73 74 6e 61 6d 65 20 20 74 65 get-testname te
cb90: 73 74 2d 72 65 63 6f 72 64 29 29 0a 09 20 20 20 st-record))..
cba0: 20 20 20 28 69 74 65 6d 64 61 74 20 20 20 20 20 (itemdat
cbb0: 28 74 65 73 74 73 3a 74 65 73 74 71 75 65 75 65 (tests:testqueue
cbc0: 2d 67 65 74 2d 69 74 65 6d 64 61 74 20 20 20 74 -get-itemdat t
cbd0: 65 73 74 2d 72 65 63 6f 72 64 29 29 0a 09 20 20 est-record))..
cbe0: 20 20 20 20 28 69 74 65 6d 2d 70 61 74 68 20 20 (item-path
cbf0: 20 28 74 65 73 74 73 3a 74 65 73 74 71 75 65 75 (tests:testqueu
cc00: 65 2d 67 65 74 2d 69 74 65 6d 5f 70 61 74 68 20 e-get-item_path
cc10: 74 65 73 74 2d 72 65 63 6f 72 64 29 29 0a 09 20 test-record))..
cc20: 20 20 20 20 20 28 77 61 69 74 6f 6e 73 20 20 20 (waitons
cc30: 20 20 28 74 65 73 74 73 3a 74 65 73 74 71 75 65 (tests:testque
cc40: 75 65 2d 67 65 74 2d 77 61 69 74 6f 6e 73 20 20 ue-get-waitons
cc50: 20 74 65 73 74 2d 72 65 63 6f 72 64 29 29 0a 09 test-record))..
cc60: 20 20 20 20 20 20 28 6b 65 65 70 2d 74 65 73 74 (keep-test
cc70: 20 20 20 23 74 29 0a 09 20 20 20 20 20 20 28 74 #t).. (t
cc80: 65 73 74 2d 69 64 20 20 20 20 20 28 72 6d 74 3a est-id (rmt:
cc90: 67 65 74 2d 74 65 73 74 2d 69 64 20 72 75 6e 2d get-test-id run-
cca0: 69 64 20 74 65 73 74 2d 6e 61 6d 65 20 69 74 65 id test-name ite
ccb0: 6d 2d 70 61 74 68 29 29 0a 09 20 20 20 20 20 20 m-path))..
ccc0: 28 74 64 61 74 20 20 20 20 20 20 20 20 28 72 6d (tdat (rm
ccd0: 74 3a 67 65 74 2d 74 65 73 74 69 6e 66 6f 2d 73 t:get-testinfo-s
cce0: 74 61 74 65 2d 73 74 61 74 75 73 20 72 75 6e 2d tate-status run-
ccf0: 69 64 20 74 65 73 74 2d 69 64 29 29 29 20 3b 3b id test-id))) ;;
cd00: 20 28 63 64 62 3a 67 65 74 2d 74 65 73 74 2d 69 (cdb:get-test-i
cd10: 6e 66 6f 2d 62 79 2d 69 64 20 2a 72 75 6e 72 65 nfo-by-id *runre
cd20: 6d 6f 74 65 2a 20 74 65 73 74 2d 69 64 29 29 29 mote* test-id)))
cd30: 0a 09 20 28 69 66 20 74 64 61 74 0a 09 20 20 20 .. (if tdat..
cd40: 20 20 28 62 65 67 69 6e 0a 09 20 20 20 20 20 20 (begin..
cd50: 20 3b 3b 20 4c 6f 6f 6b 20 61 74 20 74 68 65 20 ;; Look at the
cd60: 74 65 73 74 20 73 74 61 74 65 20 61 6e 64 20 73 test state and s
cd70: 74 61 74 75 73 0a 09 20 20 20 20 20 20 20 28 69 tatus.. (i
cd80: 66 20 28 6f 72 20 28 61 6e 64 20 28 6d 65 6d 62 f (or (and (memb
cd90: 65 72 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d er (db:test-get-
cda0: 73 74 61 74 75 73 20 74 64 61 74 29 20 0a 09 09 status tdat) ...
cdb0: 09 09 20 20 20 20 27 28 22 50 41 53 53 22 20 22 .. '("PASS" "
cdc0: 57 41 52 4e 22 20 22 57 41 49 56 45 44 22 20 22 WARN" "WAIVED" "
cdd0: 43 48 45 43 4b 22 20 22 53 4b 49 50 22 29 29 0a CHECK" "SKIP")).
cde0: 09 09 09 20 20 20 20 28 65 71 75 61 6c 3f 20 28 ... (equal? (
cdf0: 64 62 3a 74 65 73 74 2d 67 65 74 2d 73 74 61 74 db:test-get-stat
ce00: 65 20 74 64 61 74 29 20 22 43 4f 4d 50 4c 45 54 e tdat) "COMPLET
ce10: 45 44 22 29 29 0a 09 09 20 20 20 20 20 20 20 28 ED"))... (
ce20: 6d 65 6d 62 65 72 20 28 64 62 3a 74 65 73 74 2d member (db:test-
ce30: 67 65 74 2d 73 74 61 74 65 20 74 64 61 74 29 0a get-state tdat).
ce40: 09 09 09 09 20 20 20 20 27 28 22 49 4e 43 4f 4d .... '("INCOM
ce50: 50 4c 45 54 45 22 20 22 4b 49 4c 4c 45 44 22 29 PLETE" "KILLED")
ce60: 29 29 0a 09 09 20 20 20 28 73 65 74 21 20 6b 65 ))... (set! ke
ce70: 65 70 2d 74 65 73 74 20 23 66 29 29 0a 0a 09 20 ep-test #f))...
ce80: 20 20 20 20 20 20 3b 3b 20 65 78 61 6d 69 6e 65 ;; examine
ce90: 20 77 61 69 74 6f 6e 73 20 66 6f 72 20 61 6e 79 waitons for any
cea0: 20 66 61 69 6c 73 2e 20 49 66 20 69 74 20 69 73 fails. If it is
ceb0: 20 46 41 49 4c 20 6f 72 20 49 4e 43 4f 4d 50 4c FAIL or INCOMPL
cec0: 45 54 45 20 74 68 65 6e 20 65 6c 69 6d 69 6e 61 ETE then elimina
ced0: 74 65 20 74 68 69 73 20 74 65 73 74 0a 09 20 20 te this test..
cee0: 20 20 20 20 20 3b 3b 20 66 72 6f 6d 20 74 68 65 ;; from the
cef0: 20 72 75 6e 6e 61 62 6c 65 20 6c 69 73 74 0a 09 runnable list..
cf00: 20 20 20 20 20 20 20 28 69 66 20 6b 65 65 70 2d (if keep-
cf10: 74 65 73 74 0a 09 09 20 20 20 28 66 6f 72 2d 65 test... (for-e
cf20: 61 63 68 20 28 6c 61 6d 62 64 61 20 28 77 61 69 ach (lambda (wai
cf30: 74 6f 6e 29 0a 09 09 09 20 20 20 20 20 20 20 3b ton).... ;
cf40: 3b 20 66 6f 72 20 6e 6f 77 20 77 65 20 61 72 65 ; for now we are
cf50: 20 77 61 69 74 69 6e 67 20 6f 6e 6c 79 20 6f 6e waiting only on
cf60: 20 74 68 65 20 70 61 72 65 6e 74 20 74 65 73 74 the parent test
cf70: 0a 09 09 09 20 20 20 20 20 20 20 28 6c 65 74 2a .... (let*
cf80: 20 28 28 70 61 72 65 6e 74 2d 74 65 73 74 2d 69 ((parent-test-i
cf90: 64 20 28 72 6d 74 3a 67 65 74 2d 74 65 73 74 2d d (rmt:get-test-
cfa0: 69 64 20 72 75 6e 2d 69 64 20 77 61 69 74 6f 6e id run-id waiton
cfb0: 20 22 22 29 29 0a 09 09 09 09 20 20 20 20 20 20 "")).....
cfc0: 28 77 74 64 61 74 20 20 20 20 20 20 20 20 20 20 (wtdat
cfd0: 28 72 6d 74 3a 67 65 74 2d 74 65 73 74 69 6e 66 (rmt:get-testinf
cfe0: 6f 2d 73 74 61 74 65 2d 73 74 61 74 75 73 20 72 o-state-status r
cff0: 75 6e 2d 69 64 20 74 65 73 74 2d 69 64 29 29 29 un-id test-id)))
d000: 20 3b 3b 20 28 63 64 62 3a 67 65 74 2d 74 65 73 ;; (cdb:get-tes
d010: 74 2d 69 6e 66 6f 2d 62 79 2d 69 64 20 2a 72 75 t-info-by-id *ru
d020: 6e 72 65 6d 6f 74 65 2a 20 74 65 73 74 2d 69 64 nremote* test-id
d030: 29 29 29 0a 09 09 09 09 20 28 69 66 20 28 6f 72 )))..... (if (or
d040: 20 28 61 6e 64 20 28 65 71 75 61 6c 3f 20 28 64 (and (equal? (d
d050: 62 3a 74 65 73 74 2d 67 65 74 2d 73 74 61 74 65 b:test-get-state
d060: 20 77 74 64 61 74 29 20 22 43 4f 4d 50 4c 45 54 wtdat) "COMPLET
d070: 45 44 22 29 0a 09 09 09 09 09 20 20 20 20 20 20 ED")......
d080: 28 6d 65 6d 62 65 72 20 28 64 62 3a 74 65 73 74 (member (db:test
d090: 2d 67 65 74 2d 73 74 61 74 75 73 20 77 74 64 61 -get-status wtda
d0a0: 74 29 20 27 28 22 46 41 49 4c 22 20 22 41 42 4f t) '("FAIL" "ABO
d0b0: 52 54 22 29 29 29 0a 09 09 09 09 09 20 28 6d 65 RT")))...... (me
d0c0: 6d 62 65 72 20 28 64 62 3a 74 65 73 74 2d 67 65 mber (db:test-ge
d0d0: 74 2d 73 74 61 74 75 73 20 77 74 64 61 74 29 20 t-status wtdat)
d0e0: 20 27 28 22 4b 49 4c 4c 45 44 22 29 29 0a 09 09 '("KILLED"))...
d0f0: 09 09 09 20 28 6d 65 6d 62 65 72 20 28 64 62 3a ... (member (db:
d100: 74 65 73 74 2d 67 65 74 2d 73 74 61 74 65 20 77 test-get-state w
d110: 74 64 61 74 29 20 20 20 27 28 22 49 4e 43 4f 4d tdat) '("INCOM
d120: 50 45 54 45 22 29 29 29 0a 09 09 09 09 20 3b 3b PETE")))..... ;;
d130: 20 28 69 66 20 28 6f 72 20 28 6d 65 6d 62 65 72 (if (or (member
d140: 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 73 74 (db:test-get-st
d150: 61 74 75 73 20 77 74 64 61 74 29 0a 09 09 09 09 atus wtdat).....
d160: 20 3b 3b 20 20 20 20 20 20 20 20 09 20 27 28 22 ;; . '("
d170: 46 41 49 4c 22 20 22 4b 49 4c 4c 45 44 22 29 29 FAIL" "KILLED"))
d180: 0a 09 09 09 09 20 3b 3b 20 20 20 20 20 20 20 20 ..... ;;
d190: 20 28 6d 65 6d 62 65 72 20 28 64 62 3a 74 65 73 (member (db:tes
d1a0: 74 2d 67 65 74 2d 73 74 61 74 65 20 77 74 64 61 t-get-state wtda
d1b0: 74 29 0a 09 09 09 09 20 3b 3b 20 20 20 20 20 20 t)..... ;;
d1c0: 20 20 09 20 27 28 22 49 4e 43 4f 4d 50 45 54 45 . '("INCOMPETE
d1d0: 22 29 29 29 0a 09 09 09 09 20 20 20 20 20 28 73 ")))..... (s
d1e0: 65 74 21 20 6b 65 65 70 2d 74 65 73 74 20 23 66 et! keep-test #f
d1f0: 29 29 29 29 20 3b 3b 20 6e 6f 20 70 6f 69 6e 74 )))) ;; no point
d200: 20 69 6e 20 72 75 6e 6e 69 6e 67 20 74 68 69 73 in running this
d210: 20 6f 6e 65 20 61 67 61 69 6e 0a 09 09 09 20 20 one again....
d220: 20 20 20 77 61 69 74 6f 6e 73 29 29 29 29 0a 09 waitons))))..
d230: 20 28 69 66 20 6b 65 65 70 2d 74 65 73 74 20 28 (if keep-test (
d240: 73 65 74 21 20 72 75 6e 6e 61 62 6c 65 73 20 28 set! runnables (
d250: 63 6f 6e 73 20 74 65 73 74 6b 65 79 6e 61 6d 65 cons testkeyname
d260: 20 72 75 6e 6e 61 62 6c 65 73 29 29 29 29 29 0a runnables))))).
d270: 20 20 20 20 20 74 65 73 74 6b 65 79 6e 61 6d 65 testkeyname
d280: 73 29 0a 20 20 20 20 72 75 6e 6e 61 62 6c 65 73 s). runnables
d290: 29 29 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ))..;;==========
d2a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
d2b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
d2c0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
d2d0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 ============.;;
d2e0: 72 65 66 61 63 74 6f 72 69 6e 67 20 74 68 69 73 refactoring this
d2f0: 20 62 6c 6f 63 6b 20 69 6e 74 6f 20 74 65 73 74 block into test
d300: 73 3a 67 65 74 2d 66 75 6c 6c 2d 64 61 74 61 20 s:get-full-data
d310: 66 72 6f 6d 20 6c 69 6e 65 20 32 36 33 20 6f 66 from line 263 of
d320: 20 72 75 6e 73 2e 73 63 6d 0a 3b 3b 3d 3d 3d 3d runs.scm.;;====
d330: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
d340: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
d350: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
d360: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
d370: 3d 3d 0a 3b 3b 20 68 65 64 20 69 73 20 74 68 65 ==.;; hed is the
d380: 20 74 65 73 74 20 6e 61 6d 65 0a 3b 3b 20 74 65 test name.;; te
d390: 73 74 2d 72 65 63 6f 72 64 73 20 69 73 20 61 20 st-records is a
d3a0: 68 61 73 68 20 6f 66 20 74 65 73 74 2d 6e 61 6d hash of test-nam
d3b0: 65 20 3d 3e 20 74 65 73 74 20 72 65 63 6f 72 64 e => test record
d3c0: 0a 28 64 65 66 69 6e 65 20 28 74 65 73 74 73 3a .(define (tests:
d3d0: 67 65 74 2d 66 75 6c 6c 2d 64 61 74 61 20 74 65 get-full-data te
d3e0: 73 74 2d 6e 61 6d 65 73 20 74 65 73 74 2d 72 65 st-names test-re
d3f0: 63 6f 72 64 73 20 72 65 71 75 69 72 65 64 2d 74 cords required-t
d400: 65 73 74 73 20 61 6c 6c 2d 74 65 73 74 73 2d 72 ests all-tests-r
d410: 65 67 69 73 74 72 79 29 0a 20 20 28 69 66 20 28 egistry). (if (
d420: 6e 6f 74 20 28 6e 75 6c 6c 3f 20 74 65 73 74 2d not (null? test-
d430: 6e 61 6d 65 73 29 29 0a 20 20 20 20 20 20 28 6c names)). (l
d440: 65 74 20 6c 6f 6f 70 20 28 28 68 65 64 20 28 63 et loop ((hed (c
d450: 61 72 20 74 65 73 74 2d 6e 61 6d 65 73 29 29 0a ar test-names)).
d460: 09 09 20 28 74 61 6c 20 28 63 64 72 20 74 65 73 .. (tal (cdr tes
d470: 74 2d 6e 61 6d 65 73 29 29 29 20 20 20 20 20 20 t-names)))
d480: 20 20 20 3b 3b 20 27 72 65 74 75 72 6e 2d 70 72 ;; 'return-pr
d490: 6f 63 73 20 74 65 6c 6c 73 20 74 68 65 20 63 6f ocs tells the co
d4a0: 6e 66 69 67 20 72 65 61 64 65 72 20 74 6f 20 70 nfig reader to p
d4b0: 72 65 70 20 72 75 6e 6e 69 6e 67 20 73 79 73 74 rep running syst
d4c0: 65 6d 20 62 75 74 20 72 65 74 75 72 6e 20 61 20 em but return a
d4d0: 70 72 6f 63 0a 09 28 64 65 62 75 67 3a 70 72 69 proc..(debug:pri
d4e0: 6e 74 2d 69 6e 66 6f 20 34 20 2a 64 65 66 61 75 nt-info 4 *defau
d4f0: 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 68 65 lt-log-port* "he
d500: 64 3d 22 20 68 65 64 20 22 20 61 74 20 74 6f 70 d=" hed " at top
d510: 20 6f 66 20 6c 6f 6f 70 22 29 0a 09 28 6c 65 74 of loop")..(let
d520: 2a 20 28 28 63 6f 6e 66 69 67 20 20 28 74 65 73 * ((config (tes
d530: 74 73 3a 67 65 74 2d 74 65 73 74 63 6f 6e 66 69 ts:get-testconfi
d540: 67 20 68 65 64 20 61 6c 6c 2d 74 65 73 74 73 2d g hed all-tests-
d550: 72 65 67 69 73 74 72 79 20 27 72 65 74 75 72 6e registry 'return
d560: 2d 70 72 6f 63 73 29 29 0a 09 20 20 20 20 20 20 -procs))..
d570: 20 28 77 61 69 74 6f 6e 73 20 28 6c 65 74 20 28 (waitons (let (
d580: 28 69 6e 73 74 72 20 28 69 66 20 63 6f 6e 66 69 (instr (if confi
d590: 67 20 0a 09 09 09 09 09 20 28 63 6f 6e 66 69 67 g ...... (config
d5a0: 2d 6c 6f 6f 6b 75 70 20 63 6f 6e 66 69 67 20 22 -lookup config "
d5b0: 72 65 71 75 69 72 65 6d 65 6e 74 73 22 20 22 77 requirements" "w
d5c0: 61 69 74 6f 6e 22 29 0a 09 09 09 09 09 20 28 62 aiton")...... (b
d5d0: 65 67 69 6e 20 3b 3b 20 4e 6f 20 63 6f 6e 66 69 egin ;; No confi
d5e0: 67 20 6d 65 61 6e 73 20 74 68 69 73 20 69 73 20 g means this is
d5f0: 61 20 6e 6f 6e 2d 65 78 69 73 74 61 6e 74 20 74 a non-existant t
d600: 65 73 74 0a 09 09 09 09 09 20 20 20 28 64 65 62 est...... (deb
d610: 75 67 3a 70 72 69 6e 74 2d 65 72 72 6f 72 20 30 ug:print-error 0
d620: 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f *default-log-po
d630: 72 74 2a 20 22 6e 6f 6e 2d 65 78 69 73 74 65 6e rt* "non-existen
d640: 74 20 72 65 71 75 69 72 65 64 20 74 65 73 74 20 t required test
d650: 5c 22 22 20 68 65 64 20 22 5c 22 2c 20 67 72 65 \"" hed "\", gre
d660: 70 20 74 68 72 6f 75 67 68 20 79 6f 75 72 20 74 p through your t
d670: 65 73 74 63 6f 6e 66 69 67 73 20 74 6f 20 66 69 estconfigs to fi
d680: 6e 64 20 61 6e 64 20 72 65 6d 6f 76 65 20 6f 72 nd and remove or
d690: 20 63 72 65 61 74 65 20 74 68 65 20 74 65 73 74 create the test
d6a0: 2e 20 44 69 73 63 61 72 64 69 6e 67 20 61 6e 64 . Discarding and
d6b0: 20 63 6f 6e 74 69 6e 75 69 6e 67 2e 22 29 0a 09 continuing.")..
d6c0: 09 09 09 09 20 20 20 20 20 22 22 29 29 29 29 0a .... "")))).
d6d0: 09 09 09 20 20 28 64 65 62 75 67 3a 70 72 69 6e ... (debug:prin
d6e0: 74 2d 69 6e 66 6f 20 38 20 2a 64 65 66 61 75 6c t-info 8 *defaul
d6f0: 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 77 61 69 t-log-port* "wai
d700: 74 6f 6e 73 20 73 74 72 69 6e 67 20 69 73 20 22 tons string is "
d710: 20 69 6e 73 74 72 29 0a 09 09 09 20 20 28 73 74 instr).... (st
d720: 72 69 6e 67 2d 73 70 6c 69 74 20 28 63 6f 6e 64 ring-split (cond
d730: 0a 09 09 09 09 09 20 28 28 70 72 6f 63 65 64 75 ...... ((procedu
d740: 72 65 3f 20 69 6e 73 74 72 29 0a 09 09 09 09 09 re? instr)......
d750: 20 20 28 6c 65 74 20 28 28 72 65 73 20 28 69 6e (let ((res (in
d760: 73 74 72 29 29 29 0a 09 09 09 09 09 20 20 20 20 str)))......
d770: 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 (debug:print-inf
d780: 6f 20 38 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 o 8 *default-log
d790: 2d 70 6f 72 74 2a 20 22 77 61 69 74 6f 6e 20 70 -port* "waiton p
d7a0: 72 6f 63 65 64 75 72 65 20 72 65 73 75 6c 74 73 rocedure results
d7b0: 20 69 6e 20 73 74 72 69 6e 67 20 22 20 72 65 73 in string " res
d7c0: 20 22 20 66 6f 72 20 74 65 73 74 20 22 20 68 65 " for test " he
d7d0: 64 29 0a 09 09 09 09 09 20 20 20 20 72 65 73 29 d)...... res)
d7e0: 29 0a 09 09 09 09 09 20 28 28 73 74 72 69 6e 67 )...... ((string
d7f0: 3f 20 69 6e 73 74 72 29 20 20 20 20 20 69 6e 73 ? instr) ins
d800: 74 72 29 0a 09 09 09 09 09 20 28 65 6c 73 65 20 tr)...... (else
d810: 0a 09 09 09 09 09 20 20 3b 3b 20 4e 4f 54 45 3a ...... ;; NOTE:
d820: 20 54 68 69 73 20 69 73 20 61 63 74 75 61 6c 6c This is actuall
d830: 79 20 74 68 65 20 63 61 73 65 20 6f 66 20 2a 6e y the case of *n
d840: 6f 2a 20 77 61 69 74 6f 6e 73 21 20 3b 3b 20 28 o* waitons! ;; (
d850: 64 65 62 75 67 3a 70 72 69 6e 74 2d 65 72 72 6f debug:print-erro
d860: 72 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 r 0 *default-log
d870: 2d 70 6f 72 74 2a 20 22 73 6f 6d 65 74 68 69 6e -port* "somethin
d880: 67 20 77 65 6e 74 20 77 72 6f 6e 67 20 69 6e 20 g went wrong in
d890: 70 72 6f 63 65 73 73 69 6e 67 20 77 61 69 74 6f processing waito
d8a0: 6e 73 20 66 6f 72 20 74 65 73 74 20 22 20 68 65 ns for test " he
d8b0: 64 29 0a 09 09 09 09 09 20 20 22 22 29 29 29 29 d)...... ""))))
d8c0: 29 29 0a 09 20 20 28 69 66 20 28 6e 6f 74 20 63 )).. (if (not c
d8d0: 6f 6e 66 69 67 29 20 3b 3b 20 74 68 69 73 20 69 onfig) ;; this i
d8e0: 73 20 61 20 6e 6f 6e 2d 65 78 69 73 74 61 6e 74 s a non-existant
d8f0: 20 74 65 73 74 20 63 61 6c 6c 65 64 20 69 6e 20 test called in
d900: 61 20 77 61 69 74 6f 6e 2e 20 0a 09 20 20 20 20 a waiton. ..
d910: 20 20 28 69 66 20 28 6e 75 6c 6c 3f 20 74 61 6c (if (null? tal
d920: 29 0a 09 09 20 20 74 65 73 74 2d 72 65 63 6f 72 )... test-recor
d930: 64 73 0a 09 09 20 20 28 6c 6f 6f 70 20 28 63 61 ds... (loop (ca
d940: 72 20 74 61 6c 29 28 63 64 72 20 74 61 6c 29 29 r tal)(cdr tal))
d950: 29 0a 09 20 20 20 20 20 20 28 62 65 67 69 6e 0a ).. (begin.
d960: 09 09 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 ..(debug:print-i
d970: 6e 66 6f 20 38 20 2a 64 65 66 61 75 6c 74 2d 6c nfo 8 *default-l
d980: 6f 67 2d 70 6f 72 74 2a 20 22 77 61 69 74 6f 6e og-port* "waiton
d990: 73 3a 20 22 20 77 61 69 74 6f 6e 73 29 0a 09 09 s: " waitons)...
d9a0: 3b 3b 20 63 68 65 63 6b 20 66 6f 72 20 68 65 64 ;; check for hed
d9b0: 20 69 6e 20 77 61 69 74 6f 6e 73 20 3d 3e 20 74 in waitons => t
d9c0: 68 69 73 20 77 6f 75 6c 64 20 62 65 20 63 69 72 his would be cir
d9d0: 63 75 6c 61 72 2c 20 72 65 6d 6f 76 65 20 69 74 cular, remove it
d9e0: 20 61 6e 64 20 69 73 73 75 65 20 61 6e 0a 09 09 and issue an...
d9f0: 3b 3b 20 65 72 72 6f 72 0a 09 09 28 69 66 20 28 ;; error...(if (
da00: 6d 65 6d 62 65 72 20 68 65 64 20 77 61 69 74 6f member hed waito
da10: 6e 73 29 0a 09 09 20 20 20 20 28 62 65 67 69 6e ns)... (begin
da20: 0a 09 09 20 20 20 20 20 20 28 64 65 62 75 67 3a ... (debug:
da30: 70 72 69 6e 74 2d 65 72 72 6f 72 20 30 20 2a 64 print-error 0 *d
da40: 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a efault-log-port*
da50: 20 22 74 65 73 74 20 22 20 68 65 64 20 22 20 68 "test " hed " h
da60: 61 73 20 6c 69 73 74 65 64 20 69 74 73 65 6c 66 as listed itself
da70: 20 61 73 20 61 20 77 61 69 74 6f 6e 2c 20 70 6c as a waiton, pl
da80: 65 61 73 65 20 63 6f 72 72 65 63 74 20 74 68 69 ease correct thi
da90: 73 21 22 29 0a 09 09 20 20 20 20 20 20 28 73 65 s!")... (se
daa0: 74 21 20 77 61 69 74 6f 6e 73 20 28 66 69 6c 74 t! waitons (filt
dab0: 65 72 20 28 6c 61 6d 62 64 61 20 28 78 29 28 6e er (lambda (x)(n
dac0: 6f 74 20 28 65 71 75 61 6c 3f 20 78 20 68 65 64 ot (equal? x hed
dad0: 29 29 29 20 77 61 69 74 6f 6e 73 29 29 29 29 0a ))) waitons)))).
dae0: 09 09 0a 09 09 3b 3b 20 28 69 74 65 6d 73 20 20 .....;; (items
daf0: 20 28 69 74 65 6d 73 3a 67 65 74 2d 69 74 65 6d (items:get-item
db00: 73 2d 66 72 6f 6d 2d 63 6f 6e 66 69 67 20 63 6f s-from-config co
db10: 6e 66 69 67 29 29 29 0a 09 09 28 69 66 20 28 6e nfig)))...(if (n
db20: 6f 74 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 ot (hash-table-r
db30: 65 66 2f 64 65 66 61 75 6c 74 20 74 65 73 74 2d ef/default test-
db40: 72 65 63 6f 72 64 73 20 68 65 64 20 23 66 29 29 records hed #f))
db50: 0a 09 09 20 20 20 20 28 68 61 73 68 2d 74 61 62 ... (hash-tab
db60: 6c 65 2d 73 65 74 21 20 74 65 73 74 2d 72 65 63 le-set! test-rec
db70: 6f 72 64 73 0a 09 09 09 09 20 20 20 20 20 68 65 ords..... he
db80: 64 20 28 76 65 63 74 6f 72 20 68 65 64 20 20 20 d (vector hed
db90: 20 20 3b 3b 20 30 0a 09 09 09 09 09 09 20 63 6f ;; 0....... co
dba0: 6e 66 69 67 20 20 3b 3b 20 31 0a 09 09 09 09 09 nfig ;; 1......
dbb0: 09 20 77 61 69 74 6f 6e 73 20 3b 3b 20 32 0a 09 . waitons ;; 2..
dbc0: 09 09 09 09 09 20 28 63 6f 6e 66 69 67 2d 6c 6f ..... (config-lo
dbd0: 6f 6b 75 70 20 63 6f 6e 66 69 67 20 22 72 65 71 okup config "req
dbe0: 75 69 72 65 6d 65 6e 74 73 22 20 22 70 72 69 6f uirements" "prio
dbf0: 72 69 74 79 22 29 20 20 20 20 20 3b 3b 20 70 72 rity") ;; pr
dc00: 69 6f 72 69 74 79 20 33 0a 09 09 09 09 09 09 20 iority 3.......
dc10: 28 6c 65 74 20 28 28 69 74 65 6d 73 20 20 20 20 (let ((items
dc20: 20 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 (hash-table-re
dc30: 66 2f 64 65 66 61 75 6c 74 20 63 6f 6e 66 69 67 f/default config
dc40: 20 22 69 74 65 6d 73 22 20 23 66 29 29 20 3b 3b "items" #f)) ;;
dc50: 20 69 74 65 6d 73 20 34 0a 09 09 09 09 09 09 20 items 4.......
dc60: 20 20 20 20 20 20 28 69 74 65 6d 73 74 61 62 6c (itemstabl
dc70: 65 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 e (hash-table-re
dc80: 66 2f 64 65 66 61 75 6c 74 20 63 6f 6e 66 69 67 f/default config
dc90: 20 22 69 74 65 6d 73 74 61 62 6c 65 22 20 23 66 "itemstable" #f
dca0: 29 29 29 20 0a 09 09 09 09 09 09 20 20 20 3b 3b ))) ....... ;;
dcb0: 20 69 66 20 65 69 74 68 65 72 20 69 74 65 6d 73 if either items
dcc0: 20 6f 72 20 69 74 65 6d 73 20 74 61 62 6c 65 20 or items table
dcd0: 69 73 20 61 20 70 72 6f 63 20 72 65 74 75 72 6e is a proc return
dce0: 20 69 74 20 73 6f 20 74 65 73 74 20 72 75 6e 6e it so test runn
dcf0: 69 6e 67 0a 09 09 09 09 09 09 20 20 20 3b 3b 20 ing....... ;;
dd00: 70 72 6f 63 65 73 73 20 63 61 6e 20 6b 6e 6f 77 process can know
dd10: 20 74 6f 20 63 61 6c 6c 20 69 74 65 6d 73 3a 67 to call items:g
dd20: 65 74 2d 69 74 65 6d 73 2d 66 72 6f 6d 2d 63 6f et-items-from-co
dd30: 6e 66 69 67 0a 09 09 09 09 09 09 20 20 20 3b 3b nfig....... ;;
dd40: 20 69 66 20 65 69 74 68 65 72 20 69 73 20 61 20 if either is a
dd50: 6c 69 73 74 20 61 6e 64 20 6e 6f 6e 65 20 69 73 list and none is
dd60: 20 61 20 70 72 6f 63 20 67 6f 20 61 68 65 61 64 a proc go ahead
dd70: 20 61 6e 64 20 63 61 6c 6c 20 67 65 74 2d 69 74 and call get-it
dd80: 65 6d 73 0a 09 09 09 09 09 09 20 20 20 3b 3b 20 ems....... ;;
dd90: 6f 74 68 65 72 77 69 73 65 20 72 65 74 75 72 6e otherwise return
dda0: 20 23 66 20 2d 20 74 68 69 73 20 69 73 20 6e 6f #f - this is no
ddb0: 74 20 61 6e 20 69 74 65 72 61 74 65 64 20 74 65 t an iterated te
ddc0: 73 74 0a 09 09 09 09 09 09 20 20 20 28 63 6f 6e st....... (con
ddd0: 64 0a 09 09 09 09 09 09 20 20 20 20 28 28 70 72 d....... ((pr
dde0: 6f 63 65 64 75 72 65 3f 20 69 74 65 6d 73 29 20 ocedure? items)
ddf0: 20 20 20 20 20 0a 09 09 09 09 09 09 20 20 20 20 .......
de00: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e (debug:print-in
de10: 66 6f 20 34 20 2a 64 65 66 61 75 6c 74 2d 6c 6f fo 4 *default-lo
de20: 67 2d 70 6f 72 74 2a 20 22 69 74 65 6d 73 20 69 g-port* "items i
de30: 73 20 61 20 70 72 6f 63 65 64 75 72 65 2c 20 77 s a procedure, w
de40: 69 6c 6c 20 63 61 6c 63 20 6c 61 74 65 72 22 29 ill calc later")
de50: 0a 09 09 09 09 09 09 20 20 20 20 20 69 74 65 6d ....... item
de60: 73 29 20 20 20 20 20 20 20 20 20 20 20 20 3b 3b s) ;;
de70: 20 63 61 6c 63 20 6c 61 74 65 72 0a 09 09 09 09 calc later.....
de80: 09 09 20 20 20 20 28 28 70 72 6f 63 65 64 75 72 .. ((procedur
de90: 65 3f 20 69 74 65 6d 73 74 61 62 6c 65 29 0a 09 e? itemstable)..
dea0: 09 09 09 09 09 20 20 20 20 20 28 64 65 62 75 67 ..... (debug
deb0: 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 34 20 2a 64 :print-info 4 *d
dec0: 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a efault-log-port*
ded0: 20 22 69 74 65 6d 73 74 61 62 6c 65 20 69 73 20 "itemstable is
dee0: 61 20 70 72 6f 63 65 64 75 72 65 2c 20 77 69 6c a procedure, wil
def0: 6c 20 63 61 6c 63 20 6c 61 74 65 72 22 29 0a 09 l calc later")..
df00: 09 09 09 09 09 20 20 20 20 20 69 74 65 6d 73 74 ..... itemst
df10: 61 62 6c 65 29 20 20 20 20 20 20 20 3b 3b 20 63 able) ;; c
df20: 61 6c 63 20 6c 61 74 65 72 0a 09 09 09 09 09 09 alc later.......
df30: 20 20 20 20 28 28 66 69 6c 74 65 72 20 28 6c 61 ((filter (la
df40: 6d 62 64 61 20 28 78 29 0a 09 09 09 09 09 09 09 mbda (x)........
df50: 20 20 20 20 20 20 20 28 6c 65 74 20 28 28 76 61 (let ((va
df60: 6c 20 28 63 61 72 20 78 29 29 29 0a 09 09 09 09 l (car x))).....
df70: 09 09 09 09 20 28 69 66 20 28 70 72 6f 63 65 64 .... (if (proced
df80: 75 72 65 3f 20 76 61 6c 29 20 76 61 6c 20 23 66 ure? val) val #f
df90: 29 29 29 0a 09 09 09 09 09 09 09 20 20 20 20 20 )))........
dfa0: 28 61 70 70 65 6e 64 20 28 69 66 20 28 6c 69 73 (append (if (lis
dfb0: 74 3f 20 69 74 65 6d 73 29 20 69 74 65 6d 73 20 t? items) items
dfc0: 27 28 29 29 0a 09 09 09 09 09 09 09 09 20 20 20 '()).........
dfd0: 20 20 28 69 66 20 28 6c 69 73 74 3f 20 69 74 65 (if (list? ite
dfe0: 6d 73 74 61 62 6c 65 29 20 69 74 65 6d 73 74 61 mstable) itemsta
dff0: 62 6c 65 20 27 28 29 29 29 29 0a 09 09 09 09 09 ble '())))......
e000: 09 20 20 20 20 20 27 68 61 76 65 2d 70 72 6f 63 . 'have-proc
e010: 65 64 75 72 65 29 0a 09 09 09 09 09 09 20 20 20 edure).......
e020: 20 28 28 6f 72 20 28 6c 69 73 74 3f 20 69 74 65 ((or (list? ite
e030: 6d 73 29 28 6c 69 73 74 3f 20 69 74 65 6d 73 74 ms)(list? itemst
e040: 61 62 6c 65 29 29 20 3b 3b 20 63 61 6c 63 20 6e able)) ;; calc n
e050: 6f 77 0a 09 09 09 09 09 09 20 20 20 20 20 28 64 ow....... (d
e060: 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 ebug:print-info
e070: 34 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 4 *default-log-p
e080: 6f 72 74 2a 20 22 69 74 65 6d 73 20 61 6e 64 20 ort* "items and
e090: 69 74 65 6d 73 74 61 62 6c 65 20 61 72 65 20 6c itemstable are l
e0a0: 69 73 74 73 2c 20 63 61 6c 63 20 6e 6f 77 5c 6e ists, calc now\n
e0b0: 22 0a 09 09 09 09 09 09 09 09 20 20 20 20 20 20 ".........
e0c0: 20 22 20 20 20 20 69 74 65 6d 73 3a 20 22 20 69 " items: " i
e0d0: 74 65 6d 73 20 22 20 69 74 65 6d 73 74 61 62 6c tems " itemstabl
e0e0: 65 3a 20 22 20 69 74 65 6d 73 74 61 62 6c 65 29 e: " itemstable)
e0f0: 0a 09 09 09 09 09 09 20 20 20 20 20 28 69 74 65 ....... (ite
e100: 6d 73 3a 67 65 74 2d 69 74 65 6d 73 2d 66 72 6f ms:get-items-fro
e110: 6d 2d 63 6f 6e 66 69 67 20 63 6f 6e 66 69 67 29 m-config config)
e120: 29 0a 09 09 09 09 09 09 20 20 20 20 28 65 6c 73 )....... (els
e130: 65 20 23 66 29 29 29 20 20 20 20 20 20 20 20 20 e #f)))
e140: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
e150: 20 20 3b 3b 20 6e 6f 74 20 69 74 65 72 61 74 65 ;; not iterate
e160: 64 0a 09 09 09 09 09 09 20 23 66 20 20 20 20 20 d....... #f
e170: 20 3b 3b 20 69 74 65 6d 73 64 61 74 20 35 0a 09 ;; itemsdat 5..
e180: 09 09 09 09 09 20 23 66 20 20 20 20 20 20 3b 3b ..... #f ;;
e190: 20 73 70 61 72 65 20 2d 20 75 73 65 64 20 66 6f spare - used fo
e1a0: 72 20 69 74 65 6d 2d 70 61 74 68 0a 09 09 09 09 r item-path.....
e1b0: 09 09 20 29 29 29 0a 09 09 28 66 6f 72 2d 65 61 .. )))...(for-ea
e1c0: 63 68 20 0a 09 09 20 28 6c 61 6d 62 64 61 20 28 ch ... (lambda (
e1d0: 77 61 69 74 6f 6e 29 0a 09 09 20 20 20 28 69 66 waiton)... (if
e1e0: 20 28 61 6e 64 20 77 61 69 74 6f 6e 20 28 6e 6f (and waiton (no
e1f0: 74 20 28 6d 65 6d 62 65 72 20 77 61 69 74 6f 6e t (member waiton
e200: 20 74 65 73 74 2d 6e 61 6d 65 73 29 29 29 0a 09 test-names)))..
e210: 09 20 20 20 20 20 20 20 28 62 65 67 69 6e 0a 09 . (begin..
e220: 09 09 20 28 73 65 74 21 20 72 65 71 75 69 72 65 .. (set! require
e230: 64 2d 74 65 73 74 73 20 28 63 6f 6e 73 20 77 61 d-tests (cons wa
e240: 69 74 6f 6e 20 72 65 71 75 69 72 65 64 2d 74 65 iton required-te
e250: 73 74 73 29 29 0a 09 09 09 20 28 73 65 74 21 20 sts)).... (set!
e260: 74 65 73 74 2d 6e 61 6d 65 73 20 28 63 6f 6e 73 test-names (cons
e270: 20 77 61 69 74 6f 6e 20 74 65 73 74 2d 6e 61 6d waiton test-nam
e280: 65 73 29 29 29 29 29 20 3b 3b 20 77 61 73 20 61 es))))) ;; was a
e290: 6e 20 61 70 70 65 6e 64 2c 20 6e 6f 77 20 61 20 n append, now a
e2a0: 63 6f 6e 73 0a 09 09 20 77 61 69 74 6f 6e 73 29 cons... waitons)
e2b0: 0a 09 09 28 6c 65 74 20 28 28 72 65 6d 74 65 73 ...(let ((remtes
e2c0: 74 73 20 28 64 65 6c 65 74 65 2d 64 75 70 6c 69 ts (delete-dupli
e2d0: 63 61 74 65 73 20 28 61 70 70 65 6e 64 20 77 61 cates (append wa
e2e0: 69 74 6f 6e 73 20 74 61 6c 29 29 29 29 0a 09 09 itons tal))))...
e2f0: 20 20 28 69 66 20 28 6e 6f 74 20 28 6e 75 6c 6c (if (not (null
e300: 3f 20 72 65 6d 74 65 73 74 73 29 29 0a 09 09 20 ? remtests))...
e310: 20 20 20 20 20 28 6c 6f 6f 70 20 28 63 61 72 20 (loop (car
e320: 72 65 6d 74 65 73 74 73 29 28 63 64 72 20 72 65 remtests)(cdr re
e330: 6d 74 65 73 74 73 29 29 0a 09 09 20 20 20 20 20 mtests))...
e340: 20 74 65 73 74 2d 72 65 63 6f 72 64 73 29 29 29 test-records)))
e350: 29 29 29 29 29 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d )))))..;;=======
e360: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
e370: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
e380: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
e390: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a ===============.
e3a0: 3b 3b 20 74 65 73 74 20 73 74 65 70 73 0a 3b 3b ;; test steps.;;
e3b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
e3c0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
e3d0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
e3e0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
e3f0: 3d 3d 3d 3d 3d 3d 0a 0a 3b 3b 20 74 65 73 74 73 ======..;; tests
e400: 74 65 70 2d 73 65 74 2d 73 74 61 74 75 73 21 20 tep-set-status!
e410: 75 73 65 64 20 74 6f 20 62 65 20 68 65 72 65 0a used to be here.
e420: 0a 28 64 65 66 69 6e 65 20 28 74 65 73 74 2d 67 .(define (test-g
e430: 65 74 2d 6b 69 6c 6c 2d 72 65 71 75 65 73 74 20 et-kill-request
e440: 72 75 6e 2d 69 64 20 74 65 73 74 2d 69 64 29 20 run-id test-id)
e450: 3b 3b 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 6e ;; run-id test-n
e460: 61 6d 65 20 69 74 65 6d 64 61 74 29 0a 20 20 28 ame itemdat). (
e470: 6c 65 74 2a 20 28 28 74 65 73 74 64 61 74 20 20 let* ((testdat
e480: 20 28 72 6d 74 3a 67 65 74 2d 74 65 73 74 2d 69 (rmt:get-test-i
e490: 6e 66 6f 2d 62 79 2d 69 64 20 72 75 6e 2d 69 64 nfo-by-id run-id
e4a0: 20 74 65 73 74 2d 69 64 29 29 29 0a 20 20 20 20 test-id))).
e4b0: 28 61 6e 64 20 74 65 73 74 64 61 74 0a 09 20 28 (and testdat.. (
e4c0: 65 71 75 61 6c 3f 20 28 74 65 73 74 3a 67 65 74 equal? (test:get
e4d0: 2d 73 74 61 74 65 20 74 65 73 74 64 61 74 29 20 -state testdat)
e4e0: 22 4b 49 4c 4c 52 45 51 22 29 29 29 29 0a 0a 28 "KILLREQ"))))..(
e4f0: 64 65 66 69 6e 65 20 28 74 65 73 74 3a 74 64 62 define (test:tdb
e500: 2d 67 65 74 2d 72 75 6e 64 61 74 2d 63 6f 75 6e -get-rundat-coun
e510: 74 20 74 64 62 29 0a 20 20 28 69 66 20 74 64 62 t tdb). (if tdb
e520: 0a 20 20 20 20 20 20 28 6c 65 74 20 28 28 72 65 . (let ((re
e530: 73 20 30 29 29 0a 09 28 73 71 6c 69 74 65 33 3a s 0))..(sqlite3:
e540: 66 6f 72 2d 65 61 63 68 2d 72 6f 77 0a 09 20 28 for-each-row.. (
e550: 6c 61 6d 62 64 61 20 28 63 6f 75 6e 74 29 0a 09 lambda (count)..
e560: 20 20 20 28 73 65 74 21 20 72 65 73 20 63 6f 75 (set! res cou
e570: 6e 74 29 29 0a 09 20 74 64 62 0a 09 20 22 53 45 nt)).. tdb.. "SE
e580: 4c 45 43 54 20 63 6f 75 6e 74 28 69 64 29 20 46 LECT count(id) F
e590: 52 4f 4d 20 74 65 73 74 5f 72 75 6e 64 61 74 3b ROM test_rundat;
e5a0: 22 29 0a 09 72 65 73 29 29 0a 20 20 30 29 0a 0a ")..res)). 0)..
e5b0: 28 64 65 66 69 6e 65 20 28 74 65 73 74 73 3a 75 (define (tests:u
e5c0: 70 64 61 74 65 2d 63 65 6e 74 72 61 6c 2d 6d 65 pdate-central-me
e5d0: 74 61 2d 69 6e 66 6f 20 72 75 6e 2d 69 64 20 74 ta-info run-id t
e5e0: 65 73 74 2d 69 64 20 63 70 75 6c 6f 61 64 20 64 est-id cpuload d
e5f0: 69 73 6b 66 72 65 65 20 6d 69 6e 75 74 65 73 20 iskfree minutes
e600: 75 6e 61 6d 65 20 68 6f 73 74 6e 61 6d 65 29 0a uname hostname).
e610: 20 20 28 69 66 20 28 61 6e 64 20 63 70 75 6c 6f (if (and cpulo
e620: 61 64 20 64 69 73 6b 66 72 65 65 29 0a 20 20 20 ad diskfree).
e630: 20 20 20 28 72 6d 74 3a 67 65 6e 65 72 61 6c 2d (rmt:general-
e640: 63 61 6c 6c 20 27 75 70 64 61 74 65 2d 63 70 75 call 'update-cpu
e650: 6c 6f 61 64 2d 64 69 73 6b 66 72 65 65 20 72 75 load-diskfree ru
e660: 6e 2d 69 64 20 63 70 75 6c 6f 61 64 20 64 69 73 n-id cpuload dis
e670: 6b 66 72 65 65 20 74 65 73 74 2d 69 64 29 29 0a kfree test-id)).
e680: 20 20 28 69 66 20 6d 69 6e 75 74 65 73 20 0a 20 (if minutes .
e690: 20 20 20 20 20 28 72 6d 74 3a 67 65 6e 65 72 61 (rmt:genera
e6a0: 6c 2d 63 61 6c 6c 20 27 75 70 64 61 74 65 2d 72 l-call 'update-r
e6b0: 75 6e 2d 64 75 72 61 74 69 6f 6e 20 72 75 6e 2d un-duration run-
e6c0: 69 64 20 6d 69 6e 75 74 65 73 20 74 65 73 74 2d id minutes test-
e6d0: 69 64 29 29 0a 20 20 28 69 66 20 28 61 6e 64 20 id)). (if (and
e6e0: 75 6e 61 6d 65 20 68 6f 73 74 6e 61 6d 65 29 0a uname hostname).
e6f0: 20 20 20 20 20 20 28 72 6d 74 3a 67 65 6e 65 72 (rmt:gener
e700: 61 6c 2d 63 61 6c 6c 20 27 75 70 64 61 74 65 2d al-call 'update-
e710: 75 6e 61 6d 65 2d 68 6f 73 74 20 72 75 6e 2d 69 uname-host run-i
e720: 64 20 75 6e 61 6d 65 20 68 6f 73 74 6e 61 6d 65 d uname hostname
e730: 20 74 65 73 74 2d 69 64 29 29 29 0a 20 20 0a 3b test-id))). .;
e740: 3b 20 54 68 69 73 20 6f 6e 65 20 69 73 20 66 6f ; This one is fo
e750: 72 20 72 75 6e 6e 69 6e 67 20 77 69 74 68 20 6e r running with n
e760: 6f 20 64 62 20 61 63 63 65 73 73 20 28 69 2e 65 o db access (i.e
e770: 2e 20 76 69 61 20 72 6d 74 3a 20 69 6e 74 65 72 . via rmt: inter
e780: 6e 61 6c 6c 79 29 0a 28 64 65 66 69 6e 65 20 28 nally).(define (
e790: 74 65 73 74 73 3a 73 65 74 2d 66 75 6c 6c 2d 6d tests:set-full-m
e7a0: 65 74 61 2d 69 6e 66 6f 20 64 62 20 74 65 73 74 eta-info db test
e7b0: 2d 69 64 20 72 75 6e 2d 69 64 20 6d 69 6e 75 74 -id run-id minut
e7c0: 65 73 20 77 6f 72 6b 2d 61 72 65 61 20 72 65 6d es work-area rem
e7d0: 74 72 69 65 73 29 0a 3b 3b 20 28 64 65 66 69 6e tries).;; (defin
e7e0: 65 20 28 74 65 73 74 73 3a 73 65 74 2d 66 75 6c e (tests:set-ful
e7f0: 6c 2d 6d 65 74 61 2d 69 6e 66 6f 20 74 65 73 74 l-meta-info test
e800: 2d 69 64 20 72 75 6e 2d 69 64 20 6d 69 6e 75 74 -id run-id minut
e810: 65 73 20 77 6f 72 6b 2d 61 72 65 61 29 0a 3b 3b es work-area).;;
e820: 20 20 28 6c 65 74 20 28 28 72 65 6d 74 72 69 65 (let ((remtrie
e830: 73 20 31 30 29 29 0a 20 20 28 6c 65 74 2a 20 28 s 10)). (let* (
e840: 28 63 70 75 6c 6f 61 64 20 20 28 67 65 74 2d 63 (cpuload (get-c
e850: 70 75 2d 6c 6f 61 64 29 29 0a 09 20 28 64 69 73 pu-load)).. (dis
e860: 6b 66 72 65 65 20 28 67 65 74 2d 64 66 20 28 63 kfree (get-df (c
e870: 75 72 72 65 6e 74 2d 64 69 72 65 63 74 6f 72 79 urrent-directory
e880: 29 29 29 0a 09 20 28 75 6e 61 6d 65 20 20 20 20 ))).. (uname
e890: 28 67 65 74 2d 75 6e 61 6d 65 20 22 2d 73 72 76 (get-uname "-srv
e8a0: 70 69 6f 22 29 29 0a 09 20 28 68 6f 73 74 6e 61 pio")).. (hostna
e8b0: 6d 65 20 28 67 65 74 2d 68 6f 73 74 2d 6e 61 6d me (get-host-nam
e8c0: 65 29 29 29 0a 20 20 20 20 28 74 65 73 74 73 3a e))). (tests:
e8d0: 75 70 64 61 74 65 2d 63 65 6e 74 72 61 6c 2d 6d update-central-m
e8e0: 65 74 61 2d 69 6e 66 6f 20 72 75 6e 2d 69 64 20 eta-info run-id
e8f0: 74 65 73 74 2d 69 64 20 63 70 75 6c 6f 61 64 20 test-id cpuload
e900: 64 69 73 6b 66 72 65 65 20 6d 69 6e 75 74 65 73 diskfree minutes
e910: 20 75 6e 61 6d 65 20 68 6f 73 74 6e 61 6d 65 29 uname hostname)
e920: 29 29 0a 20 20 20 20 0a 3b 3b 20 28 64 65 66 69 )). .;; (defi
e930: 6e 65 20 28 74 65 73 74 73 3a 73 65 74 2d 70 61 ne (tests:set-pa
e940: 72 74 69 61 6c 2d 6d 65 74 61 2d 69 6e 66 6f 20 rtial-meta-info
e950: 74 65 73 74 2d 69 64 20 72 75 6e 2d 69 64 20 6d test-id run-id m
e960: 69 6e 75 74 65 73 20 77 6f 72 6b 2d 61 72 65 61 inutes work-area
e970: 29 0a 28 64 65 66 69 6e 65 20 28 74 65 73 74 73 ).(define (tests
e980: 3a 73 65 74 2d 70 61 72 74 69 61 6c 2d 6d 65 74 :set-partial-met
e990: 61 2d 69 6e 66 6f 20 74 65 73 74 2d 69 64 20 72 a-info test-id r
e9a0: 75 6e 2d 69 64 20 6d 69 6e 75 74 65 73 20 77 6f un-id minutes wo
e9b0: 72 6b 2d 61 72 65 61 20 72 65 6d 74 72 69 65 73 rk-area remtries
e9c0: 29 0a 20 20 28 6c 65 74 2a 20 28 28 63 70 75 6c ). (let* ((cpul
e9d0: 6f 61 64 20 20 28 67 65 74 2d 63 70 75 2d 6c 6f oad (get-cpu-lo
e9e0: 61 64 29 29 0a 09 20 28 64 69 73 6b 66 72 65 65 ad)).. (diskfree
e9f0: 20 28 67 65 74 2d 64 66 20 28 63 75 72 72 65 6e (get-df (curren
ea00: 74 2d 64 69 72 65 63 74 6f 72 79 29 29 29 0a 09 t-directory)))..
ea10: 20 28 72 65 6d 74 72 69 65 73 20 31 30 29 29 0a (remtries 10)).
ea20: 20 20 20 20 28 68 61 6e 64 6c 65 2d 65 78 63 65 (handle-exce
ea30: 70 74 69 6f 6e 73 0a 20 20 20 20 20 65 78 6e 0a ptions. exn.
ea40: 20 20 20 20 20 28 69 66 20 28 3e 20 72 65 6d 74 (if (> remt
ea50: 72 69 65 73 20 30 29 0a 09 20 28 62 65 67 69 6e ries 0).. (begin
ea60: 0a 09 20 20 20 28 70 72 69 6e 74 2d 63 61 6c 6c .. (print-call
ea70: 2d 63 68 61 69 6e 20 28 63 75 72 72 65 6e 74 2d -chain (current-
ea80: 65 72 72 6f 72 2d 70 6f 72 74 29 29 0a 09 20 20 error-port))..
ea90: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e (debug:print-in
eaa0: 66 6f 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f fo 0 *default-lo
eab0: 67 2d 70 6f 72 74 2a 20 22 57 41 52 4e 49 4e 47 g-port* "WARNING
eac0: 3a 20 66 61 69 6c 65 64 20 74 6f 20 73 65 74 20 : failed to set
ead0: 6d 65 74 61 20 69 6e 66 6f 2e 20 57 69 6c 6c 20 meta info. Will
eae0: 74 72 79 20 22 20 72 65 6d 74 72 69 65 73 20 22 try " remtries "
eaf0: 20 6d 6f 72 65 20 74 69 6d 65 73 22 29 0a 09 20 more times")..
eb00: 20 20 28 73 65 74 21 20 72 65 6d 74 72 69 65 73 (set! remtries
eb10: 20 28 2d 20 72 65 6d 74 72 69 65 73 20 31 29 29 (- remtries 1))
eb20: 0a 09 20 20 20 28 74 68 72 65 61 64 2d 73 6c 65 .. (thread-sle
eb30: 65 70 21 20 31 30 29 0a 09 20 20 20 28 74 65 73 ep! 10).. (tes
eb40: 74 73 3a 73 65 74 2d 66 75 6c 6c 2d 6d 65 74 61 ts:set-full-meta
eb50: 2d 69 6e 66 6f 20 64 62 20 74 65 73 74 2d 69 64 -info db test-id
eb60: 20 72 75 6e 2d 69 64 20 6d 69 6e 75 74 65 73 20 run-id minutes
eb70: 77 6f 72 6b 2d 61 72 65 61 20 28 2d 20 72 65 6d work-area (- rem
eb80: 74 72 69 65 73 20 31 29 29 29 0a 09 20 28 6c 65 tries 1))).. (le
eb90: 74 20 28 28 65 72 72 2d 73 74 61 74 75 73 20 28 t ((err-status (
eba0: 28 63 6f 6e 64 69 74 69 6f 6e 2d 70 72 6f 70 65 (condition-prope
ebb0: 72 74 79 2d 61 63 63 65 73 73 6f 72 20 27 73 71 rty-accessor 'sq
ebc0: 6c 69 74 65 33 20 27 73 74 61 74 75 73 20 23 66 lite3 'status #f
ebd0: 29 20 65 78 6e 29 29 29 0a 09 20 20 20 28 64 65 ) exn))).. (de
ebe0: 62 75 67 3a 70 72 69 6e 74 2d 65 72 72 6f 72 20 bug:print-error
ebf0: 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 0 *default-log-p
ec00: 6f 72 74 2a 20 22 74 72 69 65 64 20 66 6f 72 20 ort* "tried for
ec10: 6f 76 65 72 20 61 20 6d 69 6e 75 74 65 20 74 6f over a minute to
ec20: 20 75 70 64 61 74 65 20 6d 65 74 61 20 69 6e 66 update meta inf
ec30: 6f 20 61 6e 64 20 66 61 69 6c 65 64 2e 20 47 69 o and failed. Gi
ec40: 76 69 6e 67 20 75 70 22 29 0a 09 20 20 20 28 64 ving up").. (d
ec50: 65 62 75 67 3a 70 72 69 6e 74 20 30 20 2a 64 65 ebug:print 0 *de
ec60: 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 fault-log-port*
ec70: 22 45 58 43 45 50 54 49 4f 4e 3a 20 64 61 74 61 "EXCEPTION: data
ec80: 62 61 73 65 20 70 72 6f 62 61 62 6c 79 20 6f 76 base probably ov
ec90: 65 72 6c 6f 61 64 65 64 20 6f 72 20 75 6e 72 65 erloaded or unre
eca0: 61 64 61 62 6c 65 2e 22 29 0a 09 20 20 20 28 64 adable.").. (d
ecb0: 65 62 75 67 3a 70 72 69 6e 74 20 30 20 2a 64 65 ebug:print 0 *de
ecc0: 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 fault-log-port*
ecd0: 22 20 6d 65 73 73 61 67 65 3a 20 22 20 28 28 63 " message: " ((c
ece0: 6f 6e 64 69 74 69 6f 6e 2d 70 72 6f 70 65 72 74 ondition-propert
ecf0: 79 2d 61 63 63 65 73 73 6f 72 20 27 65 78 6e 20 y-accessor 'exn
ed00: 27 6d 65 73 73 61 67 65 29 20 65 78 6e 29 29 0a 'message) exn)).
ed10: 09 20 20 20 28 70 72 69 6e 74 20 22 65 78 6e 3d . (print "exn=
ed20: 22 20 28 63 6f 6e 64 69 74 69 6f 6e 2d 3e 6c 69 " (condition->li
ed30: 73 74 20 65 78 6e 29 29 0a 09 20 20 20 28 64 65 st exn)).. (de
ed40: 62 75 67 3a 70 72 69 6e 74 20 30 20 2a 64 65 66 bug:print 0 *def
ed50: 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 ault-log-port* "
ed60: 20 73 74 61 74 75 73 3a 20 20 22 20 28 28 63 6f status: " ((co
ed70: 6e 64 69 74 69 6f 6e 2d 70 72 6f 70 65 72 74 79 ndition-property
ed80: 2d 61 63 63 65 73 73 6f 72 20 27 73 71 6c 69 74 -accessor 'sqlit
ed90: 65 33 20 27 73 74 61 74 75 73 29 20 65 78 6e 29 e3 'status) exn)
eda0: 29 0a 09 20 20 20 28 70 72 69 6e 74 2d 63 61 6c ).. (print-cal
edb0: 6c 2d 63 68 61 69 6e 20 28 63 75 72 72 65 6e 74 l-chain (current
edc0: 2d 65 72 72 6f 72 2d 70 6f 72 74 29 29 29 29 0a -error-port)))).
edd0: 20 20 20 20 20 28 74 65 73 74 73 3a 75 70 64 61 (tests:upda
ede0: 74 65 2d 74 65 73 74 64 61 74 2d 6d 65 74 61 2d te-testdat-meta-
edf0: 69 6e 66 6f 20 64 62 20 74 65 73 74 2d 69 64 20 info db test-id
ee00: 77 6f 72 6b 2d 61 72 65 61 20 63 70 75 6c 6f 61 work-area cpuloa
ee10: 64 20 64 69 73 6b 66 72 65 65 20 6d 69 6e 75 74 d diskfree minut
ee20: 65 73 29 0a 20 20 29 29 29 0a 09 20 0a 3b 3b 3d es). ))).. .;;=
ee30: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
ee40: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
ee50: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
ee60: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
ee70: 3d 3d 3d 3d 3d 0a 3b 3b 20 41 20 52 20 43 20 48 =====.;; A R C H
ee80: 20 49 20 56 20 49 20 4e 20 47 0a 3b 3b 3d 3d 3d I V I N G.;;===
ee90: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
eea0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
eeb0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
eec0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
eed0: 3d 3d 3d 0a 0a 28 64 65 66 69 6e 65 20 28 74 65 ===..(define (te
eee0: 73 74 3a 61 72 63 68 69 76 65 20 64 62 20 74 65 st:archive db te
eef0: 73 74 2d 69 64 29 0a 20 20 23 66 29 0a 0a 28 64 st-id). #f)..(d
ef00: 65 66 69 6e 65 20 28 74 65 73 74 3a 61 72 63 68 efine (test:arch
ef10: 69 76 65 2d 74 65 73 74 73 20 64 62 20 6b 65 79 ive-tests db key
ef20: 6e 61 6d 65 73 20 74 61 72 67 65 74 29 0a 20 20 names target).
ef30: 23 66 29 0a 0a #f)..