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: 23 66 20 61 6c 6c 2d 74 65 73 74 73 2d 72 65 67 #f all-tests-reg
14f0: 69 73 74 72 79 20 27 72 65 74 75 72 6e 2d 70 72 istry 'return-pr
1500: 6f 63 73 29 29 29 0a 20 20 20 20 20 28 6c 65 74 ocs))). (let
1510: 20 28 28 69 6e 73 74 72 20 28 69 66 20 63 6f 6e ((instr (if con
1520: 66 69 67 20 0a 09 09 20 20 20 20 20 20 28 63 6f fig ... (co
1530: 6e 66 69 67 2d 6c 6f 6f 6b 75 70 20 63 6f 6e 66 nfig-lookup conf
1540: 69 67 20 22 72 65 71 75 69 72 65 6d 65 6e 74 73 ig "requirements
1550: 22 20 22 77 61 69 74 6f 6e 22 29 0a 09 09 20 20 " "waiton")...
1560: 20 20 20 20 28 62 65 67 69 6e 20 3b 3b 20 4e 6f (begin ;; No
1570: 20 63 6f 6e 66 69 67 20 6d 65 61 6e 73 20 74 68 config means th
1580: 69 73 20 69 73 20 61 20 6e 6f 6e 2d 65 78 69 73 is is a non-exis
1590: 74 61 6e 74 20 74 65 73 74 0a 09 09 09 28 64 65 tant test....(de
15a0: 62 75 67 3a 70 72 69 6e 74 2d 65 72 72 6f 72 20 bug:print-error
15b0: 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 0 *default-log-p
15c0: 6f 72 74 2a 20 22 6e 6f 6e 2d 65 78 69 73 74 65 ort* "non-existe
15d0: 6e 74 20 72 65 71 75 69 72 65 64 20 74 65 73 74 nt required test
15e0: 20 5c 22 22 20 74 65 73 74 2d 6e 61 6d 65 20 22 \"" test-name "
15f0: 5c 22 22 29 0a 09 09 09 28 65 78 69 74 20 31 29 \"")....(exit 1)
1600: 29 29 29 0a 09 20 20 20 28 69 6e 73 74 72 32 20 ))).. (instr2
1610: 28 69 66 20 63 6f 6e 66 69 67 0a 09 09 20 20 20 (if config...
1620: 20 20 20 20 28 63 6f 6e 66 69 67 2d 6c 6f 6f 6b (config-look
1630: 75 70 20 63 6f 6e 66 69 67 20 22 72 65 71 75 69 up config "requi
1640: 72 65 6d 65 6e 74 73 22 20 22 77 61 69 74 6f 72 rements" "waitor
1650: 22 29 0a 09 09 20 20 20 20 20 20 20 22 22 29 29 ")... ""))
1660: 29 0a 20 20 20 20 20 20 20 28 64 65 62 75 67 3a ). (debug:
1670: 70 72 69 6e 74 2d 69 6e 66 6f 20 38 20 2a 64 65 print-info 8 *de
1680: 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 fault-log-port*
1690: 22 77 61 69 74 6f 6e 73 20 73 74 72 69 6e 67 20 "waitons string
16a0: 69 73 20 22 20 69 6e 73 74 72 20 22 2c 20 77 61 is " instr ", wa
16b0: 69 74 6f 72 73 20 73 74 72 69 6e 67 20 69 73 20 itors string is
16c0: 22 20 69 6e 73 74 72 32 29 0a 20 20 20 20 20 20 " instr2).
16d0: 20 28 6c 65 74 20 28 28 6e 65 77 77 61 69 74 6f (let ((newwaito
16e0: 6e 73 0a 09 20 20 20 20 20 20 28 73 74 72 69 6e ns.. (strin
16f0: 67 2d 73 70 6c 69 74 20 28 63 6f 6e 64 0a 09 09 g-split (cond...
1700: 09 20 20 20 20 20 28 28 70 72 6f 63 65 64 75 72 . ((procedur
1710: 65 3f 20 69 6e 73 74 72 29 20 3b 3b 20 68 65 72 e? instr) ;; her
1720: 65 20 0a 09 09 09 20 20 20 20 20 20 28 6c 65 74 e .... (let
1730: 20 28 28 72 65 73 20 28 69 6e 73 74 72 29 29 29 ((res (instr)))
1740: 0a 09 09 09 09 28 64 65 62 75 67 3a 70 72 69 6e .....(debug:prin
1750: 74 2d 69 6e 66 6f 20 38 20 2a 64 65 66 61 75 6c t-info 8 *defaul
1760: 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 77 61 69 t-log-port* "wai
1770: 74 6f 6e 20 70 72 6f 63 65 64 75 72 65 20 72 65 ton procedure re
1780: 73 75 6c 74 73 20 69 6e 20 73 74 72 69 6e 67 20 sults in string
1790: 22 20 72 65 73 20 22 20 66 6f 72 20 74 65 73 74 " res " for test
17a0: 20 22 20 74 65 73 74 2d 6e 61 6d 65 29 0a 09 09 " test-name)...
17b0: 09 09 72 65 73 29 29 0a 09 09 09 20 20 20 20 20 ..res))....
17c0: 28 28 73 74 72 69 6e 67 3f 20 69 6e 73 74 72 29 ((string? instr)
17d0: 20 20 20 20 20 69 6e 73 74 72 29 0a 09 09 09 20 instr)....
17e0: 20 20 20 20 28 65 6c 73 65 20 0a 09 09 09 20 20 (else ....
17f0: 20 20 20 20 3b 3b 20 4e 4f 54 45 3a 20 54 68 69 ;; NOTE: Thi
1800: 73 20 69 73 20 61 63 74 75 61 6c 6c 79 20 74 68 s is actually th
1810: 65 20 63 61 73 65 20 6f 66 20 2a 6e 6f 2a 20 77 e case of *no* w
1820: 61 69 74 6f 6e 73 21 20 3b 3b 20 28 64 65 62 75 aitons! ;; (debu
1830: 67 3a 70 72 69 6e 74 2d 65 72 72 6f 72 20 30 20 g:print-error 0
1840: 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 *default-log-por
1850: 74 2a 20 22 73 6f 6d 65 74 68 69 6e 67 20 77 65 t* "something we
1860: 6e 74 20 77 72 6f 6e 67 20 69 6e 20 70 72 6f 63 nt wrong in proc
1870: 65 73 73 69 6e 67 20 77 61 69 74 6f 6e 73 20 66 essing waitons f
1880: 6f 72 20 74 65 73 74 20 22 20 74 65 73 74 2d 6e or test " test-n
1890: 61 6d 65 29 0a 09 09 09 20 20 20 20 20 20 22 22 ame).... ""
18a0: 29 29 29 29 0a 09 20 20 20 20 20 28 6e 65 77 77 )))).. (neww
18b0: 61 69 74 6f 72 73 0a 09 20 20 20 20 20 20 28 73 aitors.. (s
18c0: 74 72 69 6e 67 2d 73 70 6c 69 74 20 28 63 6f 6e tring-split (con
18d0: 64 0a 09 09 09 20 20 20 20 20 28 28 70 72 6f 63 d.... ((proc
18e0: 65 64 75 72 65 3f 20 69 6e 73 74 72 32 29 0a 09 edure? instr2)..
18f0: 09 09 20 20 20 20 20 20 28 6c 65 74 20 28 28 72 .. (let ((r
1900: 65 73 20 28 69 6e 73 74 72 32 29 29 29 0a 09 09 es (instr2)))...
1910: 09 09 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 ..(debug:print-i
1920: 6e 66 6f 20 38 20 2a 64 65 66 61 75 6c 74 2d 6c nfo 8 *default-l
1930: 6f 67 2d 70 6f 72 74 2a 20 22 77 61 69 74 6f 72 og-port* "waitor
1940: 20 70 72 6f 63 65 64 75 72 65 20 72 65 73 75 6c procedure resul
1950: 74 73 20 69 6e 20 73 74 72 69 6e 67 20 22 20 72 ts in string " r
1960: 65 73 20 22 20 66 6f 72 20 74 65 73 74 20 22 20 es " for test "
1970: 74 65 73 74 2d 6e 61 6d 65 29 0a 09 09 09 09 72 test-name).....r
1980: 65 73 29 29 0a 09 09 09 20 20 20 20 20 28 28 73 es)).... ((s
1990: 74 72 69 6e 67 3f 20 69 6e 73 74 72 32 29 20 20 tring? instr2)
19a0: 20 20 20 69 6e 73 74 72 32 29 0a 09 09 09 20 20 instr2)....
19b0: 20 20 20 28 65 6c 73 65 20 0a 09 09 09 20 20 20 (else ....
19c0: 20 20 20 3b 3b 20 4e 4f 54 45 3a 20 54 68 69 73 ;; NOTE: This
19d0: 20 69 73 20 61 63 74 75 61 6c 6c 79 20 74 68 65 is actually the
19e0: 20 63 61 73 65 20 6f 66 20 2a 6e 6f 2a 20 77 61 case of *no* wa
19f0: 69 74 6f 6e 73 21 20 3b 3b 20 28 64 65 62 75 67 itons! ;; (debug
1a00: 3a 70 72 69 6e 74 2d 65 72 72 6f 72 20 30 20 2a :print-error 0 *
1a10: 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 default-log-port
1a20: 2a 20 22 73 6f 6d 65 74 68 69 6e 67 20 77 65 6e * "something wen
1a30: 74 20 77 72 6f 6e 67 20 69 6e 20 70 72 6f 63 65 t wrong in proce
1a40: 73 73 69 6e 67 20 77 61 69 74 6f 6e 73 20 66 6f ssing waitons fo
1a50: 72 20 74 65 73 74 20 22 20 74 65 73 74 2d 6e 61 r test " test-na
1a60: 6d 65 29 0a 09 09 09 20 20 20 20 20 20 22 22 29 me).... "")
1a70: 29 29 29 29 0a 09 20 28 76 61 6c 75 65 73 0a 09 )))).. (values..
1a80: 20 20 3b 3b 20 74 68 65 20 77 61 69 74 6f 6e 73 ;; the waitons
1a90: 0a 09 20 20 28 66 69 6c 74 65 72 20 28 6c 61 6d .. (filter (lam
1aa0: 62 64 61 20 28 78 29 0a 09 09 20 20 20 20 28 69 bda (x)... (i
1ab0: 66 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 f (hash-table-re
1ac0: 66 2f 64 65 66 61 75 6c 74 20 61 6c 6c 2d 74 65 f/default all-te
1ad0: 73 74 73 2d 72 65 67 69 73 74 72 79 20 78 20 23 sts-registry x #
1ae0: 66 29 0a 09 09 09 23 74 0a 09 09 09 28 62 65 67 f)....#t....(beg
1af0: 69 6e 0a 09 09 09 20 20 28 64 65 62 75 67 3a 70 in.... (debug:p
1b00: 72 69 6e 74 2d 65 72 72 6f 72 20 30 20 2a 64 65 rint-error 0 *de
1b10: 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 fault-log-port*
1b20: 22 74 65 73 74 20 22 20 74 65 73 74 2d 6e 61 6d "test " test-nam
1b30: 65 20 22 20 68 61 73 20 75 6e 72 65 63 6f 67 6e e " has unrecogn
1b40: 69 73 65 64 20 77 61 69 74 6f 6e 20 74 65 73 74 ised waiton test
1b50: 6e 61 6d 65 20 22 20 78 29 0a 09 09 09 20 20 23 name " x).... #
1b60: 66 29 29 29 0a 09 09 20 20 6e 65 77 77 61 69 74 f)))... newwait
1b70: 6f 6e 73 29 0a 09 20 20 28 66 69 6c 74 65 72 20 ons).. (filter
1b80: 28 6c 61 6d 62 64 61 20 28 78 29 0a 09 09 20 20 (lambda (x)...
1b90: 20 20 28 69 66 20 28 68 61 73 68 2d 74 61 62 6c (if (hash-tabl
1ba0: 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 61 6c e-ref/default al
1bb0: 6c 2d 74 65 73 74 73 2d 72 65 67 69 73 74 72 79 l-tests-registry
1bc0: 20 78 20 23 66 29 0a 09 09 09 23 74 0a 09 09 09 x #f)....#t....
1bd0: 28 62 65 67 69 6e 0a 09 09 09 20 20 28 64 65 62 (begin.... (deb
1be0: 75 67 3a 70 72 69 6e 74 2d 65 72 72 6f 72 20 30 ug:print-error 0
1bf0: 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f *default-log-po
1c00: 72 74 2a 20 22 74 65 73 74 20 22 20 74 65 73 74 rt* "test " test
1c10: 2d 6e 61 6d 65 20 22 20 68 61 73 20 75 6e 72 65 -name " has unre
1c20: 63 6f 67 6e 69 73 65 64 20 77 61 69 74 6f 6e 20 cognised waiton
1c30: 74 65 73 74 6e 61 6d 65 20 22 20 78 29 0a 09 09 testname " x)...
1c40: 09 20 20 23 66 29 29 29 0a 09 09 20 20 6e 65 77 . #f)))... new
1c50: 77 61 69 74 6f 72 73 29 0a 09 20 20 63 6f 6e 66 waitors).. conf
1c60: 69 67 29 29 29 29 29 0a 09 09 09 09 09 20 20 20 ig)))))......
1c70: 20 20 0a 3b 3b 20 67 69 76 65 6e 20 77 61 69 74 .;; given wait
1c80: 69 6e 67 2d 74 65 73 74 20 74 68 61 74 20 69 73 ing-test that is
1c90: 20 77 61 69 74 69 6e 67 20 6f 6e 20 77 61 69 74 waiting on wait
1ca0: 6f 6e 2d 74 65 73 74 20 65 78 74 65 6e 64 20 74 on-test extend t
1cb0: 65 73 74 2d 70 61 74 74 20 61 70 70 72 6f 70 72 est-patt appropr
1cc0: 69 61 74 65 6c 79 0a 3b 3b 0a 3b 3b 20 20 67 65 iately.;;.;; ge
1cd0: 6e 6c 69 62 2f 74 65 73 74 63 6f 6e 66 69 67 20 nlib/testconfig
1ce0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 73 69 si
1cf0: 6d 2f 74 65 73 74 63 6f 6e 66 69 67 0a 3b 3b 20 m/testconfig.;;
1d00: 20 67 65 6e 6c 69 62 2f 73 63 68 20 20 20 20 20 genlib/sch
1d10: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1d20: 20 73 69 6d 2f 73 63 68 2f 63 65 6c 6c 31 0a 3b sim/sch/cell1.;
1d30: 3b 0a 3b 3b 20 20 5b 72 65 71 75 69 72 65 6d 65 ;.;; [requireme
1d40: 6e 74 73 5d 20 20 20 20 20 20 20 20 20 20 20 20 nts]
1d50: 20 20 20 20 20 20 5b 72 65 71 75 69 72 65 6d 65 [requireme
1d60: 6e 74 73 5d 0a 3b 3b 20 20 20 20 20 20 20 20 20 nts].;;
1d70: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1d80: 20 20 20 20 20 20 20 20 20 6d 6f 64 65 20 69 74 mode it
1d90: 65 6d 77 61 69 74 0a 3b 3b 20 20 20 20 20 20 20 emwait.;;
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 20 20 20 23 20 74 72 69 # tri
1dc0: 6d 20 6f 66 66 20 74 68 65 20 63 65 6c 6c 20 74 m off the cell t
1dd0: 6f 20 64 65 74 65 72 6d 69 6e 65 20 77 68 61 74 o determine what
1de0: 20 74 6f 20 72 75 6e 20 66 6f 72 20 67 65 6e 6c to run for genl
1df0: 69 62 0a 3b 3b 20 20 20 20 20 20 20 20 20 20 20 ib.;;
1e00: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1e10: 20 20 20 20 20 20 20 69 74 65 6d 6d 61 70 20 2f itemmap /
1e20: 2e 2a 0a 3b 3b 0a 3b 3b 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 20 20 20 77 61 69 74 69 6e waitin
1e50: 67 2d 74 65 73 74 20 69 73 20 77 61 69 74 69 6e g-test is waitin
1e60: 67 20 6f 6e 20 77 61 69 74 6f 6e 2d 74 65 73 74 g on waiton-test
1e70: 20 73 6f 20 77 65 20 6e 65 65 64 20 74 6f 20 63 so we need to c
1e80: 72 65 61 74 65 20 61 20 70 61 74 74 65 72 6e 20 reate a pattern
1e90: 66 6f 72 20 77 61 69 74 6f 6e 2d 74 65 73 74 20 for waiton-test
1ea0: 67 69 76 65 6e 20 77 61 69 74 69 6e 67 2d 74 65 given waiting-te
1eb0: 73 74 20 61 6e 64 20 69 74 65 6d 6d 61 70 0a 28 st and itemmap.(
1ec0: 64 65 66 69 6e 65 20 28 74 65 73 74 73 3a 65 78 define (tests:ex
1ed0: 74 65 6e 64 2d 74 65 73 74 2d 70 61 74 74 73 20 tend-test-patts
1ee0: 74 65 73 74 2d 70 61 74 74 20 77 61 69 74 69 6e test-patt waitin
1ef0: 67 2d 74 65 73 74 20 77 61 69 74 6f 6e 2d 74 65 g-test waiton-te
1f00: 73 74 20 69 74 65 6d 6d 61 70 73 29 0a 20 20 28 st itemmaps). (
1f10: 6c 65 74 2a 20 28 28 69 74 65 6d 6d 61 70 20 20 let* ((itemmap
1f20: 20 20 20 20 20 20 20 20 28 74 65 73 74 73 3a 6c (tests:l
1f30: 6f 6f 6b 75 70 2d 69 74 65 6d 6d 61 70 20 69 74 ookup-itemmap it
1f40: 65 6d 6d 61 70 73 20 77 61 69 74 6f 6e 2d 74 65 emmaps waiton-te
1f50: 73 74 29 29 0a 09 20 28 70 61 74 74 73 20 20 20 st)).. (patts
1f60: 20 20 20 20 20 20 20 20 20 28 73 74 72 69 6e 67 (string
1f70: 2d 73 70 6c 69 74 20 74 65 73 74 2d 70 61 74 74 -split test-patt
1f80: 20 22 2c 22 29 29 0a 09 20 28 77 61 69 74 69 6e ",")).. (waitin
1f90: 67 2d 74 65 73 74 2d 6c 65 6e 20 28 2b 20 28 73 g-test-len (+ (s
1fa0: 74 72 69 6e 67 2d 6c 65 6e 67 74 68 20 77 61 69 tring-length wai
1fb0: 74 69 6e 67 2d 74 65 73 74 29 20 31 29 29 0a 09 ting-test) 1))..
1fc0: 20 28 70 61 74 74 73 2d 77 61 69 74 6f 6e 20 20 (patts-waiton
1fd0: 20 20 20 28 6d 61 70 20 28 6c 61 6d 62 64 61 20 (map (lambda
1fe0: 28 78 29 20 20 3b 3b 20 66 6f 72 20 65 61 63 68 (x) ;; for each
1ff0: 20 69 6e 63 6f 6d 69 6e 67 20 70 61 74 74 20 74 incoming patt t
2000: 68 61 74 20 6d 61 74 63 68 65 73 20 74 68 65 20 hat matches the
2010: 77 61 69 74 69 6e 67 20 74 65 73 74 0a 09 09 09 waiting test....
2020: 09 20 20 28 6c 65 74 2a 20 28 28 6d 6f 64 70 61 . (let* ((modpa
2030: 74 74 20 28 69 66 20 69 74 65 6d 6d 61 70 20 28 tt (if itemmap (
2040: 64 62 3a 63 6f 6e 76 65 72 74 2d 74 65 73 74 2d db:convert-test-
2050: 69 74 65 6d 70 61 74 68 20 78 20 69 74 65 6d 6d itempath x itemm
2060: 61 70 29 20 78 29 29 20 0a 09 09 09 09 09 20 28 ap) x)) ...... (
2070: 6e 65 77 70 61 74 74 20 28 63 6f 6e 63 20 77 61 newpatt (conc wa
2080: 69 74 6f 6e 2d 74 65 73 74 20 22 2f 22 20 28 73 iton-test "/" (s
2090: 75 62 73 74 72 69 6e 67 20 6d 6f 64 70 61 74 74 ubstring modpatt
20a0: 20 77 61 69 74 69 6e 67 2d 74 65 73 74 2d 6c 65 waiting-test-le
20b0: 6e 20 28 73 74 72 69 6e 67 2d 6c 65 6e 67 74 68 n (string-length
20c0: 20 6d 6f 64 70 61 74 74 29 29 29 29 29 0a 09 09 modpatt)))))...
20d0: 09 09 20 20 20 20 3b 3b 20 28 63 6f 6e 63 20 77 .. ;; (conc w
20e0: 61 69 74 69 6e 67 2d 74 65 73 74 20 22 2f 2c 22 aiting-test "/,"
20f0: 20 77 61 69 74 69 6e 67 2d 74 65 73 74 20 22 2f waiting-test "/
2100: 22 20 28 73 75 62 73 74 72 69 6e 67 20 6d 6f 64 " (substring mod
2110: 70 61 74 74 20 77 61 69 74 6f 6e 2d 74 65 73 74 patt waiton-test
2120: 2d 6c 65 6e 20 28 73 74 72 69 6e 67 2d 6c 65 6e -len (string-len
2130: 67 74 68 20 6d 6f 64 70 61 74 74 29 29 29 29 29 gth modpatt)))))
2140: 0a 09 09 09 09 20 20 20 20 3b 3b 20 28 70 72 69 ..... ;; (pri
2150: 6e 74 20 22 69 6e 20 6d 61 70 2c 20 78 3d 22 20 nt "in map, x="
2160: 78 20 22 2c 20 6e 65 77 70 61 74 74 3d 22 20 6e x ", newpatt=" n
2170: 65 77 70 61 74 74 29 0a 09 09 09 09 20 20 20 20 ewpatt).....
2180: 6e 65 77 70 61 74 74 29 29 0a 09 09 09 09 28 66 newpatt)).....(f
2190: 69 6c 74 65 72 20 28 6c 61 6d 62 64 61 20 28 78 ilter (lambda (x
21a0: 29 0a 09 09 09 09 09 20 20 28 65 71 3f 20 28 73 )...... (eq? (s
21b0: 75 62 73 74 72 69 6e 67 2d 69 6e 64 65 78 20 28 ubstring-index (
21c0: 63 6f 6e 63 20 77 61 69 74 69 6e 67 2d 74 65 73 conc waiting-tes
21d0: 74 20 22 2f 22 29 20 78 29 20 30 29 29 20 3b 3b t "/") x) 0)) ;;
21e0: 20 69 73 20 74 68 69 73 20 70 61 74 74 20 70 65 is this patt pe
21f0: 72 74 69 6e 65 6e 74 20 74 6f 20 74 68 65 20 77 rtinent to the w
2200: 61 69 74 69 6e 67 20 74 65 73 74 0a 09 09 09 09 aiting test.....
2210: 09 70 61 74 74 73 29 29 29 29 0a 20 20 20 20 28 .patts)))). (
2220: 73 74 72 69 6e 67 2d 69 6e 74 65 72 73 70 65 72 string-intersper
2230: 73 65 20 28 64 65 6c 65 74 65 2d 64 75 70 6c 69 se (delete-dupli
2240: 63 61 74 65 73 20 28 61 70 70 65 6e 64 20 70 61 cates (append pa
2250: 74 74 73 20 28 69 66 20 28 6e 75 6c 6c 3f 20 70 tts (if (null? p
2260: 61 74 74 73 2d 77 61 69 74 6f 6e 29 0a 09 09 09 atts-waiton)....
2270: 09 09 09 09 20 20 20 20 20 28 6c 69 73 74 20 28 .... (list (
2280: 63 6f 6e 63 20 77 61 69 74 6f 6e 2d 74 65 73 74 conc waiton-test
2290: 20 22 2f 25 22 29 29 20 3b 3b 20 72 65 61 6c 6c "/%")) ;; reall
22a0: 79 20 73 68 6f 75 6c 64 6e 27 74 20 61 64 64 20 y shouldn't add
22b0: 74 68 65 20 77 61 69 74 6f 6e 20 66 6f 72 63 65 the waiton force
22c0: 66 75 6c 6c 79 20 6c 69 6b 65 20 74 68 69 73 0a fully like this.
22d0: 09 09 09 09 09 09 09 20 20 20 20 20 70 61 74 74 ....... patt
22e0: 73 2d 77 61 69 74 6f 6e 29 29 29 0a 09 09 09 22 s-waiton)))...."
22f0: 2c 22 29 29 29 0a 0a 0a 20 20 0a 3b 3b 20 74 65 ,")))... .;; te
2300: 73 74 73 3a 67 6c 6f 62 2d 6c 69 6b 65 2d 6d 61 sts:glob-like-ma
2310: 74 63 68 20 0a 28 64 65 66 69 6e 65 20 28 74 65 tch .(define (te
2320: 73 74 73 3a 67 6c 6f 62 2d 6c 69 6b 65 2d 6d 61 sts:glob-like-ma
2330: 74 63 68 20 70 61 74 74 20 73 74 72 29 20 0a 20 tch patt str) .
2340: 20 28 6c 65 74 20 28 28 6c 69 6b 65 20 28 73 75 (let ((like (su
2350: 62 73 74 72 69 6e 67 2d 69 6e 64 65 78 20 22 25 bstring-index "%
2360: 22 20 70 61 74 74 29 29 29 0a 20 20 20 20 28 6c " patt))). (l
2370: 65 74 2a 20 28 28 6e 6f 74 70 61 74 74 20 20 28 et* ((notpatt (
2380: 65 71 75 61 6c 3f 20 28 73 75 62 73 74 72 69 6e equal? (substrin
2390: 67 2d 69 6e 64 65 78 20 22 7e 22 20 70 61 74 74 g-index "~" patt
23a0: 29 20 30 29 29 0a 09 20 20 20 28 6e 65 77 70 61 ) 0)).. (newpa
23b0: 74 74 20 20 28 69 66 20 6e 6f 74 70 61 74 74 20 tt (if notpatt
23c0: 28 73 75 62 73 74 72 69 6e 67 20 70 61 74 74 20 (substring patt
23d0: 31 29 20 70 61 74 74 29 29 0a 09 20 20 20 28 66 1) patt)).. (f
23e0: 69 6e 70 61 74 74 20 20 28 69 66 20 6c 69 6b 65 inpatt (if like
23f0: 0a 09 09 09 28 73 74 72 69 6e 67 2d 73 75 62 73 ....(string-subs
2400: 74 69 74 75 74 65 20 28 72 65 67 65 78 70 20 22 titute (regexp "
2410: 25 22 29 20 22 2e 2a 22 20 6e 65 77 70 61 74 74 %") ".*" newpatt
2420: 20 23 66 29 0a 09 09 09 28 73 74 72 69 6e 67 2d #f)....(string-
2430: 73 75 62 73 74 69 74 75 74 65 20 28 72 65 67 65 substitute (rege
2440: 78 70 20 22 5c 5c 2a 22 29 20 22 2e 2a 22 20 6e xp "\\*") ".*" n
2450: 65 77 70 61 74 74 20 23 66 29 29 29 0a 09 20 20 ewpatt #f)))..
2460: 20 28 72 65 73 20 20 20 20 20 20 23 66 29 29 0a (res #f)).
2470: 20 20 20 20 20 20 3b 3b 20 28 70 72 69 6e 74 20 ;; (print
2480: 22 74 65 73 74 73 3a 67 6c 6f 62 2d 6c 69 6b 65 "tests:glob-like
2490: 2d 6d 61 74 63 68 20 3d 3e 20 6e 6f 74 70 61 74 -match => notpat
24a0: 74 3a 20 22 20 6e 6f 74 70 61 74 74 20 22 2c 20 t: " notpatt ",
24b0: 6e 65 77 70 61 74 74 3a 20 22 20 6e 65 77 70 61 newpatt: " newpa
24c0: 74 74 20 22 2c 20 66 69 6e 70 61 74 74 3a 20 22 tt ", finpatt: "
24d0: 20 66 69 6e 70 61 74 74 29 0a 20 20 20 20 20 20 finpatt).
24e0: 28 73 65 74 21 20 72 65 73 20 28 73 74 72 69 6e (set! res (strin
24f0: 67 2d 6d 61 74 63 68 20 28 72 65 67 65 78 70 20 g-match (regexp
2500: 66 69 6e 70 61 74 74 20 28 69 66 20 6c 69 6b 65 finpatt (if like
2510: 20 23 74 20 23 66 29 29 20 73 74 72 29 29 0a 20 #t #f)) str)).
2520: 20 20 20 20 20 28 69 66 20 6e 6f 74 70 61 74 74 (if notpatt
2530: 20 28 6e 6f 74 20 72 65 73 29 20 72 65 73 29 29 (not res) res))
2540: 29 29 0a 0a 3b 3b 20 69 66 20 69 74 65 6d 70 61 ))..;; if itempa
2550: 74 68 20 69 73 20 23 66 20 74 68 65 6e 20 6c 6f th is #f then lo
2560: 6f 6b 20 6f 6e 6c 79 20 61 74 20 74 68 65 20 74 ok only at the t
2570: 65 73 74 6e 61 6d 65 20 70 61 72 74 0a 3b 3b 0a estname part.;;.
2580: 28 64 65 66 69 6e 65 20 28 74 65 73 74 73 3a 6d (define (tests:m
2590: 61 74 63 68 20 70 61 74 74 65 72 6e 73 20 74 65 atch patterns te
25a0: 73 74 6e 61 6d 65 20 69 74 65 6d 70 61 74 68 20 stname itempath
25b0: 23 21 6b 65 79 20 28 72 65 71 75 69 72 65 64 20 #!key (required
25c0: 27 28 29 29 29 0a 20 20 28 69 66 20 28 73 74 72 '())). (if (str
25d0: 69 6e 67 3f 20 70 61 74 74 65 72 6e 73 29 0a 20 ing? patterns).
25e0: 20 20 20 20 20 28 6c 65 74 20 28 28 70 61 74 74 (let ((patt
25f0: 73 20 28 61 70 70 65 6e 64 20 28 73 74 72 69 6e s (append (strin
2600: 67 2d 73 70 6c 69 74 20 70 61 74 74 65 72 6e 73 g-split patterns
2610: 20 22 2c 22 29 20 72 65 71 75 69 72 65 64 29 29 ",") required))
2620: 29 0a 09 28 69 66 20 28 6e 75 6c 6c 3f 20 70 61 )..(if (null? pa
2630: 74 74 73 29 20 3b 3b 3b 20 6e 6f 20 70 61 74 74 tts) ;;; no patt
2640: 65 72 6e 28 73 29 20 6d 65 61 6e 73 20 6e 6f 20 ern(s) means no
2650: 6d 61 74 63 68 0a 09 20 20 20 20 23 66 0a 09 20 match.. #f..
2660: 20 20 20 28 6c 65 74 20 6c 6f 6f 70 20 28 28 70 (let loop ((p
2670: 61 74 74 20 28 63 61 72 20 70 61 74 74 73 29 29 att (car patts))
2680: 0a 09 09 20 20 20 20 20 20 20 28 74 61 6c 20 20 ... (tal
2690: 28 63 64 72 20 70 61 74 74 73 29 29 29 0a 09 20 (cdr patts)))..
26a0: 20 20 20 20 20 3b 3b 20 28 70 72 69 6e 74 20 22 ;; (print "
26b0: 6c 6f 6f 70 3a 20 70 61 74 74 3a 20 22 20 70 61 loop: patt: " pa
26c0: 74 74 20 22 2c 20 74 61 6c 20 22 20 74 61 6c 29 tt ", tal " tal)
26d0: 0a 09 20 20 20 20 20 20 28 69 66 20 28 73 74 72 .. (if (str
26e0: 69 6e 67 3d 3f 20 70 61 74 74 20 22 22 29 0a 09 ing=? patt "")..
26f0: 09 20 20 23 66 20 3b 3b 20 6e 6f 74 68 69 6e 67 . #f ;; nothing
2700: 20 65 76 65 72 20 6d 61 74 63 68 65 73 20 65 6d ever matches em
2710: 70 74 79 20 73 74 72 69 6e 67 20 2d 20 70 6f 6c pty string - pol
2720: 69 63 79 0a 09 09 20 20 28 6c 65 74 2a 20 28 28 icy... (let* ((
2730: 70 61 74 74 2d 70 61 72 74 73 20 28 73 74 72 69 patt-parts (stri
2740: 6e 67 2d 6d 61 74 63 68 20 28 72 65 67 65 78 70 ng-match (regexp
2750: 20 22 5e 28 5b 5e 5c 5c 2f 5d 2a 29 28 5c 5c 2f "^([^\\/]*)(\\/
2760: 28 2e 2a 29 7c 29 24 22 29 20 70 61 74 74 29 29 (.*)|)$") patt))
2770: 0a 09 09 09 20 28 74 65 73 74 2d 70 61 74 74 20 .... (test-patt
2780: 20 28 63 61 64 72 20 70 61 74 74 2d 70 61 72 74 (cadr patt-part
2790: 73 29 29 0a 09 09 09 20 28 69 74 65 6d 2d 70 61 s)).... (item-pa
27a0: 74 74 20 20 28 63 61 64 64 64 72 20 70 61 74 74 tt (cadddr patt
27b0: 2d 70 61 72 74 73 29 29 29 0a 09 09 20 20 20 20 -parts)))...
27c0: 3b 3b 20 73 70 65 63 69 61 6c 20 63 61 73 65 3a ;; special case:
27d0: 20 74 65 73 74 20 76 73 2e 20 74 65 73 74 2f 0a test vs. test/.
27e0: 09 09 20 20 20 20 3b 3b 20 20 20 74 65 73 74 20 .. ;; test
27f0: 20 3d 3e 20 22 74 65 73 74 22 20 22 25 22 0a 09 => "test" "%"..
2800: 09 20 20 20 20 3b 3b 20 20 20 74 65 73 74 2f 20 . ;; test/
2810: 3d 3e 20 22 74 65 73 74 22 20 22 22 0a 09 09 20 => "test" ""...
2820: 20 20 20 28 69 66 20 28 61 6e 64 20 28 6e 6f 74 (if (and (not
2830: 20 28 73 75 62 73 74 72 69 6e 67 2d 69 6e 64 65 (substring-inde
2840: 78 20 22 2f 22 20 70 61 74 74 29 29 20 3b 3b 20 x "/" patt)) ;;
2850: 6e 6f 20 73 6c 61 73 68 20 69 6e 20 74 68 65 20 no slash in the
2860: 6f 72 69 67 69 6e 61 6c 0a 09 09 09 20 20 20 20 original....
2870: 20 28 6f 72 20 28 6e 6f 74 20 69 74 65 6d 2d 70 (or (not item-p
2880: 61 74 74 29 0a 09 09 09 09 20 28 65 71 75 61 6c att)..... (equal
2890: 3f 20 69 74 65 6d 2d 70 61 74 74 20 22 22 29 29 ? item-patt ""))
28a0: 29 20 20 20 20 20 20 3b 3b 20 73 68 6f 75 6c 64 ) ;; should
28b0: 20 61 6c 77 61 79 73 20 62 65 20 74 72 75 65 20 always be true
28c0: 74 68 61 74 20 69 74 65 6d 2d 70 61 74 74 20 69 that item-patt i
28d0: 73 20 22 22 0a 09 09 09 28 73 65 74 21 20 69 74 s ""....(set! it
28e0: 65 6d 2d 70 61 74 74 20 22 25 22 29 29 0a 09 09 em-patt "%"))...
28f0: 20 20 20 20 3b 3b 20 28 70 72 69 6e 74 20 22 74 ;; (print "t
2900: 65 73 74 73 3a 6d 61 74 63 68 20 3d 3e 20 70 61 ests:match => pa
2910: 74 74 2d 70 61 72 74 73 3a 20 22 20 70 61 74 74 tt-parts: " patt
2920: 2d 70 61 72 74 73 20 22 2c 20 74 65 73 74 2d 70 -parts ", test-p
2930: 61 74 74 3a 20 22 20 74 65 73 74 2d 70 61 74 74 att: " test-patt
2940: 20 22 2c 20 69 74 65 6d 2d 70 61 74 74 3a 20 22 ", item-patt: "
2950: 20 69 74 65 6d 2d 70 61 74 74 29 0a 09 09 20 20 item-patt)...
2960: 20 20 28 69 66 20 28 61 6e 64 20 28 74 65 73 74 (if (and (test
2970: 73 3a 67 6c 6f 62 2d 6c 69 6b 65 2d 6d 61 74 63 s:glob-like-matc
2980: 68 20 74 65 73 74 2d 70 61 74 74 20 74 65 73 74 h test-patt test
2990: 6e 61 6d 65 29 0a 09 09 09 20 20 20 20 20 28 6f name).... (o
29a0: 72 20 28 6e 6f 74 20 69 74 65 6d 70 61 74 68 29 r (not itempath)
29b0: 0a 09 09 09 09 20 28 74 65 73 74 73 3a 67 6c 6f ..... (tests:glo
29c0: 62 2d 6c 69 6b 65 2d 6d 61 74 63 68 20 28 69 66 b-like-match (if
29d0: 20 69 74 65 6d 2d 70 61 74 74 20 69 74 65 6d 2d item-patt item-
29e0: 70 61 74 74 20 22 22 29 20 69 74 65 6d 70 61 74 patt "") itempat
29f0: 68 29 29 29 0a 09 09 09 23 74 0a 09 09 09 28 69 h)))....#t....(i
2a00: 66 20 28 6e 75 6c 6c 3f 20 74 61 6c 29 0a 09 09 f (null? tal)...
2a10: 09 20 20 20 20 23 66 0a 09 09 09 20 20 20 20 28 . #f.... (
2a20: 6c 6f 6f 70 20 28 63 61 72 20 74 61 6c 29 28 63 loop (car tal)(c
2a30: 64 72 20 74 61 6c 29 29 29 29 29 29 29 29 29 29 dr tal))))))))))
2a40: 29 0a 0a 3b 3b 20 69 66 20 69 74 65 6d 70 61 74 )..;; if itempat
2a50: 68 20 69 73 20 23 66 20 74 68 65 6e 20 6c 6f 6f h is #f then loo
2a60: 6b 20 6f 6e 6c 79 20 61 74 20 74 68 65 20 74 65 k only at the te
2a70: 73 74 6e 61 6d 65 20 70 61 72 74 0a 3b 3b 0a 28 stname part.;;.(
2a80: 64 65 66 69 6e 65 20 28 74 65 73 74 73 3a 6d 61 define (tests:ma
2a90: 74 63 68 2d 3e 73 71 6c 71 72 79 20 70 61 74 74 tch->sqlqry patt
2aa0: 65 72 6e 73 29 0a 20 20 28 69 66 20 28 73 74 72 erns). (if (str
2ab0: 69 6e 67 3f 20 70 61 74 74 65 72 6e 73 29 0a 20 ing? patterns).
2ac0: 20 20 20 20 20 28 6c 65 74 20 28 28 70 61 74 74 (let ((patt
2ad0: 73 20 28 73 74 72 69 6e 67 2d 73 70 6c 69 74 20 s (string-split
2ae0: 70 61 74 74 65 72 6e 73 20 22 2c 22 29 29 29 0a patterns ","))).
2af0: 09 28 69 66 20 28 6e 75 6c 6c 3f 20 70 61 74 74 .(if (null? patt
2b00: 73 29 20 3b 3b 3b 20 6e 6f 20 70 61 74 74 65 72 s) ;;; no patter
2b10: 6e 28 73 29 20 6d 65 61 6e 73 20 6e 6f 20 6d 61 n(s) means no ma
2b20: 74 63 68 2c 20 77 65 20 77 69 6c 6c 20 64 6f 20 tch, we will do
2b30: 6e 6f 20 71 75 65 72 79 0a 09 20 20 20 20 23 66 no query.. #f
2b40: 0a 09 20 20 20 20 28 6c 65 74 20 6c 6f 6f 70 20 .. (let loop
2b50: 28 28 70 61 74 74 20 28 63 61 72 20 70 61 74 74 ((patt (car patt
2b60: 73 29 29 0a 09 09 20 20 20 20 20 20 20 28 74 61 s))... (ta
2b70: 6c 20 20 28 63 64 72 20 70 61 74 74 73 29 29 0a l (cdr patts)).
2b80: 09 09 20 20 20 20 20 20 20 28 72 65 73 20 20 27 .. (res '
2b90: 28 29 29 29 0a 09 20 20 20 20 20 20 3b 3b 20 28 ())).. ;; (
2ba0: 70 72 69 6e 74 20 22 6c 6f 6f 70 3a 20 70 61 74 print "loop: pat
2bb0: 74 3a 20 22 20 70 61 74 74 20 22 2c 20 74 61 6c t: " patt ", tal
2bc0: 20 22 20 74 61 6c 29 0a 09 20 20 20 20 20 20 28 " tal).. (
2bd0: 6c 65 74 2a 20 28 28 70 61 74 74 2d 70 61 72 74 let* ((patt-part
2be0: 73 20 28 73 74 72 69 6e 67 2d 6d 61 74 63 68 20 s (string-match
2bf0: 28 72 65 67 65 78 70 20 22 5e 28 5b 5e 5c 5c 2f (regexp "^([^\\/
2c00: 5d 2a 29 28 5c 5c 2f 28 2e 2a 29 7c 29 24 22 29 ]*)(\\/(.*)|)$")
2c10: 20 70 61 74 74 29 29 0a 09 09 20 20 20 20 20 28 patt))... (
2c20: 74 65 73 74 2d 70 61 74 74 20 20 28 63 61 64 72 test-patt (cadr
2c30: 20 70 61 74 74 2d 70 61 72 74 73 29 29 0a 09 09 patt-parts))...
2c40: 20 20 20 20 20 28 69 74 65 6d 2d 70 61 74 74 20 (item-patt
2c50: 20 28 63 61 64 64 64 72 20 70 61 74 74 2d 70 61 (cadddr patt-pa
2c60: 72 74 73 29 29 0a 09 09 20 20 20 20 20 28 74 65 rts))... (te
2c70: 73 74 2d 71 72 79 20 20 20 28 64 62 3a 70 61 74 st-qry (db:pat
2c80: 74 2d 3e 6c 69 6b 65 20 22 74 65 73 74 6e 61 6d t->like "testnam
2c90: 65 22 20 74 65 73 74 2d 70 61 74 74 29 29 0a 09 e" test-patt))..
2ca0: 09 20 20 20 20 20 28 69 74 65 6d 2d 71 72 79 20 . (item-qry
2cb0: 20 20 28 64 62 3a 70 61 74 74 2d 3e 6c 69 6b 65 (db:patt->like
2cc0: 20 22 69 74 65 6d 5f 70 61 74 68 22 20 69 74 65 "item_path" ite
2cd0: 6d 2d 70 61 74 74 29 29 0a 09 09 20 20 20 20 20 m-patt))...
2ce0: 28 71 72 79 20 20 20 20 20 20 20 20 28 63 6f 6e (qry (con
2cf0: 63 20 22 28 22 20 74 65 73 74 2d 71 72 79 20 22 c "(" test-qry "
2d00: 20 41 4e 44 20 22 20 69 74 65 6d 2d 71 72 79 20 AND " item-qry
2d10: 22 29 22 29 29 29 0a 09 09 3b 3b 20 28 70 72 69 ")")))...;; (pri
2d20: 6e 74 20 22 74 65 73 74 73 3a 6d 61 74 63 68 20 nt "tests:match
2d30: 3d 3e 20 70 61 74 74 2d 70 61 72 74 73 3a 20 22 => patt-parts: "
2d40: 20 70 61 74 74 2d 70 61 72 74 73 20 22 2c 20 74 patt-parts ", t
2d50: 65 73 74 2d 70 61 74 74 3a 20 22 20 74 65 73 74 est-patt: " test
2d60: 2d 70 61 74 74 20 22 2c 20 69 74 65 6d 2d 70 61 -patt ", item-pa
2d70: 74 74 3a 20 22 20 69 74 65 6d 2d 70 61 74 74 29 tt: " item-patt)
2d80: 0a 09 09 28 69 66 20 28 6e 75 6c 6c 3f 20 74 61 ...(if (null? ta
2d90: 6c 29 0a 09 09 20 20 20 20 28 73 74 72 69 6e 67 l)... (string
2da0: 2d 69 6e 74 65 72 73 70 65 72 73 65 20 28 61 70 -intersperse (ap
2db0: 70 65 6e 64 20 28 72 65 76 65 72 73 65 20 72 65 pend (reverse re
2dc0: 73 29 28 6c 69 73 74 20 71 72 79 29 29 20 22 20 s)(list qry)) "
2dd0: 4f 52 20 22 29 0a 09 09 20 20 20 20 28 6c 6f 6f OR ")... (loo
2de0: 70 20 28 63 61 72 20 74 61 6c 29 28 63 64 72 20 p (car tal)(cdr
2df0: 74 61 6c 29 28 63 6f 6e 73 20 71 72 79 20 72 65 tal)(cons qry re
2e00: 73 29 29 29 29 29 29 29 0a 20 20 20 20 20 20 23 s))))))). #
2e10: 66 29 29 0a 0a 3b 3b 20 43 68 65 63 6b 20 66 6f f))..;; Check fo
2e20: 72 20 77 61 69 76 65 72 20 65 6c 69 67 69 62 69 r waiver eligibi
2e30: 6c 69 74 79 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 lity.;;.(define
2e40: 28 74 65 73 74 73 3a 63 68 65 63 6b 2d 77 61 69 (tests:check-wai
2e50: 76 65 72 2d 65 6c 69 67 69 62 69 6c 69 74 79 20 ver-eligibility
2e60: 74 65 73 74 64 61 74 20 70 72 65 76 2d 74 65 73 testdat prev-tes
2e70: 74 64 61 74 29 0a 20 20 28 6c 65 74 2a 20 28 28 tdat). (let* ((
2e80: 74 65 73 74 2d 72 65 67 69 73 74 72 79 20 28 6d test-registry (m
2e90: 61 6b 65 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 ake-hash-table))
2ea0: 0a 09 20 28 74 65 73 74 63 6f 6e 66 69 67 20 20 .. (testconfig
2eb0: 28 74 65 73 74 73 3a 67 65 74 2d 74 65 73 74 63 (tests:get-testc
2ec0: 6f 6e 66 69 67 20 28 64 62 3a 74 65 73 74 2d 67 onfig (db:test-g
2ed0: 65 74 2d 74 65 73 74 6e 61 6d 65 20 74 65 73 74 et-testname test
2ee0: 64 61 74 29 20 28 64 62 3a 74 65 73 74 2d 67 65 dat) (db:test-ge
2ef0: 74 2d 69 74 65 6d 2d 70 61 74 68 20 74 65 73 74 t-item-path test
2f00: 64 61 74 29 20 74 65 73 74 2d 72 65 67 69 73 74 dat) test-regist
2f10: 72 79 20 23 66 29 29 0a 09 20 28 74 65 73 74 2d ry #f)).. (test-
2f20: 72 75 6e 64 69 72 20 3b 3b 20 28 73 64 62 3a 71 rundir ;; (sdb:q
2f30: 72 79 20 27 70 61 73 73 73 74 72 20 0a 09 20 20 ry 'passstr ..
2f40: 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 72 75 6e (db:test-get-run
2f50: 64 69 72 20 74 65 73 74 64 61 74 29 29 20 3b 3b dir testdat)) ;;
2f60: 20 29 0a 09 20 28 70 72 65 76 2d 72 75 6e 64 69 ).. (prev-rundi
2f70: 72 20 3b 3b 20 28 73 64 62 3a 71 72 79 20 27 70 r ;; (sdb:qry 'p
2f80: 61 73 73 73 74 72 20 0a 09 20 20 28 64 62 3a 74 assstr .. (db:t
2f90: 65 73 74 2d 67 65 74 2d 72 75 6e 64 69 72 20 70 est-get-rundir p
2fa0: 72 65 76 2d 74 65 73 74 64 61 74 29 29 20 3b 3b rev-testdat)) ;;
2fb0: 20 29 0a 09 20 28 77 61 69 76 65 72 73 20 20 20 ).. (waivers
2fc0: 20 20 28 69 66 20 74 65 73 74 63 6f 6e 66 69 67 (if testconfig
2fd0: 20 28 63 6f 6e 66 69 67 66 3a 73 65 63 74 69 6f (configf:sectio
2fe0: 6e 2d 76 61 72 73 20 74 65 73 74 63 6f 6e 66 69 n-vars testconfi
2ff0: 67 20 22 77 61 69 76 65 72 73 22 29 20 27 28 29 g "waivers") '()
3000: 29 29 0a 09 20 28 77 61 69 76 65 72 2d 72 78 20 )).. (waiver-rx
3010: 20 20 28 72 65 67 65 78 70 20 22 5e 28 5c 5c 53 (regexp "^(\\S
3020: 2b 29 5c 5c 73 2b 28 2e 2a 29 24 22 29 29 0a 09 +)\\s+(.*)$"))..
3030: 20 28 64 69 66 66 2d 72 75 6c 65 20 20 20 22 64 (diff-rule "d
3040: 69 66 66 20 25 66 69 6c 65 31 25 20 25 66 69 6c iff %file1% %fil
3050: 65 32 25 22 29 0a 09 20 28 6c 6f 67 70 72 6f 2d e2%").. (logpro-
3060: 72 75 6c 65 20 22 64 69 66 66 20 25 66 69 6c 65 rule "diff %file
3070: 31 25 20 25 66 69 6c 65 32 25 20 7c 20 6c 6f 67 1% %file2% | log
3080: 70 72 6f 20 25 77 61 69 76 65 72 6e 61 6d 65 25 pro %waivername%
3090: 2e 6c 6f 67 70 72 6f 20 25 77 61 69 76 65 72 6e .logpro %waivern
30a0: 61 6d 65 25 2e 68 74 6d 6c 22 29 29 0a 20 20 20 ame%.html")).
30b0: 20 28 69 66 20 28 6e 6f 74 20 28 66 69 6c 65 2d (if (not (file-
30c0: 65 78 69 73 74 73 3f 20 74 65 73 74 2d 72 75 6e exists? test-run
30d0: 64 69 72 29 29 0a 09 28 62 65 67 69 6e 0a 09 20 dir))..(begin..
30e0: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 65 72 (debug:print-er
30f0: 72 6f 72 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c ror 0 *default-l
3100: 6f 67 2d 70 6f 72 74 2a 20 22 74 65 73 74 20 72 og-port* "test r
3110: 75 6e 20 64 69 72 65 63 74 6f 72 79 20 69 73 20 un directory is
3120: 67 6f 6e 65 2c 20 63 61 6e 6e 6f 74 20 70 72 6f gone, cannot pro
3130: 70 61 67 61 74 65 20 77 61 69 76 65 72 22 29 0a pagate waiver").
3140: 09 20 20 23 66 29 0a 09 28 62 65 67 69 6e 0a 09 . #f)..(begin..
3150: 20 20 28 70 75 73 68 2d 64 69 72 65 63 74 6f 72 (push-director
3160: 79 20 74 65 73 74 2d 72 75 6e 64 69 72 29 0a 09 y test-rundir)..
3170: 20 20 28 6c 65 74 20 28 28 72 65 73 75 6c 74 20 (let ((result
3180: 28 69 66 20 28 6e 75 6c 6c 3f 20 77 61 69 76 65 (if (null? waive
3190: 72 73 29 0a 09 09 09 20 20 20 20 23 66 0a 09 09 rs).... #f...
31a0: 09 20 20 20 20 28 6c 65 74 20 6c 6f 6f 70 20 28 . (let loop (
31b0: 28 68 65 64 20 28 63 61 72 20 77 61 69 76 65 72 (hed (car waiver
31c0: 73 29 29 0a 09 09 09 09 20 20 20 20 20 20 20 28 s))..... (
31d0: 74 61 6c 20 28 63 64 72 20 77 61 69 76 65 72 73 tal (cdr waivers
31e0: 29 29 29 0a 09 09 09 20 20 20 20 20 20 28 64 65 ))).... (de
31f0: 62 75 67 3a 70 72 69 6e 74 20 30 20 2a 64 65 66 bug:print 0 *def
3200: 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 ault-log-port* "
3210: 49 4e 46 4f 3a 20 41 70 70 6c 79 69 6e 67 20 77 INFO: Applying w
3220: 61 69 76 65 72 20 72 75 6c 65 20 5c 22 22 20 68 aiver rule \"" h
3230: 65 64 20 22 5c 22 22 29 0a 09 09 09 20 20 20 20 ed "\"")....
3240: 20 20 28 6c 65 74 2a 20 28 28 77 61 69 76 65 72 (let* ((waiver
3250: 20 20 20 20 20 20 28 63 6f 6e 66 69 67 66 3a 6c (configf:l
3260: 6f 6f 6b 75 70 20 74 65 73 74 63 6f 6e 66 69 67 ookup testconfig
3270: 20 22 77 61 69 76 65 72 73 22 20 68 65 64 29 29 "waivers" hed))
3280: 0a 09 09 09 09 20 20 20 20 20 28 77 70 61 72 74 ..... (wpart
3290: 73 20 20 20 20 20 20 28 69 66 20 77 61 69 76 65 s (if waive
32a0: 72 20 28 73 74 72 69 6e 67 2d 6d 61 74 63 68 20 r (string-match
32b0: 77 61 69 76 65 72 2d 72 78 20 77 61 69 76 65 72 waiver-rx waiver
32c0: 29 20 23 66 29 29 0a 09 09 09 09 20 20 20 20 20 ) #f)).....
32d0: 28 77 61 69 76 65 72 2d 72 75 6c 65 20 28 69 66 (waiver-rule (if
32e0: 20 77 70 61 72 74 73 20 28 63 61 64 72 20 77 70 wparts (cadr wp
32f0: 61 72 74 73 29 20 20 23 66 29 29 0a 09 09 09 09 arts) #f)).....
3300: 20 20 20 20 20 28 77 61 69 76 65 72 2d 67 6c 6f (waiver-glo
3310: 62 20 28 69 66 20 77 70 61 72 74 73 20 28 63 61 b (if wparts (ca
3320: 64 64 72 20 77 70 61 72 74 73 29 20 23 66 29 29 ddr wparts) #f))
3330: 0a 09 09 09 09 20 20 20 20 20 28 6c 6f 67 70 72 ..... (logpr
3340: 6f 2d 66 69 6c 65 20 28 69 66 20 77 61 69 76 65 o-file (if waive
3350: 72 0a 09 09 09 09 09 09 20 20 20 20 20 20 28 6c r....... (l
3360: 65 74 20 28 28 66 6e 61 6d 65 20 28 63 6f 6e 63 et ((fname (conc
3370: 20 68 65 64 20 22 2e 6c 6f 67 70 72 6f 22 29 29 hed ".logpro"))
3380: 29 0a 09 09 09 09 09 09 09 28 69 66 20 28 66 69 )........(if (fi
3390: 6c 65 2d 65 78 69 73 74 73 3f 20 66 6e 61 6d 65 le-exists? fname
33a0: 29 0a 09 09 09 09 09 09 09 20 20 20 20 66 6e 61 )........ fna
33b0: 6d 65 20 0a 09 09 09 09 09 09 09 20 20 20 20 28 me ........ (
33c0: 62 65 67 69 6e 0a 09 09 09 09 09 09 09 20 20 20 begin........
33d0: 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 (debug:print
33e0: 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 0 *default-log-p
33f0: 6f 72 74 2a 20 22 49 4e 46 4f 3a 20 4e 6f 20 6c ort* "INFO: No l
3400: 6f 67 70 72 6f 20 66 69 6c 65 20 22 20 66 6e 61 ogpro file " fna
3410: 6d 65 20 22 20 66 61 6c 6c 69 6e 67 20 62 61 63 me " falling bac
3420: 6b 20 74 6f 20 64 69 66 66 22 29 0a 09 09 09 09 k to diff").....
3430: 09 09 09 20 20 20 20 20 20 23 66 29 29 29 0a 09 ... #f)))..
3440: 09 09 09 09 09 20 20 20 20 20 20 23 66 29 29 0a ..... #f)).
3450: 09 09 09 09 20 20 20 20 20 3b 3b 20 69 66 20 72 .... ;; if r
3460: 75 6c 65 20 62 79 20 6e 61 6d 65 20 6f 66 20 77 ule by name of w
3470: 61 69 76 65 72 2d 72 75 6c 65 20 69 73 20 66 6f aiver-rule is fo
3480: 75 6e 64 20 69 6e 20 74 65 73 74 63 6f 6e 66 69 und in testconfi
3490: 67 20 2d 20 75 73 65 20 69 74 0a 09 09 09 09 20 g - use it.....
34a0: 20 20 20 20 3b 3b 20 65 6c 73 65 20 69 66 20 77 ;; else if w
34b0: 61 69 76 65 72 6e 61 6d 65 2e 6c 6f 67 70 72 6f aivername.logpro
34c0: 20 65 78 69 73 74 73 20 75 73 65 20 6c 6f 67 70 exists use logp
34d0: 72 6f 2d 72 75 6c 65 0a 09 09 09 09 20 20 20 20 ro-rule.....
34e0: 20 3b 3b 20 65 6c 73 65 20 64 65 66 61 75 6c 74 ;; else default
34f0: 20 74 6f 20 64 69 66 66 2d 72 75 6c 65 0a 09 09 to diff-rule...
3500: 09 09 20 20 20 20 20 28 72 75 6c 65 2d 73 74 72 .. (rule-str
3510: 69 6e 67 20 28 6c 65 74 20 28 28 72 75 6c 65 20 ing (let ((rule
3520: 28 63 6f 6e 66 69 67 66 3a 6c 6f 6f 6b 75 70 20 (configf:lookup
3530: 74 65 73 74 63 6f 6e 66 69 67 20 22 77 61 69 76 testconfig "waiv
3540: 65 72 5f 72 75 6c 65 73 22 20 77 61 69 76 65 72 er_rules" waiver
3550: 2d 72 75 6c 65 29 29 29 0a 09 09 09 09 09 09 20 -rule))).......
3560: 20 20 20 28 69 66 20 72 75 6c 65 0a 09 09 09 09 (if rule.....
3570: 09 09 09 72 75 6c 65 0a 09 09 09 09 09 09 09 28 ...rule........(
3580: 69 66 20 6c 6f 67 70 72 6f 2d 66 69 6c 65 0a 09 if logpro-file..
3590: 09 09 09 09 09 09 20 20 20 20 6c 6f 67 70 72 6f ...... logpro
35a0: 2d 72 75 6c 65 0a 09 09 09 09 09 09 09 20 20 20 -rule........
35b0: 20 28 62 65 67 69 6e 0a 09 09 09 09 09 09 09 20 (begin........
35c0: 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e (debug:prin
35d0: 74 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 t 0 *default-log
35e0: 2d 70 6f 72 74 2a 20 22 49 4e 46 4f 3a 20 4e 6f -port* "INFO: No
35f0: 20 6c 6f 67 70 72 6f 20 66 69 6c 65 20 22 20 6c logpro file " l
3600: 6f 67 70 72 6f 2d 66 69 6c 65 20 22 20 66 6f 75 ogpro-file " fou
3610: 6e 64 2c 20 75 73 69 6e 67 20 64 69 66 66 20 72 nd, using diff r
3620: 75 6c 65 22 29 0a 09 09 09 09 09 09 09 20 20 20 ule")........
3630: 20 20 20 64 69 66 66 2d 72 75 6c 65 29 29 29 29 diff-rule))))
3640: 29 0a 09 09 09 09 20 20 20 20 20 3b 3b 20 28 73 )..... ;; (s
3650: 74 72 69 6e 67 2d 73 75 62 73 74 69 74 75 74 65 tring-substitute
3660: 20 22 25 66 69 6c 65 31 25 22 20 22 66 6f 6f 66 "%file1%" "foof
3670: 6f 6f 2e 74 78 74 22 20 22 54 68 69 73 20 69 73 oo.txt" "This is
3680: 20 25 66 69 6c 65 31 25 20 61 6e 64 20 73 6f 20 %file1% and so
3690: 69 73 20 74 68 69 73 20 25 66 69 6c 65 31 25 2e is this %file1%.
36a0: 22 20 23 74 29 0a 09 09 09 09 20 20 20 20 20 28 " #t)..... (
36b0: 70 72 6f 63 65 73 73 65 64 2d 63 6d 64 20 28 73 processed-cmd (s
36c0: 74 72 69 6e 67 2d 73 75 62 73 74 69 74 75 74 65 tring-substitute
36d0: 20 0a 09 09 09 09 09 09 20 20 20 20 20 22 25 66 ....... "%f
36e0: 69 6c 65 31 25 22 20 28 63 6f 6e 63 20 74 65 73 ile1%" (conc tes
36f0: 74 2d 72 75 6e 64 69 72 20 22 2f 22 20 77 61 69 t-rundir "/" wai
3700: 76 65 72 2d 67 6c 6f 62 29 0a 09 09 09 09 09 09 ver-glob).......
3710: 20 20 20 20 20 28 73 74 72 69 6e 67 2d 73 75 62 (string-sub
3720: 73 74 69 74 75 74 65 0a 09 09 09 09 09 09 20 20 stitute.......
3730: 20 20 20 20 22 25 66 69 6c 65 32 25 22 20 28 63 "%file2%" (c
3740: 6f 6e 63 20 70 72 65 76 2d 72 75 6e 64 69 72 20 onc prev-rundir
3750: 22 2f 22 20 77 61 69 76 65 72 2d 67 6c 6f 62 29 "/" waiver-glob)
3760: 0a 09 09 09 09 09 09 20 20 20 20 20 20 28 73 74 ....... (st
3770: 72 69 6e 67 2d 73 75 62 73 74 69 74 75 74 65 0a ring-substitute.
3780: 09 09 09 09 09 09 20 20 20 20 20 20 20 22 25 77 ...... "%w
3790: 61 69 76 65 72 6e 61 6d 65 25 22 20 68 65 64 20 aivername%" hed
37a0: 72 75 6c 65 2d 73 74 72 69 6e 67 20 23 74 29 20 rule-string #t)
37b0: 23 74 29 20 23 74 29 29 0a 09 09 09 09 20 20 20 #t) #t)).....
37c0: 20 20 28 72 65 73 20 20 20 20 20 20 20 20 20 20 (res
37d0: 20 20 23 66 29 29 0a 09 09 09 09 28 64 65 62 75 #f)).....(debu
37e0: 67 3a 70 72 69 6e 74 20 30 20 2a 64 65 66 61 75 g:print 0 *defau
37f0: 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 49 4e lt-log-port* "IN
3800: 46 4f 3a 20 77 61 69 76 65 72 20 63 6f 6d 6d 61 FO: waiver comma
3810: 6e 64 20 69 73 20 5c 22 22 20 70 72 6f 63 65 73 nd is \"" proces
3820: 73 65 64 2d 63 6d 64 20 22 5c 22 22 29 0a 09 09 sed-cmd "\"")...
3830: 09 09 28 69 66 20 28 65 71 3f 20 28 73 79 73 74 ..(if (eq? (syst
3840: 65 6d 20 70 72 6f 63 65 73 73 65 64 2d 63 6d 64 em processed-cmd
3850: 29 20 30 29 0a 09 09 09 09 20 20 20 20 28 69 66 ) 0)..... (if
3860: 20 28 6e 75 6c 6c 3f 20 74 61 6c 29 0a 09 09 09 (null? tal)....
3870: 09 09 23 74 0a 09 09 09 09 09 28 6c 6f 6f 70 20 ..#t......(loop
3880: 28 63 61 72 20 74 61 6c 29 28 63 64 72 20 74 61 (car tal)(cdr ta
3890: 6c 29 29 29 0a 09 09 09 09 20 20 20 20 23 66 29 l)))..... #f)
38a0: 29 29 29 29 29 0a 09 20 20 20 20 28 70 6f 70 2d ))))).. (pop-
38b0: 64 69 72 65 63 74 6f 72 79 29 0a 09 20 20 20 20 directory)..
38c0: 72 65 73 75 6c 74 29 29 29 29 29 0a 0a 3b 3b 20 result)))))..;;
38d0: 44 6f 20 6e 6f 74 20 72 70 63 20 74 68 69 73 20 Do not rpc this
38e0: 6f 6e 65 2c 20 64 6f 20 74 68 65 20 75 6e 64 65 one, do the unde
38f0: 72 6c 79 69 6e 67 20 63 61 6c 6c 73 21 21 21 0a rlying calls!!!.
3900: 28 64 65 66 69 6e 65 20 28 74 65 73 74 73 3a 74 (define (tests:t
3910: 65 73 74 2d 73 65 74 2d 73 74 61 74 75 73 21 20 est-set-status!
3920: 72 75 6e 2d 69 64 20 74 65 73 74 2d 69 64 20 73 run-id test-id s
3930: 74 61 74 65 20 73 74 61 74 75 73 20 63 6f 6d 6d tate status comm
3940: 65 6e 74 20 64 61 74 20 23 21 6b 65 79 20 28 77 ent dat #!key (w
3950: 6f 72 6b 2d 61 72 65 61 20 23 66 29 29 0a 20 20 ork-area #f)).
3960: 28 6c 65 74 2a 20 28 28 72 65 61 6c 2d 73 74 61 (let* ((real-sta
3970: 74 75 73 20 73 74 61 74 75 73 29 0a 09 20 28 6f tus status).. (o
3980: 74 68 65 72 64 61 74 20 20 20 20 28 69 66 20 64 therdat (if d
3990: 61 74 20 64 61 74 20 28 6d 61 6b 65 2d 68 61 73 at dat (make-has
39a0: 68 2d 74 61 62 6c 65 29 29 29 0a 09 20 28 74 65 h-table))).. (te
39b0: 73 74 64 61 74 20 20 20 20 20 28 72 6d 74 3a 67 stdat (rmt:g
39c0: 65 74 2d 74 65 73 74 2d 69 6e 66 6f 2d 62 79 2d et-test-info-by-
39d0: 69 64 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 69 id run-id test-i
39e0: 64 29 29 0a 09 20 28 74 65 73 74 2d 6e 61 6d 65 d)).. (test-name
39f0: 20 20 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d (db:test-get-
3a00: 74 65 73 74 6e 61 6d 65 20 20 74 65 73 74 64 61 testname testda
3a10: 74 29 29 0a 09 20 28 69 74 65 6d 2d 70 61 74 68 t)).. (item-path
3a20: 20 20 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d (db:test-get-
3a30: 69 74 65 6d 2d 70 61 74 68 20 74 65 73 74 64 61 item-path testda
3a40: 74 29 29 0a 09 20 3b 3b 20 62 65 66 6f 72 65 20 t)).. ;; before
3a50: 70 72 6f 63 65 65 64 69 6e 67 20 77 65 20 6d 75 proceeding we mu
3a60: 73 74 20 66 69 6e 64 20 6f 75 74 20 69 66 20 74 st find out if t
3a70: 68 65 20 70 72 65 76 69 6f 75 73 20 74 65 73 74 he previous test
3a80: 20 28 77 68 65 72 65 20 61 6c 6c 20 6b 65 79 73 (where all keys
3a90: 20 6d 61 74 63 68 65 64 20 65 78 63 65 70 74 20 matched except
3aa0: 72 75 6e 6e 61 6d 65 29 0a 09 20 3b 3b 20 77 61 runname).. ;; wa
3ab0: 73 20 57 41 49 56 45 44 20 69 66 20 74 68 69 73 s WAIVED if this
3ac0: 20 74 65 73 74 20 69 73 20 46 41 49 4c 0a 0a 09 test is FAIL...
3ad0: 20 3b 3b 20 4e 4f 54 45 53 3a 0a 09 20 3b 3b 20 ;; NOTES:.. ;;
3ae0: 20 31 2e 20 49 73 20 74 68 65 20 63 61 6c 6c 20 1. Is the call
3af0: 74 6f 20 74 65 73 74 3a 67 65 74 2d 70 72 65 76 to test:get-prev
3b00: 69 6f 75 73 2d 72 75 6e 2d 72 65 63 6f 72 64 20 ious-run-record
3b10: 72 65 6d 6f 74 69 66 69 65 64 3f 0a 09 20 3b 3b remotified?.. ;;
3b20: 20 20 32 2e 20 41 64 64 20 74 65 73 74 20 66 6f 2. Add test fo
3b30: 72 20 74 65 73 74 63 6f 6e 66 69 67 20 77 61 69 r testconfig wai
3b40: 76 65 72 20 70 72 6f 70 61 67 61 74 69 6f 6e 20 ver propagation
3b50: 63 6f 6e 74 72 6f 6c 20 68 65 72 65 0a 09 20 3b control here.. ;
3b60: 3b 0a 09 20 28 70 72 65 76 2d 74 65 73 74 20 20 ;.. (prev-test
3b70: 20 28 69 66 20 28 65 71 75 61 6c 3f 20 73 74 61 (if (equal? sta
3b80: 74 75 73 20 22 46 41 49 4c 22 29 0a 09 09 09 20 tus "FAIL")....
3b90: 20 28 72 6d 74 3a 67 65 74 2d 70 72 65 76 69 6f (rmt:get-previo
3ba0: 75 73 2d 74 65 73 74 2d 72 75 6e 2d 72 65 63 6f us-test-run-reco
3bb0: 72 64 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 6e rd run-id test-n
3bc0: 61 6d 65 20 69 74 65 6d 2d 70 61 74 68 29 0a 09 ame item-path)..
3bd0: 09 09 20 20 23 66 29 29 0a 09 20 28 77 61 69 76 .. #f)).. (waiv
3be0: 65 64 20 20 20 28 69 66 20 70 72 65 76 2d 74 65 ed (if prev-te
3bf0: 73 74 0a 09 09 20 20 20 20 20 20 20 28 69 66 20 st... (if
3c00: 70 72 65 76 2d 74 65 73 74 20 3b 3b 20 74 72 75 prev-test ;; tru
3c10: 65 20 69 66 20 77 65 20 66 6f 75 6e 64 20 61 20 e if we found a
3c20: 70 72 65 76 69 6f 75 73 20 74 65 73 74 20 69 6e previous test in
3c30: 20 74 68 69 73 20 72 75 6e 20 73 65 72 69 65 73 this run series
3c40: 0a 09 09 09 20 20 20 28 6c 65 74 20 28 28 70 72 .... (let ((pr
3c50: 65 76 2d 73 74 61 74 75 73 20 20 28 64 62 3a 74 ev-status (db:t
3c60: 65 73 74 2d 67 65 74 2d 73 74 61 74 75 73 20 20 est-get-status
3c70: 70 72 65 76 2d 74 65 73 74 29 29 0a 09 09 09 09 prev-test)).....
3c80: 20 28 70 72 65 76 2d 73 74 61 74 65 20 20 20 28 (prev-state (
3c90: 64 62 3a 74 65 73 74 2d 67 65 74 2d 73 74 61 74 db:test-get-stat
3ca0: 65 20 20 20 70 72 65 76 2d 74 65 73 74 29 29 0a e prev-test)).
3cb0: 09 09 09 09 20 28 70 72 65 76 2d 63 6f 6d 6d 65 .... (prev-comme
3cc0: 6e 74 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d nt (db:test-get-
3cd0: 63 6f 6d 6d 65 6e 74 20 70 72 65 76 2d 74 65 73 comment prev-tes
3ce0: 74 29 29 29 0a 09 09 09 20 20 20 20 20 28 64 65 t))).... (de
3cf0: 62 75 67 3a 70 72 69 6e 74 20 34 20 2a 64 65 66 bug:print 4 *def
3d00: 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 ault-log-port* "
3d10: 70 72 65 76 2d 73 74 61 74 75 73 20 22 20 70 72 prev-status " pr
3d20: 65 76 2d 73 74 61 74 75 73 20 22 2c 20 70 72 65 ev-status ", pre
3d30: 76 2d 73 74 61 74 65 20 22 20 70 72 65 76 2d 73 v-state " prev-s
3d40: 74 61 74 65 20 22 2c 20 70 72 65 76 2d 63 6f 6d tate ", prev-com
3d50: 6d 65 6e 74 20 22 20 70 72 65 76 2d 63 6f 6d 6d ment " prev-comm
3d60: 65 6e 74 29 0a 09 09 09 20 20 20 20 20 28 69 66 ent).... (if
3d70: 20 28 61 6e 64 20 28 65 71 75 61 6c 3f 20 70 72 (and (equal? pr
3d80: 65 76 2d 73 74 61 74 65 20 20 22 43 4f 4d 50 4c ev-state "COMPL
3d90: 45 54 45 44 22 29 0a 09 09 09 09 20 20 20 20 20 ETED").....
3da0: 20 28 65 71 75 61 6c 3f 20 70 72 65 76 2d 73 74 (equal? prev-st
3db0: 61 74 75 73 20 22 57 41 49 56 45 44 22 29 29 0a atus "WAIVED")).
3dc0: 09 09 09 09 20 28 69 66 20 63 6f 6d 6d 65 6e 74 .... (if comment
3dd0: 0a 09 09 09 09 20 20 20 20 20 63 6f 6d 6d 65 6e ..... commen
3de0: 74 0a 09 09 09 09 20 20 20 20 20 70 72 65 76 2d t..... prev-
3df0: 63 6f 6d 6d 65 6e 74 29 20 3b 3b 20 77 61 69 76 comment) ;; waiv
3e00: 65 64 20 69 73 20 65 69 74 68 65 72 20 74 68 65 ed is either the
3e10: 20 63 6f 6d 6d 65 6e 74 20 6f 72 20 23 66 0a 09 comment or #f..
3e20: 09 09 09 20 23 66 29 29 0a 09 09 09 20 20 20 23 ... #f)).... #
3e30: 66 29 0a 09 09 20 20 20 20 20 20 20 23 66 29 29 f)... #f))
3e40: 29 0a 20 20 20 20 28 69 66 20 28 61 6e 64 20 77 ). (if (and w
3e50: 61 69 76 65 64 20 0a 09 20 20 20 20 20 28 74 65 aived .. (te
3e60: 73 74 73 3a 63 68 65 63 6b 2d 77 61 69 76 65 72 sts:check-waiver
3e70: 2d 65 6c 69 67 69 62 69 6c 69 74 79 20 74 65 73 -eligibility tes
3e80: 74 64 61 74 20 70 72 65 76 2d 74 65 73 74 29 29 tdat prev-test))
3e90: 0a 09 28 73 65 74 21 20 72 65 61 6c 2d 73 74 61 ..(set! real-sta
3ea0: 74 75 73 20 22 57 41 49 56 45 44 22 29 29 0a 0a tus "WAIVED"))..
3eb0: 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 (debug:print
3ec0: 20 34 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 4 *default-log-
3ed0: 70 6f 72 74 2a 20 22 72 65 61 6c 2d 73 74 61 74 port* "real-stat
3ee0: 75 73 20 22 20 72 65 61 6c 2d 73 74 61 74 75 73 us " real-status
3ef0: 20 22 2c 20 77 61 69 76 65 64 20 22 20 77 61 69 ", waived " wai
3f00: 76 65 64 20 22 2c 20 73 74 61 74 75 73 20 22 20 ved ", status "
3f10: 73 74 61 74 75 73 29 0a 0a 20 20 20 20 3b 3b 20 status).. ;;
3f20: 75 70 64 61 74 65 20 74 68 65 20 70 72 69 6d 61 update the prima
3f30: 72 79 20 72 65 63 6f 72 64 20 49 46 20 73 74 61 ry record IF sta
3f40: 74 65 20 41 4e 44 20 73 74 61 74 75 73 20 61 72 te AND status ar
3f50: 65 20 64 65 66 69 6e 65 64 0a 20 20 20 20 28 69 e defined. (i
3f60: 66 20 28 61 6e 64 20 73 74 61 74 65 20 73 74 61 f (and state sta
3f70: 74 75 73 29 0a 09 28 62 65 67 69 6e 0a 09 20 20 tus)..(begin..
3f80: 28 72 6d 74 3a 73 65 74 2d 73 74 61 74 65 2d 73 (rmt:set-state-s
3f90: 74 61 74 75 73 2d 61 6e 64 2d 72 6f 6c 6c 2d 75 tatus-and-roll-u
3fa0: 70 2d 69 74 65 6d 73 20 72 75 6e 2d 69 64 20 74 p-items run-id t
3fb0: 65 73 74 2d 69 64 20 69 74 65 6d 2d 70 61 74 68 est-id item-path
3fc0: 20 73 74 61 74 65 20 72 65 61 6c 2d 73 74 61 74 state real-stat
3fd0: 75 73 20 28 69 66 20 77 61 69 76 65 64 20 77 61 us (if waived wa
3fe0: 69 76 65 64 20 63 6f 6d 6d 65 6e 74 29 29 0a 09 ived comment))..
3ff0: 20 20 3b 3b 20 28 6d 74 3a 70 72 6f 63 65 73 73 ;; (mt:process
4000: 2d 74 72 69 67 67 65 72 73 20 72 75 6e 2d 69 64 -triggers run-id
4010: 20 74 65 73 74 2d 69 64 20 73 74 61 74 65 20 72 test-id state r
4020: 65 61 6c 2d 73 74 61 74 75 73 29 20 3b 3b 20 74 eal-status) ;; t
4030: 72 69 67 67 65 72 73 20 61 72 65 20 63 61 6c 6c riggers are call
4040: 65 64 20 69 6e 20 74 65 73 74 2d 73 65 74 2d 73 ed in test-set-s
4050: 74 61 74 65 2d 73 74 61 74 75 73 0a 09 20 20 29 tate-status.. )
4060: 29 0a 20 20 20 20 0a 20 20 20 20 3b 3b 20 69 66 ). . ;; if
4070: 20 73 74 61 74 75 73 20 69 73 20 22 41 55 54 4f status is "AUTO
4080: 22 20 74 68 65 6e 20 63 61 6c 6c 20 72 6f 6c 6c " then call roll
4090: 75 70 20 28 6e 6f 74 65 2c 20 74 68 69 73 20 6f up (note, this o
40a0: 6e 65 20 6d 6f 64 69 66 69 65 73 20 64 61 74 61 ne modifies data
40b0: 20 69 6e 20 74 65 73 74 0a 20 20 20 20 3b 3b 20 in test. ;;
40c0: 72 75 6e 20 61 72 65 61 2c 20 69 74 20 64 6f 65 run area, it doe
40d0: 73 20 72 65 6d 6f 74 65 20 63 61 6c 6c 73 20 75 s remote calls u
40e0: 6e 64 65 72 20 74 68 65 20 68 6f 6f 64 2e 0a 20 nder the hood..
40f0: 20 20 20 3b 3b 20 28 69 66 20 28 61 6e 64 20 74 ;; (if (and t
4100: 65 73 74 2d 69 64 20 73 74 61 74 65 20 73 74 61 est-id state sta
4110: 74 75 73 20 28 65 71 75 61 6c 3f 20 73 74 61 74 tus (equal? stat
4120: 75 73 20 22 41 55 54 4f 22 29 29 20 0a 20 20 20 us "AUTO")) .
4130: 20 3b 3b 20 09 28 72 6d 74 3a 74 65 73 74 2d 64 ;; .(rmt:test-d
4140: 61 74 61 2d 72 6f 6c 6c 75 70 20 72 75 6e 2d 69 ata-rollup run-i
4150: 64 20 74 65 73 74 2d 69 64 20 73 74 61 74 75 73 d test-id status
4160: 29 29 0a 0a 20 20 20 20 3b 3b 20 61 64 64 20 6d )).. ;; add m
4170: 65 74 61 64 61 74 61 20 28 6e 65 65 64 20 74 6f etadata (need to
4180: 20 64 6f 20 74 68 69 73 20 77 61 79 20 74 6f 20 do this way to
4190: 61 76 6f 69 64 20 53 51 4c 20 69 6e 6a 65 63 74 avoid SQL inject
41a0: 69 6f 6e 20 69 73 73 75 65 73 29 0a 0a 20 20 20 ion issues)..
41b0: 20 3b 3b 20 3a 66 69 72 73 74 5f 65 72 72 0a 20 ;; :first_err.
41c0: 20 20 20 3b 3b 20 28 6c 65 74 20 28 28 76 61 6c ;; (let ((val
41d0: 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 (hash-table-ref
41e0: 2f 64 65 66 61 75 6c 74 20 6f 74 68 65 72 64 61 /default otherda
41f0: 74 20 22 3a 66 69 72 73 74 5f 65 72 72 22 20 23 t ":first_err" #
4200: 66 29 29 29 0a 20 20 20 20 3b 3b 20 20 20 28 69 f))). ;; (i
4210: 66 20 76 61 6c 0a 20 20 20 20 3b 3b 20 20 20 20 f val. ;;
4220: 20 20 20 28 73 71 6c 69 74 65 33 3a 65 78 65 63 (sqlite3:exec
4230: 75 74 65 20 64 62 20 22 55 50 44 41 54 45 20 74 ute db "UPDATE t
4240: 65 73 74 73 20 53 45 54 20 66 69 72 73 74 5f 65 ests SET first_e
4250: 72 72 3d 3f 20 57 48 45 52 45 20 72 75 6e 5f 69 rr=? WHERE run_i
4260: 64 3d 3f 20 41 4e 44 20 74 65 73 74 6e 61 6d 65 d=? AND testname
4270: 3d 3f 20 41 4e 44 20 69 74 65 6d 5f 70 61 74 68 =? AND item_path
4280: 3d 3f 3b 22 20 76 61 6c 20 72 75 6e 2d 69 64 20 =?;" val run-id
4290: 74 65 73 74 2d 6e 61 6d 65 20 69 74 65 6d 2d 70 test-name item-p
42a0: 61 74 68 29 29 29 0a 20 20 20 20 3b 3b 20 0a 20 ath))). ;; .
42b0: 20 20 20 3b 3b 20 3b 3b 20 3a 66 69 72 73 74 5f ;; ;; :first_
42c0: 77 61 72 6e 0a 20 20 20 20 3b 3b 20 28 6c 65 74 warn. ;; (let
42d0: 20 28 28 76 61 6c 20 28 68 61 73 68 2d 74 61 62 ((val (hash-tab
42e0: 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 6f le-ref/default o
42f0: 74 68 65 72 64 61 74 20 22 3a 66 69 72 73 74 5f therdat ":first_
4300: 77 61 72 6e 22 20 23 66 29 29 29 0a 20 20 20 20 warn" #f))).
4310: 3b 3b 20 20 20 28 69 66 20 76 61 6c 0a 20 20 20 ;; (if val.
4320: 20 3b 3b 20 20 20 20 20 20 20 28 73 71 6c 69 74 ;; (sqlit
4330: 65 33 3a 65 78 65 63 75 74 65 20 64 62 20 22 55 e3:execute db "U
4340: 50 44 41 54 45 20 74 65 73 74 73 20 53 45 54 20 PDATE tests SET
4350: 66 69 72 73 74 5f 77 61 72 6e 3d 3f 20 57 48 45 first_warn=? WHE
4360: 52 45 20 72 75 6e 5f 69 64 3d 3f 20 41 4e 44 20 RE run_id=? AND
4370: 74 65 73 74 6e 61 6d 65 3d 3f 20 41 4e 44 20 69 testname=? AND i
4380: 74 65 6d 5f 70 61 74 68 3d 3f 3b 22 20 76 61 6c tem_path=?;" val
4390: 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 6e 61 6d run-id test-nam
43a0: 65 20 69 74 65 6d 2d 70 61 74 68 29 29 29 0a 0a e item-path)))..
43b0: 20 20 20 20 28 6c 65 74 20 28 28 63 61 74 65 67 (let ((categ
43c0: 6f 72 79 20 28 68 61 73 68 2d 74 61 62 6c 65 2d ory (hash-table-
43d0: 72 65 66 2f 64 65 66 61 75 6c 74 20 6f 74 68 65 ref/default othe
43e0: 72 64 61 74 20 22 3a 63 61 74 65 67 6f 72 79 22 rdat ":category"
43f0: 20 22 22 29 29 0a 09 20 20 28 76 61 72 69 61 62 "")).. (variab
4400: 6c 65 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 le (hash-table-r
4410: 65 66 2f 64 65 66 61 75 6c 74 20 6f 74 68 65 72 ef/default other
4420: 64 61 74 20 22 3a 76 61 72 69 61 62 6c 65 22 20 dat ":variable"
4430: 22 22 29 29 0a 09 20 20 28 76 61 6c 75 65 20 20 "")).. (value
4440: 20 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 (hash-table-re
4450: 66 2f 64 65 66 61 75 6c 74 20 6f 74 68 65 72 64 f/default otherd
4460: 61 74 20 22 3a 76 61 6c 75 65 22 20 20 20 20 23 at ":value" #
4470: 66 29 29 0a 09 20 20 28 65 78 70 65 63 74 65 64 f)).. (expected
4480: 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 (hash-table-ref
4490: 2f 64 65 66 61 75 6c 74 20 6f 74 68 65 72 64 61 /default otherda
44a0: 74 20 22 3a 65 78 70 65 63 74 65 64 22 20 23 66 t ":expected" #f
44b0: 29 29 0a 09 20 20 28 74 6f 6c 20 20 20 20 20 20 )).. (tol
44c0: 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f (hash-table-ref/
44d0: 64 65 66 61 75 6c 74 20 6f 74 68 65 72 64 61 74 default otherdat
44e0: 20 22 3a 74 6f 6c 22 20 20 20 20 20 20 23 66 29 ":tol" #f)
44f0: 29 0a 09 20 20 28 75 6e 69 74 73 20 20 20 20 28 ).. (units (
4500: 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 hash-table-ref/d
4510: 65 66 61 75 6c 74 20 6f 74 68 65 72 64 61 74 20 efault otherdat
4520: 22 3a 75 6e 69 74 73 22 20 20 20 20 22 22 29 29 ":units" ""))
4530: 0a 09 20 20 28 74 79 70 65 20 20 20 20 20 28 68 .. (type (h
4540: 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 ash-table-ref/de
4550: 66 61 75 6c 74 20 6f 74 68 65 72 64 61 74 20 22 fault otherdat "
4560: 3a 74 79 70 65 22 20 20 20 20 20 22 22 29 29 0a :type" "")).
4570: 09 20 20 28 64 63 6f 6d 6d 65 6e 74 20 28 68 61 . (dcomment (ha
4580: 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 sh-table-ref/def
4590: 61 75 6c 74 20 6f 74 68 65 72 64 61 74 20 22 3a ault otherdat ":
45a0: 63 6f 6d 6d 65 6e 74 22 20 20 22 22 29 29 29 0a comment" ""))).
45b0: 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 (debug:pri
45c0: 6e 74 20 34 20 2a 64 65 66 61 75 6c 74 2d 6c 6f nt 4 *default-lo
45d0: 67 2d 70 6f 72 74 2a 20 0a 09 09 20 20 20 22 63 g-port* ... "c
45e0: 61 74 65 67 6f 72 79 3a 20 22 20 63 61 74 65 67 ategory: " categ
45f0: 6f 72 79 20 22 2c 20 76 61 72 69 61 62 6c 65 3a ory ", variable:
4600: 20 22 20 76 61 72 69 61 62 6c 65 20 22 2c 20 76 " variable ", v
4610: 61 6c 75 65 3a 20 22 20 76 61 6c 75 65 0a 09 09 alue: " value...
4620: 20 20 20 22 2c 20 65 78 70 65 63 74 65 64 3a 20 ", expected:
4630: 22 20 65 78 70 65 63 74 65 64 20 22 2c 20 74 6f " expected ", to
4640: 6c 3a 20 22 20 74 6f 6c 20 22 2c 20 75 6e 69 74 l: " tol ", unit
4650: 73 3a 20 22 20 75 6e 69 74 73 29 0a 20 20 20 20 s: " units).
4660: 20 20 28 69 66 20 28 61 6e 64 20 76 61 6c 75 65 (if (and value
4670: 20 65 78 70 65 63 74 65 64 20 74 6f 6c 29 20 3b expected tol) ;
4680: 3b 20 61 6c 6c 20 74 68 72 65 65 20 72 65 71 75 ; all three requ
4690: 69 72 65 64 0a 09 20 20 28 6c 65 74 20 28 28 64 ired.. (let ((d
46a0: 61 74 20 28 63 6f 6e 63 20 63 61 74 65 67 6f 72 at (conc categor
46b0: 79 20 22 2c 22 0a 09 09 09 20 20 20 76 61 72 69 y ",".... vari
46c0: 61 62 6c 65 20 22 2c 22 0a 09 09 09 20 20 20 76 able ",".... v
46d0: 61 6c 75 65 20 20 20 20 22 2c 22 0a 09 09 09 20 alue ","....
46e0: 20 20 65 78 70 65 63 74 65 64 20 22 2c 22 0a 09 expected ","..
46f0: 09 09 20 20 20 74 6f 6c 20 20 20 20 20 20 22 2c .. tol ",
4700: 22 0a 09 09 09 20 20 20 75 6e 69 74 73 20 20 20 ".... units
4710: 20 22 2c 22 0a 09 09 09 20 20 20 64 63 6f 6d 6d ",".... dcomm
4720: 65 6e 74 20 22 2c 2c 22 20 3b 3b 20 65 78 74 72 ent ",," ;; extr
4730: 61 20 63 6f 6d 6d 61 20 66 6f 72 20 73 74 61 74 a comma for stat
4740: 75 73 0a 09 09 09 20 20 20 74 79 70 65 20 20 20 us.... type
4750: 20 20 29 29 29 0a 09 20 20 20 20 3b 3b 20 54 68 ))).. ;; Th
4760: 69 73 20 77 61 73 20 72 75 6e 20 72 65 6d 6f 74 is was run remot
4770: 65 2c 20 64 6f 6e 27 74 20 74 68 69 6e 6b 20 74 e, don't think t
4780: 68 61 74 20 6d 61 6b 65 73 20 73 65 6e 73 65 2e hat makes sense.
4790: 20 50 65 72 68 61 70 73 20 6e 6f 74 2c 20 62 75 Perhaps not, bu
47a0: 74 20 74 68 61 74 20 69 73 20 74 68 65 20 65 61 t that is the ea
47b0: 73 69 65 73 74 20 70 61 74 68 20 66 6f 72 20 74 siest path for t
47c0: 68 65 20 6d 6f 6d 65 6e 74 2e 0a 09 20 20 20 20 he moment...
47d0: 28 72 6d 74 3a 63 73 76 2d 3e 74 65 73 74 2d 64 (rmt:csv->test-d
47e0: 61 74 61 20 72 75 6e 2d 69 64 20 74 65 73 74 2d ata run-id test-
47f0: 69 64 0a 09 09 09 09 64 61 74 29 29 29 29 0a 20 id.....dat)))).
4800: 20 20 20 20 20 0a 20 20 20 20 3b 3b 20 6e 65 65 . ;; nee
4810: 64 20 74 6f 20 75 70 64 61 74 65 20 74 68 65 20 d to update the
4820: 74 6f 70 20 74 65 73 74 20 72 65 63 6f 72 64 20 top test record
4830: 69 66 20 50 41 53 53 20 6f 72 20 46 41 49 4c 20 if PASS or FAIL
4840: 61 6e 64 20 74 68 69 73 20 69 73 20 61 20 73 75 and this is a su
4850: 62 74 65 73 74 0a 20 20 20 20 3b 3b 3b 3b 3b 3b btest. ;;;;;;
4860: 20 28 69 66 20 28 6e 6f 74 20 28 65 71 75 61 6c (if (not (equal
4870: 3f 20 69 74 65 6d 2d 70 61 74 68 20 22 22 29 29 ? item-path ""))
4880: 0a 20 20 20 20 3b 3b 3b 3b 3b 3b 20 20 20 20 20 . ;;;;;;
4890: 28 72 6d 74 3a 73 65 74 2d 73 74 61 74 65 2d 73 (rmt:set-state-s
48a0: 74 61 74 75 73 2d 61 6e 64 2d 72 6f 6c 6c 2d 75 tatus-and-roll-u
48b0: 70 2d 69 74 65 6d 73 20 72 75 6e 2d 69 64 20 74 p-items run-id t
48c0: 65 73 74 2d 6e 61 6d 65 20 69 74 65 6d 2d 70 61 est-name item-pa
48d0: 74 68 20 73 74 61 74 65 20 73 74 61 74 75 73 20 th state status
48e0: 23 66 29 20 3b 3b 3b 3b 3b 29 0a 0a 20 20 20 20 #f) ;;;;;)..
48f0: 28 69 66 20 28 6f 72 20 28 61 6e 64 20 28 73 74 (if (or (and (st
4900: 72 69 6e 67 3f 20 63 6f 6d 6d 65 6e 74 29 0a 09 ring? comment)..
4910: 09 20 28 73 74 72 69 6e 67 2d 6d 61 74 63 68 20 . (string-match
4920: 28 72 65 67 65 78 70 20 22 5c 5c 53 2b 22 29 20 (regexp "\\S+")
4930: 63 6f 6d 6d 65 6e 74 29 29 0a 09 20 20 20 20 77 comment)).. w
4940: 61 69 76 65 64 29 0a 09 28 6c 65 74 20 28 28 63 aived)..(let ((c
4950: 6d 74 20 20 28 69 66 20 77 61 69 76 65 64 20 77 mt (if waived w
4960: 61 69 76 65 64 20 63 6f 6d 6d 65 6e 74 29 29 29 aived comment)))
4970: 0a 09 20 20 28 72 6d 74 3a 67 65 6e 65 72 61 6c .. (rmt:general
4980: 2d 63 61 6c 6c 20 27 73 65 74 2d 74 65 73 74 2d -call 'set-test-
4990: 63 6f 6d 6d 65 6e 74 20 72 75 6e 2d 69 64 20 63 comment run-id c
49a0: 6d 74 20 74 65 73 74 2d 69 64 29 29 29 29 29 0a mt test-id))))).
49b0: 0a 28 64 65 66 69 6e 65 20 28 74 65 73 74 73 3a .(define (tests:
49c0: 74 65 73 74 2d 73 65 74 2d 74 6f 70 6c 6f 67 21 test-set-toplog!
49d0: 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 6e 61 6d run-id test-nam
49e0: 65 20 6c 6f 67 66 29 20 0a 20 20 28 72 6d 74 3a e logf) . (rmt:
49f0: 67 65 6e 65 72 61 6c 2d 63 61 6c 6c 20 27 74 65 general-call 'te
4a00: 73 74 73 3a 74 65 73 74 2d 73 65 74 2d 74 6f 70 sts:test-set-top
4a10: 6c 6f 67 20 72 75 6e 2d 69 64 20 6c 6f 67 66 20 log run-id logf
4a20: 72 75 6e 2d 69 64 20 74 65 73 74 2d 6e 61 6d 65 run-id test-name
4a30: 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 74 65 73 ))..(define (tes
4a40: 74 73 3a 73 75 6d 6d 61 72 69 7a 65 2d 69 74 65 ts:summarize-ite
4a50: 6d 73 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 69 ms run-id test-i
4a60: 64 20 74 65 73 74 2d 6e 61 6d 65 20 66 6f 72 63 d test-name forc
4a70: 65 29 0a 20 20 3b 3b 20 69 66 20 6e 6f 74 20 66 e). ;; if not f
4a80: 6f 72 63 65 20 74 68 65 6e 20 6f 6e 6c 79 20 75 orce then only u
4a90: 70 64 61 74 65 20 74 68 65 20 72 65 63 6f 72 64 pdate the record
4aa0: 20 69 66 20 6f 6e 65 20 6f 66 20 74 68 65 73 65 if one of these
4ab0: 20 69 73 20 74 72 75 65 3a 0a 20 20 3b 3b 20 20 is true:. ;;
4ac0: 20 31 2e 20 6c 6f 67 66 20 69 73 20 22 6c 6f 67 1. logf is "log
4ad0: 2f 66 69 6e 61 6c 2e 6c 6f 67 0a 20 20 3b 3b 20 /final.log. ;;
4ae0: 20 20 32 2e 20 6c 6f 67 66 20 69 73 20 73 61 6d 2. logf is sam
4af0: 65 20 61 73 20 6f 75 74 70 75 74 66 69 6c 65 6e e as outputfilen
4b00: 61 6d 65 0a 20 20 28 6c 65 74 2a 20 28 28 6f 75 ame. (let* ((ou
4b10: 74 70 75 74 66 69 6c 65 6e 61 6d 65 20 28 63 6f tputfilename (co
4b20: 6e 63 20 22 6d 65 67 61 74 65 73 74 2d 72 6f 6c nc "megatest-rol
4b30: 6c 75 70 2d 22 20 74 65 73 74 2d 6e 61 6d 65 20 lup-" test-name
4b40: 22 2e 68 74 6d 6c 22 29 29 0a 09 20 28 6f 72 69 ".html")).. (ori
4b50: 67 2d 64 69 72 20 20 20 20 20 20 20 28 63 75 72 g-dir (cur
4b60: 72 65 6e 74 2d 64 69 72 65 63 74 6f 72 79 29 29 rent-directory))
4b70: 0a 09 20 28 6c 6f 67 66 2d 69 6e 66 6f 20 20 20 .. (logf-info
4b80: 20 20 20 28 72 6d 74 3a 74 65 73 74 2d 67 65 74 (rmt:test-get
4b90: 2d 6c 6f 67 66 69 6c 65 2d 69 6e 66 6f 20 72 75 -logfile-info ru
4ba0: 6e 2d 69 64 20 74 65 73 74 2d 6e 61 6d 65 29 29 n-id test-name))
4bb0: 0a 09 20 28 6c 6f 67 66 20 20 20 20 20 20 20 20 .. (logf
4bc0: 20 20 20 28 69 66 20 6c 6f 67 66 2d 69 6e 66 6f (if logf-info
4bd0: 20 28 63 61 64 72 20 6c 6f 67 66 2d 69 6e 66 6f (cadr logf-info
4be0: 29 20 23 66 29 29 0a 09 20 28 70 61 74 68 20 20 ) #f)).. (path
4bf0: 20 20 20 20 20 20 20 20 20 28 69 66 20 6c 6f 67 (if log
4c00: 66 2d 69 6e 66 6f 20 28 63 61 72 20 20 6c 6f 67 f-info (car log
4c10: 66 2d 69 6e 66 6f 29 20 23 66 29 29 29 0a 20 20 f-info) #f))).
4c20: 20 20 3b 3b 20 54 68 69 73 20 71 75 65 72 79 20 ;; This query
4c30: 66 69 6e 64 73 20 74 68 65 20 70 61 74 68 20 61 finds the path a
4c40: 6e 64 20 63 68 61 6e 67 65 73 20 74 68 65 20 64 nd changes the d
4c50: 69 72 65 63 74 6f 72 79 20 74 6f 20 69 74 20 66 irectory to it f
4c60: 6f 72 20 74 68 65 20 74 65 73 74 0a 20 20 20 20 or the test.
4c70: 28 69 66 20 28 61 6e 64 20 28 73 74 72 69 6e 67 (if (and (string
4c80: 3f 20 70 61 74 68 29 0a 09 20 20 20 20 20 28 64 ? path).. (d
4c90: 69 72 65 63 74 6f 72 79 3f 20 70 61 74 68 29 29 irectory? path))
4ca0: 20 3b 3b 20 63 61 6e 20 67 65 74 20 23 66 20 68 ;; can get #f h
4cb0: 65 72 65 20 75 6e 64 65 72 20 73 6f 6d 65 20 77 ere under some w
4cc0: 69 65 72 64 20 63 6f 6e 64 69 74 69 6f 6e 73 2e ierd conditions.
4cd0: 20 77 68 79 2c 20 75 6e 6b 6e 6f 77 6e 20 2e 2e why, unknown ..
4ce0: 2e 0a 09 28 62 65 67 69 6e 0a 09 20 20 28 64 65 ...(begin.. (de
4cf0: 62 75 67 3a 70 72 69 6e 74 20 34 20 2a 64 65 66 bug:print 4 *def
4d00: 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 ault-log-port* "
4d10: 46 6f 75 6e 64 20 70 61 74 68 3a 20 22 20 70 61 Found path: " pa
4d20: 74 68 29 0a 09 20 20 28 63 68 61 6e 67 65 2d 64 th).. (change-d
4d30: 69 72 65 63 74 6f 72 79 20 70 61 74 68 29 29 0a irectory path)).
4d40: 09 3b 3b 20 28 73 65 74 21 20 6f 75 74 70 75 74 .;; (set! output
4d50: 66 69 6c 65 6e 61 6d 65 20 28 63 6f 6e 63 20 70 filename (conc p
4d60: 61 74 68 20 22 2f 22 20 6f 75 74 70 75 74 66 69 ath "/" outputfi
4d70: 6c 65 6e 61 6d 65 29 29 29 0a 09 28 64 65 62 75 lename)))..(debu
4d80: 67 3a 70 72 69 6e 74 2d 65 72 72 6f 72 20 30 20 g:print-error 0
4d90: 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 *default-log-por
4da0: 74 2a 20 22 73 75 6d 6d 61 72 69 7a 65 2d 69 74 t* "summarize-it
4db0: 65 6d 73 20 66 6f 72 20 72 75 6e 2d 69 64 3d 22 ems for run-id="
4dc0: 20 72 75 6e 2d 69 64 20 22 2c 20 74 65 73 74 2d run-id ", test-
4dd0: 6e 61 6d 65 3d 22 20 74 65 73 74 2d 6e 61 6d 65 name=" test-name
4de0: 20 22 2c 20 6e 6f 20 73 75 63 68 20 70 61 74 68 ", no such path
4df0: 3a 20 22 20 70 61 74 68 29 29 0a 20 20 20 20 28 : " path)). (
4e00: 64 65 62 75 67 3a 70 72 69 6e 74 20 34 20 2a 64 debug:print 4 *d
4e10: 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a efault-log-port*
4e20: 20 22 73 75 6d 6d 61 72 69 7a 65 2d 69 74 65 6d "summarize-item
4e30: 73 20 77 69 74 68 20 6c 6f 67 66 20 22 20 6c 6f s with logf " lo
4e40: 67 66 20 22 2c 20 6f 75 74 70 75 74 66 69 6c 65 gf ", outputfile
4e50: 6e 61 6d 65 20 22 20 6f 75 74 70 75 74 66 69 6c name " outputfil
4e60: 65 6e 61 6d 65 20 22 20 61 6e 64 20 66 6f 72 63 ename " and forc
4e70: 65 20 22 20 66 6f 72 63 65 29 0a 20 20 20 20 28 e " force). (
4e80: 69 66 20 28 6f 72 20 28 65 71 75 61 6c 3f 20 6c if (or (equal? l
4e90: 6f 67 66 20 22 6c 6f 67 73 2f 66 69 6e 61 6c 2e ogf "logs/final.
4ea0: 6c 6f 67 22 29 0a 09 20 20 20 20 28 65 71 75 61 log").. (equa
4eb0: 6c 3f 20 6c 6f 67 66 20 6f 75 74 70 75 74 66 69 l? logf outputfi
4ec0: 6c 65 6e 61 6d 65 29 0a 09 20 20 20 20 66 6f 72 lename).. for
4ed0: 63 65 29 0a 09 28 6c 65 74 20 28 28 6d 79 2d 73 ce)..(let ((my-s
4ee0: 74 61 72 74 2d 74 69 6d 65 20 28 63 75 72 72 65 tart-time (curre
4ef0: 6e 74 2d 73 65 63 6f 6e 64 73 29 29 0a 09 20 20 nt-seconds))..
4f00: 20 20 20 20 28 6c 6f 63 6b 66 20 20 20 20 20 20 (lockf
4f10: 20 20 20 28 63 6f 6e 63 20 6f 75 74 70 75 74 66 (conc outputf
4f20: 69 6c 65 6e 61 6d 65 20 22 2e 6c 6f 63 6b 22 29 ilename ".lock")
4f30: 29 29 0a 09 20 20 28 6c 65 74 20 6c 6f 6f 70 20 )).. (let loop
4f40: 28 28 68 61 76 65 2d 6c 6f 63 6b 20 20 28 63 6f ((have-lock (co
4f50: 6d 6d 6f 6e 3a 73 69 6d 70 6c 65 2d 66 69 6c 65 mmon:simple-file
4f60: 2d 6c 6f 63 6b 20 6c 6f 63 6b 66 29 29 29 0a 09 -lock lockf)))..
4f70: 20 20 20 20 28 69 66 20 68 61 76 65 2d 6c 6f 63 (if have-loc
4f80: 6b 0a 09 09 28 6c 65 74 20 28 28 73 63 72 69 70 k...(let ((scrip
4f90: 74 20 28 63 6f 6e 66 69 67 66 3a 6c 6f 6f 6b 75 t (configf:looku
4fa0: 70 20 2a 63 6f 6e 66 69 67 64 61 74 2a 20 22 74 p *configdat* "t
4fb0: 65 73 74 72 6f 6c 6c 75 70 22 20 74 65 73 74 2d estrollup" test-
4fc0: 6e 61 6d 65 29 29 29 0a 09 09 20 20 28 70 72 69 name)))... (pri
4fd0: 6e 74 20 22 4f 62 74 61 69 6e 65 64 20 6c 6f 63 nt "Obtained loc
4fe0: 6b 20 66 6f 72 20 22 20 6f 75 74 70 75 74 66 69 k for " outputfi
4ff0: 6c 65 6e 61 6d 65 29 0a 09 09 20 20 28 72 6d 74 lename)... (rmt
5000: 3a 73 65 74 2d 73 74 61 74 65 2d 73 74 61 74 75 :set-state-statu
5010: 73 2d 61 6e 64 2d 72 6f 6c 6c 2d 75 70 2d 69 74 s-and-roll-up-it
5020: 65 6d 73 20 72 75 6e 2d 69 64 20 74 65 73 74 2d ems run-id test-
5030: 6e 61 6d 65 20 22 22 20 23 66 20 23 66 20 23 66 name "" #f #f #f
5040: 29 0a 09 09 20 20 28 69 66 20 73 63 72 69 70 74 )... (if script
5050: 0a 09 09 20 20 20 20 20 20 28 73 79 73 74 65 6d ... (system
5060: 20 28 63 6f 6e 63 20 73 63 72 69 70 74 20 22 20 (conc script "
5070: 3e 20 22 20 6f 75 74 70 75 74 66 69 6c 65 6e 61 > " outputfilena
5080: 6d 65 20 22 20 26 20 22 29 29 0a 09 09 20 20 20 me " & "))...
5090: 20 20 20 28 74 65 73 74 73 3a 67 65 6e 65 72 61 (tests:genera
50a0: 74 65 2d 68 74 6d 6c 2d 73 75 6d 6d 61 72 79 2d te-html-summary-
50b0: 66 6f 72 2d 69 74 65 72 61 74 65 64 2d 74 65 73 for-iterated-tes
50c0: 74 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 69 64 t run-id test-id
50d0: 20 74 65 73 74 2d 6e 61 6d 65 20 6f 75 74 70 75 test-name outpu
50e0: 74 66 69 6c 65 6e 61 6d 65 29 29 0a 09 09 20 20 tfilename))...
50f0: 28 63 6f 6d 6d 6f 6e 3a 73 69 6d 70 6c 65 2d 66 (common:simple-f
5100: 69 6c 65 2d 72 65 6c 65 61 73 65 2d 6c 6f 63 6b ile-release-lock
5110: 20 6c 6f 63 6b 66 29 0a 09 09 20 20 28 63 68 61 lockf)... (cha
5120: 6e 67 65 2d 64 69 72 65 63 74 6f 72 79 20 6f 72 nge-directory or
5130: 69 67 2d 64 69 72 29 0a 09 09 20 20 3b 3b 20 4e ig-dir)... ;; N
5140: 42 2f 2f 20 74 65 73 74 73 3a 74 65 73 74 2d 73 B// tests:test-s
5150: 65 74 2d 74 6f 70 6c 6f 67 21 20 69 73 20 72 65 et-toplog! is re
5160: 6d 6f 74 65 20 69 6e 74 65 72 6e 61 6c 2e 2e 2e mote internal...
5170: 0a 09 09 20 20 28 74 65 73 74 73 3a 74 65 73 74 ... (tests:test
5180: 2d 73 65 74 2d 74 6f 70 6c 6f 67 21 20 72 75 6e -set-toplog! run
5190: 2d 69 64 20 74 65 73 74 2d 6e 61 6d 65 20 6f 75 -id test-name ou
51a0: 74 70 75 74 66 69 6c 65 6e 61 6d 65 29 29 0a 09 tputfilename))..
51b0: 09 3b 3b 20 64 69 64 6e 27 74 20 67 65 74 20 74 .;; didn't get t
51c0: 68 65 20 6c 6f 63 6b 2c 20 63 68 65 63 6b 20 74 he lock, check t
51d0: 6f 20 73 65 65 20 69 66 20 63 75 72 72 65 6e 74 o see if current
51e0: 20 75 70 64 61 74 65 20 73 74 61 72 74 65 64 20 update started
51f0: 6c 61 74 65 72 20 74 68 61 6e 20 74 68 69 73 20 later than this
5200: 0a 09 09 3b 3b 20 75 70 64 61 74 65 2c 20 69 66 ...;; update, if
5210: 20 73 6f 20 77 65 20 63 61 6e 20 65 78 69 74 20 so we can exit
5220: 77 69 74 68 6f 75 74 20 64 6f 69 6e 67 20 61 6e without doing an
5230: 79 20 77 6f 72 6b 0a 09 09 28 69 66 20 28 3e 20 y work...(if (>
5240: 6d 79 2d 73 74 61 72 74 2d 74 69 6d 65 20 28 66 my-start-time (f
5250: 69 6c 65 2d 6d 6f 64 69 66 69 63 61 74 69 6f 6e ile-modification
5260: 2d 74 69 6d 65 20 6c 6f 63 6b 66 29 29 0a 09 09 -time lockf))...
5270: 20 20 20 20 3b 3b 20 77 65 20 73 74 61 72 74 65 ;; we starte
5280: 64 20 73 69 6e 63 65 20 63 75 72 72 65 6e 74 20 d since current
5290: 72 65 2d 67 65 6e 20 69 6e 20 66 6c 69 67 68 74 re-gen in flight
52a0: 2c 20 64 65 6c 61 79 20 61 20 6c 69 74 74 6c 65 , delay a little
52b0: 20 61 6e 64 20 74 72 79 20 61 67 61 69 6e 0a 09 and try again..
52c0: 09 20 20 20 20 28 62 65 67 69 6e 0a 09 09 20 20 . (begin...
52d0: 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 (debug:print
52e0: 2d 69 6e 66 6f 20 31 20 2a 64 65 66 61 75 6c 74 -info 1 *default
52f0: 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 57 61 69 74 -log-port* "Wait
5300: 69 6e 67 20 74 6f 20 75 70 64 61 74 65 20 22 20 ing to update "
5310: 6f 75 74 70 75 74 66 69 6c 65 6e 61 6d 65 20 22 outputfilename "
5320: 2c 20 61 6e 6f 74 68 65 72 20 74 65 73 74 20 63 , another test c
5330: 75 72 72 65 6e 74 6c 79 20 75 70 64 61 74 69 6e urrently updatin
5340: 67 20 69 74 22 29 0a 09 09 20 20 20 20 20 20 28 g it")... (
5350: 74 68 72 65 61 64 2d 73 6c 65 65 70 21 20 28 2b thread-sleep! (+
5360: 20 35 20 28 72 61 6e 64 6f 6d 20 35 29 29 29 20 5 (random 5)))
5370: 3b 3b 20 64 65 6c 61 79 20 62 65 74 77 65 65 6e ;; delay between
5380: 20 35 20 61 6e 64 20 31 30 20 73 65 63 6f 6e 64 5 and 10 second
5390: 73 0a 09 09 20 20 20 20 20 20 28 6c 6f 6f 70 20 s... (loop
53a0: 28 63 6f 6d 6d 6f 6e 3a 73 69 6d 70 6c 65 2d 66 (common:simple-f
53b0: 69 6c 65 2d 6c 6f 63 6b 20 6c 6f 63 6b 66 29 29 ile-lock lockf))
53c0: 29 29 29 29 29 29 29 29 0a 0a 28 64 65 66 69 6e ))))))))..(defin
53d0: 65 20 28 74 65 73 74 73 3a 67 65 6e 65 72 61 74 e (tests:generat
53e0: 65 2d 68 74 6d 6c 2d 73 75 6d 6d 61 72 79 2d 66 e-html-summary-f
53f0: 6f 72 2d 69 74 65 72 61 74 65 64 2d 74 65 73 74 or-iterated-test
5400: 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 69 64 20 run-id test-id
5410: 74 65 73 74 2d 6e 61 6d 65 20 6f 75 74 70 75 74 test-name output
5420: 66 69 6c 65 6e 61 6d 65 29 0a 20 20 28 6c 65 74 filename). (let
5430: 20 28 28 63 6f 75 6e 74 73 20 20 20 20 20 20 20 ((counts
5440: 20 20 20 20 20 20 20 28 6d 61 6b 65 2d 68 61 73 (make-has
5450: 68 2d 74 61 62 6c 65 29 29 0a 09 28 73 74 61 74 h-table))..(stat
5460: 65 63 6f 75 6e 74 73 20 20 20 20 20 20 20 20 20 ecounts
5470: 28 6d 61 6b 65 2d 68 61 73 68 2d 74 61 62 6c 65 (make-hash-table
5480: 29 29 0a 09 28 6f 75 74 74 78 74 20 20 20 20 20 ))..(outtxt
5490: 20 20 20 20 20 20 20 20 20 22 22 29 0a 09 28 74 "")..(t
54a0: 6f 74 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ot
54b0: 20 20 20 30 29 0a 09 28 74 65 73 74 64 61 74 20 0)..(testdat
54c0: 20 20 20 20 20 20 20 20 20 20 20 20 28 72 6d 74 (rmt
54d0: 3a 74 65 73 74 2d 67 65 74 2d 72 65 63 6f 72 64 :test-get-record
54e0: 73 2d 66 6f 72 2d 69 6e 64 65 78 2d 66 69 6c 65 s-for-index-file
54f0: 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 6e 61 6d run-id test-nam
5500: 65 29 29 29 0a 20 20 20 20 28 77 69 74 68 2d 6f e))). (with-o
5510: 75 74 70 75 74 2d 74 6f 2d 66 69 6c 65 20 6f 75 utput-to-file ou
5520: 74 70 75 74 66 69 6c 65 6e 61 6d 65 0a 20 20 20 tputfilename.
5530: 20 20 20 28 6c 61 6d 62 64 61 20 28 29 0a 09 28 (lambda ()..(
5540: 73 65 74 21 20 6f 75 74 74 78 74 20 28 63 6f 6e set! outtxt (con
5550: 63 20 6f 75 74 74 78 74 20 22 3c 68 74 6d 6c 3e c outtxt "<html>
5560: 3c 74 69 74 6c 65 3e 53 75 6d 6d 61 72 79 3a 20 <title>Summary:
5570: 22 20 74 65 73 74 2d 6e 61 6d 65 20 0a 09 09 09 " test-name ....
5580: 20 20 20 22 3c 2f 74 69 74 6c 65 3e 3c 62 6f 64 "</title><bod
5590: 79 3e 3c 68 32 3e 53 75 6d 6d 61 72 79 20 66 6f y><h2>Summary fo
55a0: 72 20 22 20 74 65 73 74 2d 6e 61 6d 65 20 22 3c r " test-name "<
55b0: 2f 68 32 3e 22 29 29 0a 09 28 66 6f 72 2d 65 61 /h2>"))..(for-ea
55c0: 63 68 0a 09 20 28 6c 61 6d 62 64 61 20 28 74 65 ch.. (lambda (te
55d0: 73 74 72 65 63 6f 72 64 29 0a 09 20 20 20 28 6c strecord).. (l
55e0: 65 74 20 28 28 69 64 20 20 20 20 20 20 20 20 20 et ((id
55f0: 20 20 20 20 28 76 65 63 74 6f 72 2d 72 65 66 20 (vector-ref
5600: 74 65 73 74 72 65 63 6f 72 64 20 30 29 29 0a 09 testrecord 0))..
5610: 09 20 28 69 74 65 6d 70 61 74 68 20 20 20 20 20 . (itempath
5620: 20 20 28 76 65 63 74 6f 72 2d 72 65 66 20 74 65 (vector-ref te
5630: 73 74 72 65 63 6f 72 64 20 31 29 29 0a 09 09 20 strecord 1))...
5640: 28 73 74 61 74 65 20 20 20 20 20 20 20 20 20 20 (state
5650: 28 76 65 63 74 6f 72 2d 72 65 66 20 74 65 73 74 (vector-ref test
5660: 72 65 63 6f 72 64 20 32 29 29 0a 09 09 20 28 73 record 2))... (s
5670: 74 61 74 75 73 20 20 20 20 20 20 20 20 20 28 76 tatus (v
5680: 65 63 74 6f 72 2d 72 65 66 20 74 65 73 74 72 65 ector-ref testre
5690: 63 6f 72 64 20 33 29 29 0a 09 09 20 28 72 75 6e cord 3))... (run
56a0: 5f 64 75 72 61 74 69 6f 6e 20 20 20 28 76 65 63 _duration (vec
56b0: 74 6f 72 2d 72 65 66 20 74 65 73 74 72 65 63 6f tor-ref testreco
56c0: 72 64 20 34 29 29 0a 09 09 20 28 6c 6f 67 66 20 rd 4))... (logf
56d0: 20 20 20 20 20 20 20 20 20 20 28 76 65 63 74 6f (vecto
56e0: 72 2d 72 65 66 20 74 65 73 74 72 65 63 6f 72 64 r-ref testrecord
56f0: 20 35 29 29 0a 09 09 20 28 63 6f 6d 6d 65 6e 74 5))... (comment
5700: 20 20 20 20 20 20 20 20 28 76 65 63 74 6f 72 2d (vector-
5710: 72 65 66 20 74 65 73 74 72 65 63 6f 72 64 20 36 ref testrecord 6
5720: 29 29 29 0a 09 20 20 20 20 20 28 68 61 73 68 2d ))).. (hash-
5730: 74 61 62 6c 65 2d 73 65 74 21 20 63 6f 75 6e 74 table-set! count
5740: 73 20 73 74 61 74 75 73 20 28 2b 20 31 20 28 68 s status (+ 1 (h
5750: 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 ash-table-ref/de
5760: 66 61 75 6c 74 20 63 6f 75 6e 74 73 20 73 74 61 fault counts sta
5770: 74 75 73 20 30 29 29 29 0a 09 20 20 20 20 20 28 tus 0))).. (
5780: 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 hash-table-set!
5790: 73 74 61 74 65 63 6f 75 6e 74 73 20 73 74 61 74 statecounts stat
57a0: 65 20 28 2b 20 31 20 28 68 61 73 68 2d 74 61 62 e (+ 1 (hash-tab
57b0: 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 73 le-ref/default s
57c0: 74 61 74 65 63 6f 75 6e 74 73 20 73 74 61 74 65 tatecounts state
57d0: 20 30 29 29 29 0a 09 20 20 20 20 20 28 73 65 74 0))).. (set
57e0: 21 20 6f 75 74 74 78 74 20 28 63 6f 6e 63 20 6f ! outtxt (conc o
57f0: 75 74 74 78 74 20 22 3c 74 72 3e 22 0a 09 09 09 uttxt "<tr>"....
5800: 09 3b 3b 20 22 3c 74 64 3e 3c 61 20 68 72 65 66 .;; "<td><a href
5810: 3d 5c 22 22 20 69 74 65 6d 70 61 74 68 20 22 2f =\"" itempath "/
5820: 22 20 6c 6f 67 66 20 22 5c 22 3e 20 22 20 69 74 " logf "\"> " it
5830: 65 6d 70 61 74 68 20 22 3c 2f 61 3e 3c 2f 74 64 empath "</a></td
5840: 3e 22 20 0a 09 09 09 09 22 3c 74 64 3e 3c 61 20 >" ....."<td><a
5850: 68 72 65 66 3d 5c 22 22 20 69 74 65 6d 70 61 74 href=\"" itempat
5860: 68 20 22 2f 74 65 73 74 2d 73 75 6d 6d 61 72 79 h "/test-summary
5870: 2e 68 74 6d 6c 5c 22 3e 20 22 20 69 74 65 6d 70 .html\"> " itemp
5880: 61 74 68 20 22 3c 2f 61 3e 3c 2f 74 64 3e 22 20 ath "</a></td>"
5890: 0a 09 09 09 09 22 3c 74 64 3e 22 20 73 74 61 74 ....."<td>" stat
58a0: 65 20 20 20 20 22 3c 2f 74 64 3e 22 20 0a 09 09 e "</td>" ...
58b0: 09 09 22 3c 74 64 3e 3c 66 6f 6e 74 20 63 6f 6c .."<td><font col
58c0: 6f 72 3d 22 20 28 63 6f 6d 6d 6f 6e 3a 67 65 74 or=" (common:get
58d0: 2d 63 6f 6c 6f 72 2d 66 72 6f 6d 2d 73 74 61 74 -color-from-stat
58e0: 75 73 20 73 74 61 74 75 73 29 0a 09 09 09 09 22 us status)....."
58f0: 3e 22 20 20 20 73 74 61 74 75 73 20 20 20 22 3c >" status "<
5900: 2f 66 6f 6e 74 3e 3c 2f 74 64 3e 22 0a 09 09 09 /font></td>"....
5910: 09 22 3c 74 64 3e 22 20 28 69 66 20 28 65 71 75 ."<td>" (if (equ
5920: 61 6c 3f 20 63 6f 6d 6d 65 6e 74 20 22 22 29 0a al? comment "").
5930: 09 09 09 09 09 20 20 20 22 26 6e 62 73 70 3b 22 ..... " "
5940: 0a 09 09 09 09 09 20 20 20 63 6f 6d 6d 65 6e 74 ...... comment
5950: 29 20 22 3c 2f 74 64 3e 22 0a 09 09 09 09 09 20 ) "</td>"......
5960: 20 20 22 3c 2f 74 72 3e 22 29 29 29 29 0a 09 20 "</tr>"))))..
5970: 28 69 66 20 28 6c 69 73 74 3f 20 74 65 73 74 64 (if (list? testd
5980: 61 74 29 0a 09 20 20 20 20 20 74 65 73 74 64 61 at).. testda
5990: 74 0a 09 20 20 20 20 20 28 62 65 67 69 6e 0a 09 t.. (begin..
59a0: 20 20 20 20 20 20 20 28 70 72 69 6e 74 20 22 45 (print "E
59b0: 52 52 4f 52 3a 20 66 61 69 6c 65 64 20 74 6f 20 RROR: failed to
59c0: 67 65 74 20 72 65 63 6f 72 64 73 20 77 69 74 68 get records with
59d0: 20 72 6d 74 3a 74 65 73 74 2d 67 65 74 2d 72 65 rmt:test-get-re
59e0: 63 6f 72 64 73 2d 66 6f 72 2d 69 6e 64 65 78 2d cords-for-index-
59f0: 66 69 6c 65 20 72 75 6e 2d 69 64 3d 22 20 72 75 file run-id=" ru
5a00: 6e 2d 69 64 20 22 74 65 73 74 2d 6e 61 6d 65 3d n-id "test-name=
5a10: 22 20 74 65 73 74 2d 6e 61 6d 65 29 0a 09 20 20 " test-name)..
5a20: 20 20 20 20 20 27 28 29 29 29 29 0a 09 0a 09 28 '())))....(
5a30: 70 72 69 6e 74 20 22 3c 74 61 62 6c 65 3e 3c 74 print "<table><t
5a40: 72 3e 3c 74 64 20 76 61 6c 69 67 6e 3d 5c 22 74 r><td valign=\"t
5a50: 6f 70 5c 22 3e 22 29 0a 09 3b 3b 20 50 72 69 6e op\">")..;; Prin
5a60: 74 20 6f 75 74 20 73 74 61 74 73 20 66 6f 72 20 t out stats for
5a70: 73 74 61 74 75 73 0a 09 28 73 65 74 21 20 74 6f status..(set! to
5a80: 74 20 30 29 0a 09 28 70 72 69 6e 74 20 22 3c 74 t 0)..(print "<t
5a90: 61 62 6c 65 20 63 65 6c 6c 73 70 61 63 69 6e 67 able cellspacing
5aa0: 3d 5c 22 30 5c 22 20 62 6f 72 64 65 72 3d 5c 22 =\"0\" border=\"
5ab0: 31 5c 22 3e 3c 74 72 3e 3c 74 64 20 63 6f 6c 73 1\"><tr><td cols
5ac0: 70 61 6e 3d 5c 22 32 5c 22 3e 3c 68 32 3e 53 74 pan=\"2\"><h2>St
5ad0: 61 74 65 20 73 74 61 74 73 3c 2f 68 32 3e 3c 2f ate stats</h2></
5ae0: 74 64 3e 3c 2f 74 72 3e 22 29 0a 09 28 66 6f 72 td></tr>")..(for
5af0: 2d 65 61 63 68 20 28 6c 61 6d 62 64 61 20 28 73 -each (lambda (s
5b00: 74 61 74 65 29 0a 09 09 20 20 20 20 28 73 65 74 tate)... (set
5b10: 21 20 74 6f 74 20 28 2b 20 74 6f 74 20 28 68 61 ! tot (+ tot (ha
5b20: 73 68 2d 74 61 62 6c 65 2d 72 65 66 20 73 74 61 sh-table-ref sta
5b30: 74 65 63 6f 75 6e 74 73 20 73 74 61 74 65 29 29 tecounts state))
5b40: 29 0a 09 09 20 20 20 20 28 70 72 69 6e 74 20 22 )... (print "
5b50: 3c 74 72 3e 3c 74 64 3e 22 20 73 74 61 74 65 20 <tr><td>" state
5b60: 22 3c 2f 74 64 3e 3c 74 64 3e 22 20 28 68 61 73 "</td><td>" (has
5b70: 68 2d 74 61 62 6c 65 2d 72 65 66 20 73 74 61 74 h-table-ref stat
5b80: 65 63 6f 75 6e 74 73 20 73 74 61 74 65 29 20 22 ecounts state) "
5b90: 3c 2f 74 64 3e 3c 2f 74 72 3e 22 29 29 0a 09 09 </td></tr>"))...
5ba0: 20 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 6b 65 (hash-table-ke
5bb0: 79 73 20 73 74 61 74 65 63 6f 75 6e 74 73 29 29 ys statecounts))
5bc0: 0a 09 28 70 72 69 6e 74 20 22 3c 74 72 3e 3c 74 ..(print "<tr><t
5bd0: 64 3e 54 6f 74 61 6c 3c 2f 74 64 3e 3c 74 64 3e d>Total</td><td>
5be0: 22 20 74 6f 74 20 22 3c 2f 74 64 3e 3c 2f 74 72 " tot "</td></tr
5bf0: 3e 3c 2f 74 61 62 6c 65 3e 22 29 0a 09 28 70 72 ></table>")..(pr
5c00: 69 6e 74 20 22 3c 2f 74 64 3e 3c 74 64 20 76 61 int "</td><td va
5c10: 6c 69 67 6e 3d 5c 22 74 6f 70 5c 22 3e 22 29 0a lign=\"top\">").
5c20: 09 3b 3b 20 50 72 69 6e 74 20 6f 75 74 20 73 74 .;; Print out st
5c30: 61 74 73 20 66 6f 72 20 73 74 61 74 65 0a 09 28 ats for state..(
5c40: 73 65 74 21 20 74 6f 74 20 30 29 0a 09 28 70 72 set! tot 0)..(pr
5c50: 69 6e 74 20 22 3c 74 61 62 6c 65 20 63 65 6c 6c int "<table cell
5c60: 73 70 61 63 69 6e 67 3d 5c 22 30 5c 22 20 62 6f spacing=\"0\" bo
5c70: 72 64 65 72 3d 5c 22 31 5c 22 3e 3c 74 72 3e 3c rder=\"1\"><tr><
5c80: 74 64 20 63 6f 6c 73 70 61 6e 3d 5c 22 32 5c 22 td colspan=\"2\"
5c90: 3e 3c 68 32 3e 53 74 61 74 75 73 20 73 74 61 74 ><h2>Status stat
5ca0: 73 3c 2f 68 32 3e 3c 2f 74 64 3e 3c 2f 74 72 3e s</h2></td></tr>
5cb0: 22 29 0a 09 28 66 6f 72 2d 65 61 63 68 20 28 6c ")..(for-each (l
5cc0: 61 6d 62 64 61 20 28 73 74 61 74 75 73 29 0a 09 ambda (status)..
5cd0: 09 20 20 20 20 28 73 65 74 21 20 74 6f 74 20 28 . (set! tot (
5ce0: 2b 20 74 6f 74 20 28 68 61 73 68 2d 74 61 62 6c + tot (hash-tabl
5cf0: 65 2d 72 65 66 20 63 6f 75 6e 74 73 20 73 74 61 e-ref counts sta
5d00: 74 75 73 29 29 29 0a 09 09 20 20 20 20 28 70 72 tus)))... (pr
5d10: 69 6e 74 20 22 3c 74 72 3e 3c 74 64 3e 3c 66 6f int "<tr><td><fo
5d20: 6e 74 20 63 6f 6c 6f 72 3d 5c 22 22 20 28 63 6f nt color=\"" (co
5d30: 6d 6d 6f 6e 3a 67 65 74 2d 63 6f 6c 6f 72 2d 66 mmon:get-color-f
5d40: 72 6f 6d 2d 73 74 61 74 75 73 20 73 74 61 74 75 rom-status statu
5d50: 73 29 20 22 5c 22 3e 22 20 73 74 61 74 75 73 0a s) "\">" status.
5d60: 09 09 09 20 20 20 22 3c 2f 66 6f 6e 74 3e 3c 2f ... "</font></
5d70: 74 64 3e 3c 74 64 3e 22 20 28 68 61 73 68 2d 74 td><td>" (hash-t
5d80: 61 62 6c 65 2d 72 65 66 20 63 6f 75 6e 74 73 20 able-ref counts
5d90: 73 74 61 74 75 73 29 20 22 3c 2f 74 64 3e 3c 2f status) "</td></
5da0: 74 72 3e 22 29 29 0a 09 09 20 20 28 68 61 73 68 tr>"))... (hash
5db0: 2d 74 61 62 6c 65 2d 6b 65 79 73 20 63 6f 75 6e -table-keys coun
5dc0: 74 73 29 29 0a 09 28 70 72 69 6e 74 20 22 3c 74 ts))..(print "<t
5dd0: 72 3e 3c 74 64 3e 54 6f 74 61 6c 3c 2f 74 64 3e r><td>Total</td>
5de0: 3c 74 64 3e 22 20 74 6f 74 20 22 3c 2f 74 64 3e <td>" tot "</td>
5df0: 3c 2f 74 72 3e 3c 2f 74 61 62 6c 65 3e 22 29 0a </tr></table>").
5e00: 09 28 70 72 69 6e 74 20 22 3c 2f 74 64 3e 3c 2f .(print "</td></
5e10: 74 64 3e 3c 2f 74 72 3e 3c 2f 74 61 62 6c 65 3e td></tr></table>
5e20: 22 29 0a 09 0a 09 28 70 72 69 6e 74 20 22 3c 74 ")....(print "<t
5e30: 61 62 6c 65 20 63 65 6c 6c 73 70 61 63 69 6e 67 able cellspacing
5e40: 3d 5c 22 30 5c 22 20 62 6f 72 64 65 72 3d 5c 22 =\"0\" border=\"
5e50: 31 5c 22 3e 22 20 0a 09 20 20 20 20 20 20 20 22 1\">" .. "
5e60: 3c 74 72 3e 3c 74 64 3e 49 74 65 6d 3c 2f 74 64 <tr><td>Item</td
5e70: 3e 3c 74 64 3e 53 74 61 74 65 3c 2f 74 64 3e 3c ><td>State</td><
5e80: 74 64 3e 53 74 61 74 75 73 3c 2f 74 64 3e 3c 74 td>Status</td><t
5e90: 64 3e 43 6f 6d 6d 65 6e 74 3c 2f 74 64 3e 22 0a d>Comment</td>".
5ea0: 09 20 20 20 20 20 20 20 6f 75 74 74 78 74 20 22 . outtxt "
5eb0: 3c 2f 74 61 62 6c 65 3e 3c 2f 62 6f 64 79 3e 3c </table></body><
5ec0: 2f 68 74 6d 6c 3e 22 29 0a 09 3b 3b 20 28 72 65 /html>")..;; (re
5ed0: 6c 65 61 73 65 2d 64 6f 74 2d 6c 6f 63 6b 20 6f lease-dot-lock o
5ee0: 75 74 70 75 74 66 69 6c 65 6e 61 6d 65 29 0a 09 utputfilename)..
5ef0: 3b 3b 28 72 6d 74 3a 75 70 64 61 74 65 2d 72 75 ;;(rmt:update-ru
5f00: 6e 2d 73 74 61 74 73 20 0a 09 3b 3b 20 72 75 6e n-stats ..;; run
5f10: 2d 69 64 0a 09 3b 3b 20 28 68 61 73 68 2d 74 61 -id..;; (hash-ta
5f20: 62 6c 65 2d 6d 61 70 0a 09 3b 3b 20 20 73 74 61 ble-map..;; sta
5f30: 74 65 2d 73 74 61 74 75 73 2d 63 6f 75 6e 74 73 te-status-counts
5f40: 0a 09 3b 3b 20 20 28 6c 61 6d 62 64 61 20 28 6b ..;; (lambda (k
5f50: 65 79 20 76 61 6c 29 0a 09 3b 3b 09 28 61 70 70 ey val)..;;.(app
5f60: 65 6e 64 20 6b 65 79 20 28 6c 69 73 74 20 76 61 end key (list va
5f70: 6c 29 29 29 29 29 0a 09 29 29 29 29 0a 0a 28 64 l)))))..))))..(d
5f80: 65 66 69 6e 65 20 74 65 73 74 73 3a 63 73 73 2d efine tests:css-
5f90: 6a 73 63 72 69 70 74 2d 62 6c 6f 63 6b 0a 23 3c jscript-block.#<
5fa0: 3c 45 4f 46 0a 3c 73 74 79 6c 65 20 74 79 70 65 <EOF.<style type
5fb0: 3d 22 74 65 78 74 2f 63 73 73 22 3e 0a 75 6c 2e ="text/css">.ul.
5fc0: 4c 69 6e 6b 65 64 4c 69 73 74 20 7b 20 64 69 73 LinkedList { dis
5fd0: 70 6c 61 79 3a 20 62 6c 6f 63 6b 3b 20 7d 0a 2f play: block; }./
5fe0: 2a 20 75 6c 2e 4c 69 6e 6b 65 64 4c 69 73 74 20 * ul.LinkedList
5ff0: 75 6c 20 7b 20 64 69 73 70 6c 61 79 3a 20 6e 6f ul { display: no
6000: 6e 65 3b 20 7d 20 2a 2f 0a 2e 48 61 6e 64 43 75 ne; } */..HandCu
6010: 72 73 6f 72 53 74 79 6c 65 20 7b 20 63 75 72 73 rsorStyle { curs
6020: 6f 72 3a 20 70 6f 69 6e 74 65 72 3b 20 63 75 72 or: pointer; cur
6030: 73 6f 72 3a 20 68 61 6e 64 3b 20 7d 20 20 2f 2a sor: hand; } /*
6040: 20 46 6f 72 20 49 45 20 2a 2f 0a 74 68 20 7b 62 For IE */.th {b
6050: 61 63 6b 67 72 6f 75 6e 64 2d 63 6f 6c 6f 72 3a ackground-color:
6060: 20 23 38 63 38 63 38 63 3b 7d 0a 74 64 2e 74 65 #8c8c8c;}.td.te
6070: 73 74 20 7b 62 61 63 6b 67 72 6f 75 6e 64 2d 63 st {background-c
6080: 6f 6c 6f 72 3a 20 23 64 39 64 62 64 64 3b 7d 0a olor: #d9dbdd;}.
6090: 74 64 2e 50 41 53 53 20 7b 62 61 63 6b 67 72 6f td.PASS {backgro
60a0: 75 6e 64 2d 63 6f 6c 6f 72 3a 20 23 33 34 37 35 und-color: #3475
60b0: 33 33 3b 7d 0a 74 64 2e 46 41 49 4c 20 7b 62 61 33;}.td.FAIL {ba
60c0: 63 6b 67 72 6f 75 6e 64 2d 63 6f 6c 6f 72 3a 20 ckground-color:
60d0: 23 63 63 32 38 31 32 3b 7d 0a 0a 20 20 3c 2f 73 #cc2812;}.. </s
60e0: 74 79 6c 65 3e 0a 20 20 3c 73 63 72 69 70 74 20 tyle>. <script
60f0: 73 72 63 3d 2f 6e 66 73 2f 73 69 74 65 2f 64 69 src=/nfs/site/di
6100: 73 6b 73 2f 63 68 5f 63 69 61 66 5f 64 69 73 6b sks/ch_ciaf_disk
6110: 30 32 33 2f 66 64 6b 5f 67 77 61 5f 64 69 73 6b 023/fdk_gwa_disk
6120: 30 30 33 2f 70 6a 68 61 74 77 61 6c 2f 66 64 6b 003/pjhatwal/fdk
6130: 2f 64 6f 63 73 2f 71 61 2d 65 6e 76 2d 74 65 61 /docs/qa-env-tea
6140: 6d 2f 6a 71 75 65 72 79 2d 33 2e 31 2e 30 2e 73 m/jquery-3.1.0.s
6150: 6c 69 6d 2e 6d 69 6e 2e 6a 73 3e 3c 2f 73 63 72 lim.min.js></scr
6160: 69 70 74 3e 0a 0a 0a 20 20 3c 73 63 72 69 70 74 ipt>... <script
6170: 20 74 79 70 65 3d 22 74 65 78 74 2f 4a 61 76 61 type="text/Java
6180: 53 63 72 69 70 74 22 3e 0a 0a 20 20 20 20 66 75 Script">.. fu
6190: 6e 63 74 69 6f 6e 20 66 69 6c 74 65 72 73 6f 6d nction filtersom
61a0: 65 28 29 20 7b 0a 20 20 24 28 22 74 72 22 29 2e e() {. $("tr").
61b0: 73 68 6f 77 28 29 3b 0a 20 20 24 28 22 2e 74 65 show();. $(".te
61c0: 73 74 22 29 2e 66 69 6c 74 65 72 28 0a 20 20 20 st").filter(.
61d0: 20 66 75 6e 63 74 69 6f 6e 28 29 20 7b 0a 20 20 function() {.
61e0: 20 20 20 20 76 61 72 20 6e 61 6d 65 73 20 3d 20 var names =
61f0: 24 28 27 23 74 65 73 74 6e 61 6d 65 27 29 2e 76 $('#testname').v
6200: 61 6c 28 29 2e 73 70 6c 69 74 28 27 2c 27 29 3b al().split(',');
6210: 0a 20 20 20 20 20 20 76 61 72 20 67 6f 6f 64 3d . var good=
6220: 31 3b 0a 20 20 20 20 20 20 66 6f 72 20 28 76 61 1;. for (va
6230: 72 20 69 3d 30 2c 20 6c 65 6e 3d 6e 61 6d 65 73 r i=0, len=names
6240: 2e 6c 65 6e 67 74 68 3b 20 69 3c 6c 65 6e 3b 20 .length; i<len;
6250: 69 2b 2b 29 20 7b 0a 20 20 20 20 20 20 20 20 76 i++) {. v
6260: 61 72 20 75 6e 61 6d 65 3d 6e 61 6d 65 73 5b 69 ar uname=names[i
6270: 5d 3b 0a 20 20 20 20 20 20 20 20 63 6f 6e 73 6f ];. conso
6280: 6c 65 2e 6c 6f 67 28 22 54 72 79 69 6e 67 20 74 le.log("Trying t
6290: 6f 20 63 68 65 63 6b 20 66 6f 72 20 22 20 2b 20 o check for " +
62a0: 75 6e 61 6d 65 29 3b 20 0a 20 20 20 20 20 20 20 uname); .
62b0: 20 69 66 28 24 28 74 68 69 73 29 2e 74 65 78 74 if($(this).text
62c0: 28 29 2e 69 6e 64 65 78 4f 66 28 75 6e 61 6d 65 ().indexOf(uname
62d0: 29 20 21 3d 20 2d 31 29 20 7b 0a 20 20 20 20 20 ) != -1) {.
62e0: 20 20 20 20 20 67 6f 6f 64 3d 20 30 3b 0a 20 20 good= 0;.
62f0: 20 20 20 20 20 20 20 20 63 6f 6e 73 6f 6c 65 2e console.
6300: 6c 6f 67 28 22 46 6f 75 6e 64 20 22 2b 75 6e 61 log("Found "+una
6310: 6d 65 29 3b 0a 20 20 20 20 20 20 20 20 7d 0a 20 me);. }.
6320: 20 20 20 20 20 7d 0a 20 20 20 20 20 20 72 65 74 }. ret
6330: 75 72 6e 20 67 6f 6f 64 3b 20 0a 20 20 20 20 7d urn good; . }
6340: 0a 20 20 29 2e 70 61 72 65 6e 74 28 29 2e 68 69 . ).parent().hi
6350: 64 65 28 29 3b 0a 2f 2f 20 20 24 28 22 2e 73 75 de();.// $(".su
6360: 6d 22 29 2e 73 68 6f 77 28 29 3b 0a 7d 0a 20 20 m").show();.}.
6370: 0a 20 20 20 20 2f 2f 20 41 64 64 20 74 68 69 73 . // Add this
6380: 20 74 6f 20 74 68 65 20 6f 6e 6c 6f 61 64 20 65 to the onload e
6390: 76 65 6e 74 20 6f 66 20 74 68 65 20 42 4f 44 59 vent of the BODY
63a0: 20 65 6c 65 6d 65 6e 74 0a 20 20 20 20 66 75 6e element. fun
63b0: 63 74 69 6f 6e 20 61 64 64 45 76 65 6e 74 73 28 ction addEvents(
63c0: 29 20 7b 0a 20 20 20 20 20 20 61 63 74 69 76 61 ) {. activa
63d0: 74 65 54 72 65 65 28 64 6f 63 75 6d 65 6e 74 2e teTree(document.
63e0: 67 65 74 45 6c 65 6d 65 6e 74 42 79 49 64 28 22 getElementById("
63f0: 4c 69 6e 6b 65 64 4c 69 73 74 31 22 29 29 3b 0a LinkedList1"));.
6400: 20 20 20 20 7d 0a 0a 20 20 20 20 2f 2f 20 54 68 }.. // Th
6410: 69 73 20 66 75 6e 63 74 69 6f 6e 20 74 72 61 76 is function trav
6420: 65 72 73 65 73 20 74 68 65 20 6c 69 73 74 20 61 erses the list a
6430: 6e 64 20 61 64 64 20 6c 69 6e 6b 73 20 0a 20 20 nd add links .
6440: 20 20 2f 2f 20 74 6f 20 6e 65 73 74 65 64 20 6c // to nested l
6450: 69 73 74 20 69 74 65 6d 73 0a 20 20 20 20 66 75 ist items. fu
6460: 6e 63 74 69 6f 6e 20 61 63 74 69 76 61 74 65 54 nction activateT
6470: 72 65 65 28 6f 4c 69 73 74 29 20 7b 0a 20 20 20 ree(oList) {.
6480: 20 20 20 2f 2f 20 43 6f 6c 6c 61 70 73 65 20 74 // Collapse t
6490: 68 65 20 74 72 65 65 0a 20 20 20 20 20 20 66 6f he tree. fo
64a0: 72 20 28 76 61 72 20 69 3d 30 3b 20 69 20 3c 20 r (var i=0; i <
64b0: 6f 4c 69 73 74 2e 67 65 74 45 6c 65 6d 65 6e 74 oList.getElement
64c0: 73 42 79 54 61 67 4e 61 6d 65 28 22 75 6c 22 29 sByTagName("ul")
64d0: 2e 6c 65 6e 67 74 68 3b 20 69 2b 2b 29 20 7b 0a .length; i++) {.
64e0: 20 20 20 20 20 20 20 20 6f 4c 69 73 74 2e 67 65 oList.ge
64f0: 74 45 6c 65 6d 65 6e 74 73 42 79 54 61 67 4e 61 tElementsByTagNa
6500: 6d 65 28 22 75 6c 22 29 5b 69 5d 2e 73 74 79 6c me("ul")[i].styl
6510: 65 2e 64 69 73 70 6c 61 79 3d 22 6e 6f 6e 65 22 e.display="none"
6520: 3b 20 20 20 20 20 20 20 20 20 20 20 20 0a 20 20 ; .
6530: 20 20 20 20 7d 20 20 20 20 20 20 20 20 20 20 20 }
6540: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
6550: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
6560: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
6570: 20 20 20 20 20 20 20 0a 20 20 20 20 20 20 2f 2f . //
6580: 20 41 64 64 20 74 68 65 20 63 6c 69 63 6b 2d 65 Add the click-e
6590: 76 65 6e 74 20 68 61 6e 64 6c 65 72 20 74 6f 20 vent handler to
65a0: 74 68 65 20 6c 69 73 74 20 69 74 65 6d 73 0a 20 the list items.
65b0: 20 20 20 20 20 69 66 20 28 6f 4c 69 73 74 2e 61 if (oList.a
65c0: 64 64 45 76 65 6e 74 4c 69 73 74 65 6e 65 72 29 ddEventListener)
65d0: 20 7b 0a 20 20 20 20 20 20 20 20 6f 4c 69 73 74 {. oList
65e0: 2e 61 64 64 45 76 65 6e 74 4c 69 73 74 65 6e 65 .addEventListene
65f0: 72 28 22 63 6c 69 63 6b 22 2c 20 74 6f 67 67 6c r("click", toggl
6600: 65 42 72 61 6e 63 68 2c 20 66 61 6c 73 65 29 3b eBranch, false);
6610: 0a 20 20 20 20 20 20 7d 20 65 6c 73 65 20 69 66 . } else if
6620: 20 28 6f 4c 69 73 74 2e 61 74 74 61 63 68 45 76 (oList.attachEv
6630: 65 6e 74 29 20 7b 20 2f 2f 20 46 6f 72 20 49 45 ent) { // For IE
6640: 0a 20 20 20 20 20 20 20 20 6f 4c 69 73 74 2e 61 . oList.a
6650: 74 74 61 63 68 45 76 65 6e 74 28 22 6f 6e 63 6c ttachEvent("oncl
6660: 69 63 6b 22 2c 20 74 6f 67 67 6c 65 42 72 61 6e ick", toggleBran
6670: 63 68 29 3b 0a 20 20 20 20 20 20 7d 0a 20 20 20 ch);. }.
6680: 20 20 20 2f 2f 20 4d 61 6b 65 20 74 68 65 20 6e // Make the n
6690: 65 73 74 65 64 20 69 74 65 6d 73 20 6c 6f 6f 6b ested items look
66a0: 20 6c 69 6b 65 20 6c 69 6e 6b 73 0a 20 20 20 20 like links.
66b0: 20 20 61 64 64 4c 69 6e 6b 73 54 6f 42 72 61 6e addLinksToBran
66c0: 63 68 65 73 28 6f 4c 69 73 74 29 3b 0a 20 20 20 ches(oList);.
66d0: 20 7d 0a 0a 20 20 20 20 2f 2f 20 54 68 69 73 20 }.. // This
66e0: 69 73 20 74 68 65 20 63 6c 69 63 6b 2d 65 76 65 is the click-eve
66f0: 6e 74 20 68 61 6e 64 6c 65 72 0a 20 20 20 20 66 nt handler. f
6700: 75 6e 63 74 69 6f 6e 20 74 6f 67 67 6c 65 42 72 unction toggleBr
6710: 61 6e 63 68 28 65 76 65 6e 74 29 20 7b 0a 20 20 anch(event) {.
6720: 20 20 20 20 76 61 72 20 6f 42 72 61 6e 63 68 2c var oBranch,
6730: 20 63 53 75 62 42 72 61 6e 63 68 65 73 3b 0a 20 cSubBranches;.
6740: 20 20 20 20 20 69 66 20 28 65 76 65 6e 74 2e 74 if (event.t
6750: 61 72 67 65 74 29 20 7b 0a 20 20 20 20 20 20 20 arget) {.
6760: 20 6f 42 72 61 6e 63 68 20 3d 20 65 76 65 6e 74 oBranch = event
6770: 2e 74 61 72 67 65 74 3b 0a 20 20 20 20 20 20 7d .target;. }
6780: 20 65 6c 73 65 20 69 66 20 28 65 76 65 6e 74 2e else if (event.
6790: 73 72 63 45 6c 65 6d 65 6e 74 29 20 7b 20 2f 2f srcElement) { //
67a0: 20 46 6f 72 20 49 45 0a 20 20 20 20 20 20 20 20 For IE.
67b0: 6f 42 72 61 6e 63 68 20 3d 20 65 76 65 6e 74 2e oBranch = event.
67c0: 73 72 63 45 6c 65 6d 65 6e 74 3b 0a 20 20 20 20 srcElement;.
67d0: 20 20 7d 0a 20 20 20 20 20 20 63 53 75 62 42 72 }. cSubBr
67e0: 61 6e 63 68 65 73 20 3d 20 6f 42 72 61 6e 63 68 anches = oBranch
67f0: 2e 67 65 74 45 6c 65 6d 65 6e 74 73 42 79 54 61 .getElementsByTa
6800: 67 4e 61 6d 65 28 22 75 6c 22 29 3b 0a 20 20 20 gName("ul");.
6810: 20 20 20 69 66 20 28 63 53 75 62 42 72 61 6e 63 if (cSubBranc
6820: 68 65 73 2e 6c 65 6e 67 74 68 20 3e 20 30 29 20 hes.length > 0)
6830: 7b 0a 20 20 20 20 20 20 20 20 69 66 20 28 63 53 {. if (cS
6840: 75 62 42 72 61 6e 63 68 65 73 5b 30 5d 2e 73 74 ubBranches[0].st
6850: 79 6c 65 2e 64 69 73 70 6c 61 79 20 3d 3d 20 22 yle.display == "
6860: 62 6c 6f 63 6b 22 29 20 7b 0a 20 20 20 20 20 20 block") {.
6870: 20 20 20 20 63 53 75 62 42 72 61 6e 63 68 65 73 cSubBranches
6880: 5b 30 5d 2e 73 74 79 6c 65 2e 64 69 73 70 6c 61 [0].style.displa
6890: 79 20 3d 20 22 6e 6f 6e 65 22 3b 0a 20 20 20 20 y = "none";.
68a0: 20 20 20 20 7d 20 65 6c 73 65 20 7b 0a 20 20 20 } else {.
68b0: 20 20 20 20 20 20 20 63 53 75 62 42 72 61 6e 63 cSubBranc
68c0: 68 65 73 5b 30 5d 2e 73 74 79 6c 65 2e 64 69 73 hes[0].style.dis
68d0: 70 6c 61 79 20 3d 20 22 62 6c 6f 63 6b 22 3b 0a play = "block";.
68e0: 20 20 20 20 20 20 20 20 7d 0a 20 20 20 20 20 20 }.
68f0: 7d 0a 20 20 20 20 7d 0a 0a 20 20 20 20 2f 2f 20 }. }.. //
6900: 54 68 69 73 20 66 75 6e 63 74 69 6f 6e 20 6d 61 This function ma
6910: 6b 65 73 20 6e 65 73 74 65 64 20 6c 69 73 74 20 kes nested list
6920: 69 74 65 6d 73 20 6c 6f 6f 6b 20 6c 69 6b 65 20 items look like
6930: 6c 69 6e 6b 73 0a 20 20 20 20 66 75 6e 63 74 69 links. functi
6940: 6f 6e 20 61 64 64 4c 69 6e 6b 73 54 6f 42 72 61 on addLinksToBra
6950: 6e 63 68 65 73 28 6f 4c 69 73 74 29 20 7b 0a 20 nches(oList) {.
6960: 20 20 20 20 20 76 61 72 20 63 42 72 61 6e 63 68 var cBranch
6970: 65 73 20 3d 20 6f 4c 69 73 74 2e 67 65 74 45 6c es = oList.getEl
6980: 65 6d 65 6e 74 73 42 79 54 61 67 4e 61 6d 65 28 ementsByTagName(
6990: 22 6c 69 22 29 3b 0a 20 20 20 20 20 20 76 61 72 "li");. var
69a0: 20 69 2c 20 6e 2c 20 63 53 75 62 42 72 61 6e 63 i, n, cSubBranc
69b0: 68 65 73 3b 0a 20 20 20 20 20 20 69 66 20 28 63 hes;. if (c
69c0: 42 72 61 6e 63 68 65 73 2e 6c 65 6e 67 74 68 20 Branches.length
69d0: 3e 20 30 29 20 7b 0a 20 20 20 20 20 20 20 20 66 > 0) {. f
69e0: 6f 72 20 28 69 3d 30 2c 20 6e 20 3d 20 63 42 72 or (i=0, n = cBr
69f0: 61 6e 63 68 65 73 2e 6c 65 6e 67 74 68 3b 20 69 anches.length; i
6a00: 20 3c 20 6e 3b 20 69 2b 2b 29 20 7b 0a 20 20 20 < n; i++) {.
6a10: 20 20 20 20 20 20 20 63 53 75 62 42 72 61 6e 63 cSubBranc
6a20: 68 65 73 20 3d 20 63 42 72 61 6e 63 68 65 73 5b hes = cBranches[
6a30: 69 5d 2e 67 65 74 45 6c 65 6d 65 6e 74 73 42 79 i].getElementsBy
6a40: 54 61 67 4e 61 6d 65 28 22 75 6c 22 29 3b 0a 20 TagName("ul");.
6a50: 20 20 20 20 20 20 20 20 20 69 66 20 28 63 53 75 if (cSu
6a60: 62 42 72 61 6e 63 68 65 73 2e 6c 65 6e 67 74 68 bBranches.length
6a70: 20 3e 20 30 29 20 7b 0a 20 20 20 20 20 20 20 20 > 0) {.
6a80: 20 20 20 20 61 64 64 4c 69 6e 6b 73 54 6f 42 72 addLinksToBr
6a90: 61 6e 63 68 65 73 28 63 53 75 62 42 72 61 6e 63 anches(cSubBranc
6aa0: 68 65 73 5b 30 5d 29 3b 0a 20 20 20 20 20 20 20 hes[0]);.
6ab0: 20 20 20 20 20 63 42 72 61 6e 63 68 65 73 5b 69 cBranches[i
6ac0: 5d 2e 63 6c 61 73 73 4e 61 6d 65 20 3d 20 22 48 ].className = "H
6ad0: 61 6e 64 43 75 72 73 6f 72 53 74 79 6c 65 22 3b andCursorStyle";
6ae0: 0a 20 20 20 20 20 20 20 20 20 20 20 20 63 42 72 . cBr
6af0: 61 6e 63 68 65 73 5b 69 5d 2e 73 74 79 6c 65 2e anches[i].style.
6b00: 63 6f 6c 6f 72 20 3d 20 22 62 6c 75 65 22 3b 0a color = "blue";.
6b10: 20 20 20 20 20 20 20 20 20 20 20 20 63 53 75 62 cSub
6b20: 42 72 61 6e 63 68 65 73 5b 30 5d 2e 73 74 79 6c Branches[0].styl
6b30: 65 2e 63 6f 6c 6f 72 20 3d 20 22 62 6c 61 63 6b e.color = "black
6b40: 22 3b 0a 20 20 20 20 20 20 20 20 20 20 20 20 63 ";. c
6b50: 53 75 62 42 72 61 6e 63 68 65 73 5b 30 5d 2e 73 SubBranches[0].s
6b60: 74 79 6c 65 2e 63 75 72 73 6f 72 20 3d 20 22 61 tyle.cursor = "a
6b70: 75 74 6f 22 3b 0a 20 20 20 20 20 20 20 20 20 20 uto";.
6b80: 7d 0a 20 20 20 20 20 20 20 20 7d 0a 20 20 20 20 }. }.
6b90: 20 20 7d 0a 20 20 20 20 7d 0a 20 20 3c 2f 73 63 }. }. </sc
6ba0: 72 69 70 74 3e 0a 45 4f 46 0a 29 0a 0a 28 64 65 ript>.EOF.)..(de
6bb0: 66 69 6e 65 20 28 74 65 73 74 73 3a 72 75 6e 2d fine (tests:run-
6bc0: 72 65 63 6f 72 64 2d 3e 74 65 73 74 2d 70 61 74 record->test-pat
6bd0: 68 20 72 75 6e 20 6e 75 6d 6b 65 79 73 29 0a 20 h run numkeys).
6be0: 20 20 28 61 70 70 65 6e 64 20 28 74 61 6b 65 20 (append (take
6bf0: 28 76 65 63 74 6f 72 2d 3e 6c 69 73 74 20 72 75 (vector->list ru
6c00: 6e 29 20 6e 75 6d 6b 65 79 73 29 0a 09 20 20 20 n) numkeys)..
6c10: 28 6c 69 73 74 20 28 76 65 63 74 6f 72 2d 72 65 (list (vector-re
6c20: 66 20 72 75 6e 20 28 2b 20 31 20 6e 75 6d 6b 65 f run (+ 1 numke
6c30: 79 73 29 29 29 29 29 0a 0a 0a 28 64 65 66 69 6e ys)))))...(defin
6c40: 65 20 28 74 65 73 74 73 3a 67 65 74 2d 72 65 73 e (tests:get-res
6c50: 74 2d 64 61 74 61 20 72 75 6e 73 20 68 65 61 64 t-data runs head
6c60: 65 72 20 6e 75 6d 6b 65 79 73 29 0a 20 20 20 28 er numkeys). (
6c70: 6c 65 74 20 28 28 72 65 73 68 20 28 6d 61 6b 65 let ((resh (make
6c80: 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 29 0a 20 -hash-table))).
6c90: 20 20 28 66 6f 72 2d 65 61 63 68 0a 20 20 20 20 (for-each.
6ca0: 20 28 6c 61 6d 62 64 61 20 28 72 75 6e 29 0a 20 (lambda (run).
6cb0: 20 20 20 20 20 20 20 28 6c 65 74 2a 20 28 28 72 (let* ((r
6cc0: 75 6e 2d 69 64 20 28 64 62 3a 67 65 74 2d 76 61 un-id (db:get-va
6cd0: 6c 75 65 2d 62 79 2d 68 65 61 64 65 72 20 72 75 lue-by-header ru
6ce0: 6e 20 68 65 61 64 65 72 20 22 69 64 22 29 29 0a n header "id")).
6cf0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
6d00: 72 75 6e 2d 64 69 72 20 20 20 20 20 20 28 74 65 run-dir (te
6d10: 73 74 73 3a 72 75 6e 2d 72 65 63 6f 72 64 2d 3e sts:run-record->
6d20: 74 65 73 74 2d 70 61 74 68 20 72 75 6e 20 6e 75 test-path run nu
6d30: 6d 6b 65 79 73 29 29 0a 09 20 20 20 20 20 20 20 mkeys))..
6d40: 28 74 65 73 74 2d 64 61 74 61 20 20 20 20 28 72 (test-data (r
6d50: 6d 74 3a 67 65 74 2d 74 65 73 74 73 2d 66 6f 72 mt:get-tests-for
6d60: 2d 72 75 6e 0a 09 09 09 09 20 20 20 72 75 6e 2d -run..... run-
6d70: 69 64 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 id.
6d80: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
6d90: 20 20 20 20 20 20 22 25 22 20 20 20 20 20 20 20 "%"
6da0: 3b 3b 20 74 65 73 74 6e 61 6d 65 70 61 74 74 0a ;; testnamepatt.
6db0: 09 09 09 09 20 20 20 27 28 29 20 20 20 20 20 20 .... '()
6dc0: 20 20 3b 3b 20 73 74 61 74 65 73 0a 09 09 09 09 ;; states.....
6dd0: 20 20 20 27 28 29 20 20 20 20 20 20 20 20 3b 3b '() ;;
6de0: 20 73 74 61 74 75 73 65 73 0a 09 09 09 09 20 20 statuses.....
6df0: 20 23 66 20 20 20 20 20 20 20 20 20 3b 3b 20 6f #f ;; o
6e00: 66 66 73 65 74 0a 09 09 09 09 20 20 20 23 66 20 ffset..... #f
6e10: 20 20 20 20 20 20 20 20 3b 3b 20 6e 75 6d 2d 74 ;; num-t
6e20: 6f 2d 67 65 74 0a 09 09 09 09 20 20 20 23 66 20 o-get..... #f
6e30: 20 20 20 20 20 20 20 20 3b 3b 20 68 69 64 65 2f ;; hide/
6e40: 6e 6f 74 2d 68 69 64 65 0a 09 09 09 09 20 20 20 not-hide.....
6e50: 23 66 20 20 20 20 20 20 20 20 20 3b 3b 20 73 6f #f ;; so
6e60: 72 74 2d 62 79 0a 09 09 09 09 20 20 20 23 66 20 rt-by..... #f
6e70: 20 20 20 20 20 20 20 20 3b 3b 20 73 6f 72 74 2d ;; sort-
6e80: 6f 72 64 65 72 0a 09 09 09 09 20 20 20 23 66 20 order..... #f
6e90: 20 20 20 20 20 20 20 20 3b 3b 20 27 73 68 6f 72 ;; 'shor
6ea0: 74 6c 69 73 74 20 20 20 20 20 20 20 20 20 20 20 tlist
6eb0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
6ec0: 3b 3b 20 71 72 79 74 79 70 65 0a 20 20 20 20 20 ;; qrytype.
6ed0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
6ee0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 30 20 0
6ef0: 20 20 20 20 20 20 20 20 3b 3b 20 6c 61 73 74 20 ;; last
6f00: 75 70 64 61 74 65 0a 09 09 09 09 20 20 20 23 66 update..... #f
6f10: 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 ))).
6f20: 0a 20 20 20 20 20 20 20 20 20 20 20 20 28 6d 61 . (ma
6f30: 70 20 28 6c 61 6d 62 64 61 20 28 74 65 73 74 29 p (lambda (test)
6f40: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
6f50: 20 20 28 6c 65 74 2a 20 28 28 74 65 73 74 2d 6e (let* ((test-n
6f60: 61 6d 65 20 28 76 65 63 74 6f 72 2d 72 65 66 20 ame (vector-ref
6f70: 74 65 73 74 20 32 29 29 0a 20 20 20 20 20 20 20 test 2)).
6f80: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
6f90: 20 28 74 65 73 74 2d 68 74 6d 6c 2d 70 61 74 68 (test-html-path
6fa0: 20 28 63 6f 6e 63 20 28 76 65 63 74 6f 72 2d 72 (conc (vector-r
6fb0: 65 66 20 74 65 73 74 20 31 30 29 20 22 2f 22 20 ef test 10) "/"
6fc0: 28 76 65 63 74 6f 72 2d 72 65 66 20 74 65 73 74 (vector-ref test
6fd0: 20 31 33 29 29 29 0a 20 20 20 20 20 20 20 20 20 13))).
6fe0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
6ff0: 74 65 73 74 2d 69 74 65 6d 20 28 63 6f 6e 63 20 test-item (conc
7000: 74 65 73 74 2d 6e 61 6d 65 20 22 3a 22 20 28 76 test-name ":" (v
7010: 65 63 74 6f 72 2d 72 65 66 20 74 65 73 74 20 31 ector-ref test 1
7020: 31 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 1))).
7030: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 74 65 (te
7040: 73 74 2d 73 74 61 74 75 73 20 28 76 65 63 74 6f st-status (vecto
7050: 72 2d 72 65 66 20 74 65 73 74 20 34 29 29 29 0a r-ref test 4))).
7060: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7070: 20 20 20 20 20 20 20 20 20 0a 20 20 20 20 20 20 .
7080: 20 20 20 20 20 20 20 20 20 20 28 69 66 20 28 6e (if (n
7090: 6f 74 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 ot (hash-table-r
70a0: 65 66 2f 64 65 66 61 75 6c 74 20 72 65 73 68 20 ef/default resh
70b0: 74 65 73 74 2d 6e 61 6d 65 20 20 23 66 29 29 0a test-name #f)).
70c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
70d0: 20 20 20 20 20 20 28 68 61 73 68 2d 74 61 62 6c (hash-tabl
70e0: 65 2d 73 65 74 21 20 72 65 73 68 20 74 65 73 74 e-set! resh test
70f0: 2d 6e 61 6d 65 20 20 20 28 6d 61 6b 65 2d 68 61 -name (make-ha
7100: 73 68 2d 74 61 62 6c 65 29 29 29 0a 20 20 20 20 sh-table))).
7110: 20 20 20 20 20 20 20 20 20 20 20 20 28 69 66 20 (if
7120: 28 6e 6f 74 20 28 68 61 73 68 2d 74 61 62 6c 65 (not (hash-table
7130: 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 28 68 61 -ref/default (ha
7140: 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 sh-table-ref/def
7150: 61 75 6c 74 20 72 65 73 68 20 74 65 73 74 2d 6e ault resh test-n
7160: 61 6d 65 20 20 23 66 29 20 20 74 65 73 74 2d 69 ame #f) test-i
7170: 74 65 6d 20 20 23 66 29 29 0a 20 20 20 20 20 20 tem #f)).
7180: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7190: 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 (hash-table-set
71a0: 21 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 ! (hash-table-re
71b0: 66 2f 64 65 66 61 75 6c 74 20 72 65 73 68 20 74 f/default resh t
71c0: 65 73 74 2d 6e 61 6d 65 20 20 23 66 29 20 74 65 est-name #f) te
71d0: 73 74 2d 69 74 65 6d 20 20 20 28 6d 61 6b 65 2d st-item (make-
71e0: 68 61 73 68 2d 74 61 62 6c 65 29 29 29 20 0a 20 hash-table))) .
71f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 68 (h
7200: 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 20 ash-table-set!
7210: 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f (hash-table-ref/
7220: 64 65 66 61 75 6c 74 20 28 68 61 73 68 2d 74 61 default (hash-ta
7230: 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 ble-ref/default
7240: 72 65 73 68 20 74 65 73 74 2d 6e 61 6d 65 20 20 resh test-name
7250: 23 66 29 20 74 65 73 74 2d 69 74 65 6d 20 23 66 #f) test-item #f
7260: 29 20 72 75 6e 2d 69 64 20 28 6c 69 73 74 20 74 ) run-id (list t
7270: 65 73 74 2d 73 74 61 74 75 73 20 74 65 73 74 2d est-status test-
7280: 68 74 6d 6c 2d 70 61 74 68 29 29 29 29 20 0a 20 html-path)))) .
7290: 20 20 20 20 20 20 20 74 65 73 74 2d 64 61 74 61 test-data
72a0: 29 29 29 0a 20 20 20 20 20 20 72 75 6e 73 29 0a ))). runs).
72b0: 20 20 20 72 65 73 68 29 29 0a 0a 3b 3b 20 28 74 resh))..;; (t
72c0: 65 73 74 73 3a 63 72 65 61 74 65 2d 68 74 6d 6c ests:create-html
72d0: 2d 74 72 65 65 20 22 74 65 73 74 2d 69 6e 64 65 -tree "test-inde
72e0: 78 2e 68 74 6d 6c 22 29 0a 3b 3b 0a 28 64 65 66 x.html").;;.(def
72f0: 69 6e 65 20 28 74 65 73 74 73 3a 63 72 65 61 74 ine (tests:creat
7300: 65 2d 68 74 6d 6c 2d 74 72 65 65 20 6f 75 74 66 e-html-tree outf
7310: 29 0a 20 20 20 28 6c 65 74 2a 20 28 28 6c 6f 63 ). (let* ((loc
7320: 6b 66 69 6c 65 20 20 28 63 6f 6e 63 20 6f 75 74 kfile (conc out
7330: 66 20 22 2e 6c 6f 63 6b 22 29 29 0a 09 20 28 72 f ".lock")).. (r
7340: 75 6e 73 2d 74 6f 2d 70 72 6f 63 65 73 73 20 27 uns-to-process '
7350: 28 29 29 0a 20 20 20 20 20 20 20 20 20 28 6c 69 ()). (li
7360: 6e 6b 74 72 65 65 20 20 28 63 6f 6d 6d 6f 6e 3a nktree (common:
7370: 67 65 74 2d 6c 69 6e 6b 74 72 65 65 29 29 0a 20 get-linktree)).
7380: 20 20 20 20 20 20 20 20 20 28 61 72 65 61 2d 6e (area-n
7390: 61 6d 65 20 28 63 6f 6d 6d 6f 6e 3a 67 65 74 2d ame (common:get-
73a0: 74 65 73 74 73 75 69 74 65 2d 6e 61 6d 65 29 29 testsuite-name))
73b0: 0a 09 20 20 28 6b 65 79 73 20 20 20 20 20 20 28 .. (keys (
73c0: 72 6d 74 3a 67 65 74 2d 6b 65 79 73 29 29 0a 09 rmt:get-keys))..
73d0: 20 20 28 6e 75 6d 6b 65 79 73 20 20 20 28 6c 65 (numkeys (le
73e0: 6e 67 74 68 20 6b 65 79 73 29 29 0a 20 20 20 20 ngth keys)).
73f0: 20 20 20 20 20 28 74 6f 74 61 6c 2d 72 75 6e 73 (total-runs
7400: 20 20 28 72 6d 74 3a 67 65 74 2d 6e 75 6d 2d 72 (rmt:get-num-r
7410: 75 6e 73 20 22 25 22 29 29 0a 20 20 20 20 20 20 uns "%")).
7420: 20 20 20 28 70 67 2d 73 69 7a 65 20 31 30 29 20 (pg-size 10)
7430: 20 20 29 0a 20 20 20 20 28 69 66 20 28 63 6f 6d ). (if (com
7440: 6d 6f 6e 3a 73 69 6d 70 6c 65 2d 66 69 6c 65 2d mon:simple-file-
7450: 6c 6f 63 6b 20 6c 6f 63 6b 66 69 6c 65 29 0a 20 lock lockfile).
7460: 20 20 20 20 20 20 20 28 62 65 67 69 6e 0a 20 20 (begin.
7470: 20 20 20 20 20 20 20 28 70 72 69 6e 74 20 74 6f (print to
7480: 74 61 6c 2d 72 75 6e 73 29 20 20 20 20 0a 20 20 tal-runs) .
7490: 20 20 20 20 20 20 28 6c 65 74 20 6c 6f 6f 70 20 (let loop
74a0: 28 28 70 61 67 65 20 30 29 29 0a 09 28 6c 65 74 ((page 0))..(let
74b0: 2a 20 28 28 6f 75 70 20 20 20 20 20 20 20 28 6f * ((oup (o
74c0: 70 65 6e 2d 6f 75 74 70 75 74 2d 66 69 6c 65 20 pen-output-file
74d0: 28 6f 72 20 6f 75 74 66 20 28 63 6f 6e 63 20 6c (or outf (conc l
74e0: 69 6e 6b 74 72 65 65 20 22 2f 70 61 67 65 22 20 inktree "/page"
74f0: 70 61 67 65 20 22 2e 68 74 6d 6c 22 29 29 29 29 page ".html"))))
7500: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
7510: 28 73 74 61 72 74 20 28 2a 20 70 61 67 65 20 70 (start (* page p
7520: 67 2d 73 69 7a 65 29 29 20 0a 09 20 20 20 20 20 g-size)) ..
7530: 20 20 28 72 75 6e 73 64 61 74 20 20 20 28 72 6d (runsdat (rm
7540: 74 3a 67 65 74 2d 72 75 6e 73 20 22 25 22 20 70 t:get-runs "%" p
7550: 67 2d 73 69 7a 65 20 73 74 61 72 74 20 28 6d 61 g-size start (ma
7560: 70 20 28 6c 61 6d 62 64 61 20 28 78 29 28 6c 69 p (lambda (x)(li
7570: 73 74 20 78 20 22 25 22 29 29 20 6b 65 79 73 29 st x "%")) keys)
7580: 29 29 0a 09 20 20 20 20 20 20 20 28 68 65 61 64 )).. (head
7590: 65 72 20 20 20 20 28 76 65 63 74 6f 72 2d 72 65 er (vector-re
75a0: 66 20 72 75 6e 73 64 61 74 20 30 29 29 0a 09 20 f runsdat 0))..
75b0: 20 20 20 20 20 20 28 72 75 6e 73 20 20 20 20 20 (runs
75c0: 20 28 76 65 63 74 6f 72 2d 72 65 66 20 72 75 6e (vector-ref run
75d0: 73 64 61 74 20 31 29 29 0a 20 20 20 20 20 20 20 sdat 1)).
75e0: 20 20 20 20 20 20 20 20 28 63 74 72 20 30 29 0a (ctr 0).
75f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
7600: 74 65 73 74 2d 72 75 6e 73 2d 68 61 73 68 20 28 test-runs-hash (
7610: 74 65 73 74 73 3a 67 65 74 2d 72 65 73 74 2d 64 tests:get-rest-d
7620: 61 74 61 20 72 75 6e 73 20 68 65 61 64 65 72 20 ata runs header
7630: 6e 75 6d 6b 65 79 73 29 29 0a 20 20 20 20 20 20 numkeys)).
7640: 20 20 20 20 20 20 20 20 20 28 74 65 73 74 2d 6c (test-l
7650: 69 73 74 20 28 68 61 73 68 2d 74 61 62 6c 65 2d ist (hash-table-
7660: 6b 65 79 73 20 74 65 73 74 2d 72 75 6e 73 2d 68 keys test-runs-h
7670: 61 73 68 29 29 0a 20 20 20 20 20 20 20 20 20 20 ash)).
7680: 20 20 20 20 20 28 67 65 74 2d 70 72 65 76 2d 6c (get-prev-l
7690: 69 6e 6b 73 20 28 6c 61 6d 62 64 61 20 28 70 61 inks (lambda (pa
76a0: 67 65 20 6c 69 6e 6b 74 72 65 65 20 29 20 20 20 ge linktree )
76b0: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
76c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 6c 65 (le
76d0: 74 2a 20 28 28 6c 69 6e 6b 20 20 28 69 66 20 28 t* ((link (if (
76e0: 6e 6f 74 20 28 65 71 3f 20 70 61 67 65 20 30 29 not (eq? page 0)
76f0: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
7700: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7710: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 73 (s
7720: 3a 61 20 22 26 6c 74 3b 26 6c 74 3b 70 72 65 76 :a "<<prev
7730: 22 20 27 68 72 65 66 20 28 63 6f 6e 63 20 20 6c " 'href (conc l
7740: 69 6e 6b 74 72 65 65 20 22 2f 70 61 67 65 22 20 inktree "/page"
7750: 28 2d 20 70 61 67 65 20 31 29 20 22 2e 68 74 6d (- page 1) ".htm
7760: 6c 22 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 l")).
7770: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7780: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7790: 20 28 73 3a 61 20 22 22 20 27 68 72 65 66 20 28 (s:a "" 'href (
77a0: 63 6f 6e 63 20 20 6c 69 6e 6b 74 72 65 65 20 22 conc linktree "
77b0: 2f 70 61 67 65 22 20 20 70 61 67 65 20 22 2e 68 /page" page ".h
77c0: 74 6d 6c 22 29 29 29 29 29 0a 20 20 20 20 20 20 tml"))))).
77d0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
77e0: 20 20 20 20 20 20 20 20 20 6c 69 6e 6b 29 29 29 link)))
77f0: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
7800: 20 28 67 65 74 2d 6e 65 78 74 2d 6c 69 6e 6b 73 (get-next-links
7810: 20 28 6c 61 6d 62 64 61 20 28 70 61 67 65 20 6c (lambda (page l
7820: 69 6e 6b 74 72 65 65 20 74 6f 74 61 6c 2d 72 75 inktree total-ru
7830: 6e 73 29 20 20 20 0a 20 20 20 20 20 20 20 20 20 ns) .
7840: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7850: 20 20 20 28 6c 65 74 2a 20 28 28 6c 69 6e 6b 20 (let* ((link
7860: 20 28 69 66 20 28 3e 20 74 6f 74 61 6c 2d 72 75 (if (> total-ru
7870: 6e 73 20 28 2b 20 31 20 28 2a 20 70 61 67 65 20 ns (+ 1 (* page
7880: 70 67 2d 73 69 7a 65 29 29 29 0a 20 20 20 20 20 pg-size))).
7890: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
78a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
78b0: 20 20 20 20 20 20 20 28 73 3a 61 20 22 6e 65 78 (s:a "nex
78c0: 74 26 67 74 3b 26 67 74 3b 22 20 27 68 72 65 66 t>>" 'href
78d0: 20 28 63 6f 6e 63 20 20 6c 69 6e 6b 74 72 65 65 (conc linktree
78e0: 20 22 2f 70 61 67 65 22 20 20 28 2b 20 70 61 67 "/page" (+ pag
78f0: 65 20 31 29 20 22 2e 68 74 6d 6c 22 29 29 0a 20 e 1) ".html")).
7900: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7910: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7920: 20 20 20 20 20 20 20 20 20 20 20 20 28 73 3a 61 (s:a
7930: 20 22 22 20 27 68 72 65 66 20 28 63 6f 6e 63 20 "" 'href (conc
7940: 20 6c 69 6e 6b 74 72 65 65 20 22 2f 70 61 67 65 linktree "/page
7950: 22 20 70 61 67 65 20 20 22 2e 68 74 6d 6c 22 29 " page ".html")
7960: 29 29 29 29 0a 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: 20 20 20 20 6c 69 6e 6b 29 29 29 29 0a 09 20 20 link))))..
7990: 28 73 3a 6f 75 74 70 75 74 2d 6e 65 77 0a 09 20 (s:output-new..
79a0: 20 20 6f 75 70 0a 09 20 20 20 28 73 3a 68 74 6d oup.. (s:htm
79b0: 6c 20 74 65 73 74 73 3a 63 73 73 2d 6a 73 63 72 l tests:css-jscr
79c0: 69 70 74 2d 62 6c 6f 63 6b 0a 09 09 20 20 20 28 ipt-block... (
79d0: 73 3a 74 69 74 6c 65 20 22 53 75 6d 6d 61 72 79 s:title "Summary
79e0: 20 66 6f 72 20 22 20 61 72 65 61 2d 6e 61 6d 65 for " area-name
79f0: 29 0a 09 09 20 20 20 28 73 3a 62 6f 64 79 20 27 )... (s:body '
7a00: 6f 6e 6c 6f 61 64 20 22 61 64 64 45 76 65 6e 74 onload "addEvent
7a10: 73 28 29 3b 22 0a 20 20 20 20 20 20 20 20 20 20 s();".
7a20: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7a30: 28 67 65 74 2d 70 72 65 76 2d 6c 69 6e 6b 73 20 (get-prev-links
7a40: 70 61 67 65 20 6c 69 6e 6b 74 72 65 65 29 0a 20 page linktree).
7a50: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7a60: 20 20 20 20 20 20 20 20 20 28 67 65 74 2d 6e 65 (get-ne
7a70: 78 74 2d 6c 69 6e 6b 73 20 70 61 67 65 20 6c 69 xt-links page li
7a80: 6e 6b 74 72 65 65 20 74 6f 74 61 6c 2d 72 75 6e nktree total-run
7a90: 73 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 s).
7aa0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 0a 09 ..
7ab0: 09 09 20 20 20 28 73 3a 68 31 20 22 53 75 6d 6d .. (s:h1 "Summ
7ac0: 61 72 79 20 66 6f 72 20 22 20 61 72 65 61 2d 6e ary for " area-n
7ad0: 61 6d 65 29 0a 20 20 20 20 20 20 20 20 20 20 20 ame).
7ae0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7af0: 28 73 3a 68 33 20 22 46 69 6c 74 65 72 22 20 29 (s:h3 "Filter" )
7b00: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
7b10: 20 20 20 20 20 20 20 20 20 20 20 20 28 73 3a 69 (s:i
7b20: 6e 70 75 74 20 27 74 79 70 65 20 22 74 65 78 74 nput 'type "text
7b30: 22 20 20 27 6e 61 6d 65 20 22 74 65 73 74 6e 61 " 'name "testna
7b40: 6d 65 22 20 27 69 64 20 22 74 65 73 74 6e 61 6d me" 'id "testnam
7b50: 65 22 20 27 6c 65 6e 67 74 68 20 22 33 30 22 20 e" 'length "30"
7b60: 27 6f 6e 6b 65 79 75 70 20 22 66 69 6c 74 65 72 'onkeyup "filter
7b70: 73 6f 6d 65 28 29 22 29 0a 20 20 0a 09 09 09 20 some()"). ....
7b80: 20 20 3b 3b 20 74 6f 70 20 6c 69 73 74 0a 09 09 ;; top list...
7b90: 09 20 20 20 28 73 3a 74 61 62 6c 65 20 27 69 64 . (s:table 'id
7ba0: 20 22 4c 69 6e 6b 65 64 4c 69 73 74 31 22 20 27 "LinkedList1" '
7bb0: 62 6f 72 64 65 72 20 22 31 22 0a 20 20 20 20 20 border "1".
7bc0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7bd0: 20 20 20 20 20 20 20 28 6d 61 70 20 28 6c 61 6d (map (lam
7be0: 62 64 61 20 28 6b 65 79 29 0a 09 09 09 09 20 28 bda (key)..... (
7bf0: 6c 65 74 2a 20 28 28 72 65 73 20 28 73 3a 74 72 let* ((res (s:tr
7c00: 20 27 63 6c 61 73 73 20 22 73 6f 6d 65 74 68 69 'class "somethi
7c10: 6e 67 22 20 0a 09 09 09 09 20 20 28 73 3a 74 68 ng" ..... (s:th
7c20: 20 6b 65 79 20 29 0a 20 20 20 20 20 20 20 20 20 key ).
7c30: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7c40: 20 20 20 20 20 20 20 20 20 20 28 6d 61 70 20 28 (map (
7c50: 6c 61 6d 62 64 61 20 28 72 75 6e 29 0a 20 20 20 lambda (run).
7c60: 20 20 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: 28 73 3a 74 68 20 20 28 76 65 63 74 6f 72 2d 72 (s:th (vector-r
7c90: 65 66 20 72 75 6e 20 63 74 72 29 29 29 0a 20 20 ef run ctr))).
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: 72 75 6e 73 29 29 29 29 0a 20 20 20 20 20 20 20 runs)))).
7cd0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7ce0: 20 20 20 20 20 20 28 73 65 74 21 20 63 74 72 20 (set! ctr
7cf0: 28 2b 20 63 74 72 20 31 29 29 0a 20 20 20 20 20 (+ ctr 1)).
7d00: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7d10: 20 20 20 20 20 20 20 20 20 20 72 65 73 29 29 0a res)).
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 6b k
7d40: 65 79 73 29 0a 20 20 20 20 20 20 20 20 20 20 20 eys).
7d50: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7d60: 20 20 20 20 28 73 3a 74 72 0a 09 09 09 09 20 28 (s:tr..... (
7d70: 73 3a 74 68 20 22 52 75 6e 20 4e 61 6d 65 22 29 s:th "Run Name")
7d80: 0a 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 20 20 20 20
7da0: 20 20 20 28 6d 61 70 20 28 6c 61 6d 62 64 61 20 (map (lambda
7db0: 28 72 75 6e 29 0a 20 20 20 20 20 20 20 20 20 20 (run).
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 28 73 3a 74 68 20 20 (s:th
7de0: 28 76 65 63 74 6f 72 2d 72 65 66 20 72 75 6e 20 (vector-ref run
7df0: 33 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 3))).
7e00: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7e10: 20 20 20 20 20 20 20 72 75 6e 73 29 29 0a 20 20 runs)).
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 0a 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 28 6d 61 70 (map
7e60: 20 28 6c 61 6d 62 64 61 20 28 74 65 73 74 2d 6e (lambda (test-n
7e70: 61 6d 65 29 0a 20 20 20 20 20 20 20 20 20 20 20 ame).
7e80: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7e90: 20 20 20 20 20 20 28 6c 65 74 2a 20 28 28 69 74 (let* ((it
7ea0: 65 6d 2d 68 61 73 68 20 28 68 61 73 68 2d 74 61 em-hash (hash-ta
7eb0: 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 ble-ref/default
7ec0: 74 65 73 74 2d 72 75 6e 73 2d 68 61 73 68 20 74 test-runs-hash t
7ed0: 65 73 74 2d 6e 61 6d 65 20 20 23 66 29 29 0a 20 est-name #f)).
7ee0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7ef0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7f00: 20 20 20 20 20 20 20 20 28 69 74 65 6d 2d 6b 65 (item-ke
7f10: 79 73 20 28 73 6f 72 74 20 28 68 61 73 68 2d 74 ys (sort (hash-t
7f20: 61 62 6c 65 2d 6b 65 79 73 20 69 74 65 6d 2d 68 able-keys item-h
7f30: 61 73 68 29 20 73 74 72 69 6e 67 3c 3d 3f 29 29 ash) string<=?))
7f40: 29 20 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 ) .
7f50: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7f60: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 6d 61 (ma
7f70: 70 20 28 6c 61 6d 62 64 61 20 28 69 74 65 6d 2d p (lambda (item-
7f80: 6e 61 6d 65 29 20 20 0a 20 20 09 09 20 20 20 20 name) . ..
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 28 6c 65 74 2a 20 28 (let* (
7fb0: 28 72 65 73 20 28 73 3a 74 72 20 20 27 63 6c 61 (res (s:tr 'cla
7fc0: 73 73 20 69 74 65 6d 2d 6e 61 6d 65 0a 09 09 09 ss item-name....
7fd0: 09 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
7fe0: 20 20 20 20 20 20 20 20 20 20 28 73 3a 74 64 20 (s:td
7ff0: 20 69 74 65 6d 2d 6e 61 6d 65 20 27 63 6c 61 73 item-name 'clas
8000: 73 20 22 74 65 73 74 22 20 29 0a 20 20 20 20 20 s "test" ).
8010: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8020: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8030: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8040: 20 20 20 20 20 20 28 6d 61 70 20 28 6c 61 6d 62 (map (lamb
8050: 64 61 20 28 72 75 6e 29 0a 20 20 20 20 20 20 20 da (run).
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 28 6c 65 74 2a 20 28 28 (let* ((
80a0: 72 75 6e 2d 74 65 73 74 20 28 68 61 73 68 2d 74 run-test (hash-t
80b0: 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 able-ref/default
80c0: 20 69 74 65 6d 2d 68 61 73 68 20 69 74 65 6d 2d item-hash item-
80d0: 6e 61 6d 65 20 20 23 66 29 29 0a 20 20 20 20 20 name #f)).
80e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
80f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8100: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8110: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8120: 20 28 72 75 6e 2d 69 64 20 28 64 62 3a 67 65 74 (run-id (db:get
8130: 2d 76 61 6c 75 65 2d 62 79 2d 68 65 61 64 65 72 -value-by-header
8140: 20 72 75 6e 20 68 65 61 64 65 72 20 22 69 64 22 run header "id"
8150: 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 )).
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 28 72 65 73 75 6c 74 (result
81a0: 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 (hash-table-ref
81b0: 2f 64 65 66 61 75 6c 74 20 72 75 6e 2d 74 65 73 /default run-tes
81c0: 74 20 72 75 6e 2d 69 64 20 22 6e 2f 61 22 29 29 t run-id "n/a"))
81d0: 0a 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 20 20
8210: 20 20 20 20 20 20 20 28 73 74 61 74 75 73 20 28 (status (
8220: 69 66 20 28 73 74 72 69 6e 67 3f 20 72 65 73 75 if (string? resu
8230: 6c 74 29 0a 09 09 09 09 09 09 09 09 09 09 72 65 lt)...........re
8240: 73 75 6c 74 0a 09 09 09 09 09 09 09 09 09 09 28 sult...........(
8250: 63 61 72 20 72 65 73 75 6c 74 29 29 29 0a 20 20 car result))).
8260: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8270: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8280: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8290: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
82a0: 20 20 20 20 20 20 28 6c 69 6e 6b 20 28 69 66 20 (link (if
82b0: 28 73 74 72 69 6e 67 3f 20 72 65 73 75 6c 74 29 (string? result)
82c0: 0a 09 09 09 09 09 09 09 09 09 09 72 65 73 75 6c ...........resul
82d0: 74 0a 09 09 09 09 09 09 09 09 09 09 28 73 3a 61 t...........(s:a
82e0: 20 28 63 61 72 20 72 65 73 75 6c 74 29 20 27 68 (car result) 'h
82f0: 72 65 66 20 28 63 61 64 72 20 72 65 73 75 6c 74 ref (cadr result
8300: 29 29 29 29 29 0a 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 20 20 20
8340: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 73 3a (s:
8350: 74 64 20 20 6c 69 6e 6b 20 27 63 6c 61 73 73 20 td link 'class
8360: 73 74 61 74 75 73 29 29 29 0a 20 20 20 20 20 20 status))).
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 20 20 20 20 20 20 20 20 72 75 6e 73 29 29 runs))
83b0: 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 )).
83c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
83d0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
83e0: 20 20 20 20 20 20 20 20 20 20 20 72 65 73 29 29 res))
83f0: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
8400: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8410: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8420: 20 20 20 20 69 74 65 6d 2d 6b 65 79 73 29 29 29 item-keys)))
8430: 0a 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: 74 65 73 74 2d 6c 69 73 74 29 29 29 29 29 0a 20 test-list))))).
8460: 20 20 20 20 20 20 20 20 20 28 63 6c 6f 73 65 2d (close-
8470: 6f 75 74 70 75 74 2d 70 6f 72 74 20 6f 75 70 29 output-port oup)
8480: 0a 20 20 20 20 20 20 20 20 20 3b 20 28 73 65 74 . ; (set
8490: 21 20 70 61 67 65 20 28 2b 20 31 20 70 61 67 65 ! page (+ 1 page
84a0: 29 29 0a 20 20 20 20 20 20 20 20 20 20 28 69 66 )). (if
84b0: 20 28 3e 20 74 6f 74 61 6c 2d 72 75 6e 73 20 28 (> total-runs (
84c0: 2a 20 28 2b 20 31 20 70 61 67 65 29 20 70 67 2d * (+ 1 page) pg-
84d0: 73 69 7a 65 29 29 0a 20 20 20 20 20 20 20 20 20 size)).
84e0: 20 20 28 6c 6f 6f 70 20 28 2b 20 31 20 20 70 61 (loop (+ 1 pa
84f0: 67 65 29 29 29 29 29 0a 09 20 20 28 63 6f 6d 6d ge))))).. (comm
8500: 6f 6e 3a 73 69 6d 70 6c 65 2d 66 69 6c 65 2d 72 on:simple-file-r
8510: 65 6c 65 61 73 65 2d 6c 6f 63 6b 20 6c 6f 63 6b elease-lock lock
8520: 66 69 6c 65 29 29 0a 09 20 20 20 20 20 20 20 20 file))..
8530: 20 20 20 20 0a 09 23 66 29 29 29 0a 0a 0a 0a 0a ..#f))).....
8540: 0a 0a 28 64 65 66 69 6e 65 20 28 74 65 73 74 73 ..(define (tests
8550: 3a 63 72 65 61 74 65 2d 68 74 6d 6c 2d 74 72 65 :create-html-tre
8560: 65 2d 6f 6c 64 20 6f 75 74 66 29 0a 20 20 20 28 e-old outf). (
8570: 6c 65 74 2a 20 28 28 6c 6f 63 6b 66 69 6c 65 20 let* ((lockfile
8580: 20 28 63 6f 6e 63 20 6f 75 74 66 20 22 2e 6c 6f (conc outf ".lo
8590: 63 6b 22 29 29 0a 09 20 28 72 75 6e 73 2d 74 6f ck")).. (runs-to
85a0: 2d 70 72 6f 63 65 73 73 20 27 28 29 29 29 0a 20 -process '())).
85b0: 20 20 20 28 69 66 20 28 63 6f 6d 6d 6f 6e 3a 73 (if (common:s
85c0: 69 6d 70 6c 65 2d 66 69 6c 65 2d 6c 6f 63 6b 20 imple-file-lock
85d0: 6c 6f 63 6b 66 69 6c 65 29 0a 09 28 6c 65 74 2a lockfile)..(let*
85e0: 20 28 28 6c 69 6e 6b 74 72 65 65 20 20 28 63 6f ((linktree (co
85f0: 6d 6d 6f 6e 3a 67 65 74 2d 6c 69 6e 6b 74 72 65 mmon:get-linktre
8600: 65 29 29 0a 09 20 20 20 20 20 20 20 28 6f 75 70 e)).. (oup
8610: 20 20 20 20 20 20 20 28 6f 70 65 6e 2d 6f 75 74 (open-out
8620: 70 75 74 2d 66 69 6c 65 20 28 6f 72 20 6f 75 74 put-file (or out
8630: 66 20 28 63 6f 6e 63 20 6c 69 6e 6b 74 72 65 65 f (conc linktree
8640: 20 22 2f 72 75 6e 73 2d 69 6e 64 65 78 2e 68 74 "/runs-index.ht
8650: 6d 6c 22 29 29 29 29 0a 09 20 20 20 20 20 20 20 ml"))))..
8660: 28 61 72 65 61 2d 6e 61 6d 65 20 28 63 6f 6d 6d (area-name (comm
8670: 6f 6e 3a 67 65 74 2d 74 65 73 74 73 75 69 74 65 on:get-testsuite
8680: 2d 6e 61 6d 65 29 29 0a 09 20 20 20 20 20 20 20 -name))..
8690: 28 6b 65 79 73 20 20 20 20 20 20 28 72 6d 74 3a (keys (rmt:
86a0: 67 65 74 2d 6b 65 79 73 29 29 0a 09 20 20 20 20 get-keys))..
86b0: 20 20 20 28 6e 75 6d 6b 65 79 73 20 20 20 28 6c (numkeys (l
86c0: 65 6e 67 74 68 20 6b 65 79 73 29 29 0a 09 20 20 ength keys))..
86d0: 20 20 20 20 20 28 72 75 6e 73 64 61 74 20 20 20 (runsdat
86e0: 28 72 6d 74 3a 67 65 74 2d 72 75 6e 73 20 22 25 (rmt:get-runs "%
86f0: 22 20 23 66 20 23 66 20 28 6d 61 70 20 28 6c 61 " #f #f (map (la
8700: 6d 62 64 61 20 28 78 29 28 6c 69 73 74 20 78 20 mbda (x)(list x
8710: 22 25 22 29 29 20 6b 65 79 73 29 29 29 0a 09 20 "%")) keys)))..
8720: 20 20 20 20 20 20 28 68 65 61 64 65 72 20 20 20 (header
8730: 20 28 76 65 63 74 6f 72 2d 72 65 66 20 72 75 6e (vector-ref run
8740: 73 64 61 74 20 30 29 29 0a 09 20 20 20 20 20 20 sdat 0))..
8750: 20 28 72 75 6e 73 20 20 20 20 20 20 28 76 65 63 (runs (vec
8760: 74 6f 72 2d 72 65 66 20 72 75 6e 73 64 61 74 20 tor-ref runsdat
8770: 31 29 29 0a 09 20 20 20 20 20 20 20 28 72 75 6e 1)).. (run
8780: 74 72 65 65 64 61 74 20 28 6d 61 70 20 28 6c 61 treedat (map (la
8790: 6d 62 64 61 20 28 78 29 0a 09 09 09 09 20 20 28 mbda (x)..... (
87a0: 74 65 73 74 73 3a 72 75 6e 2d 72 65 63 6f 72 64 tests:run-record
87b0: 2d 3e 74 65 73 74 2d 70 61 74 68 20 78 20 6e 75 ->test-path x nu
87c0: 6d 6b 65 79 73 29 29 0a 09 09 09 09 72 75 6e 73 mkeys)).....runs
87d0: 29 29 0a 09 20 20 20 20 20 20 20 28 72 75 6e 73 )).. (runs
87e0: 2d 68 74 72 65 65 20 28 63 6f 6d 6d 6f 6e 3a 6c -htree (common:l
87f0: 69 73 74 2d 3e 68 74 72 65 65 20 72 75 6e 74 72 ist->htree runtr
8800: 65 65 64 61 74 29 29 29 0a 09 20 20 28 73 65 74 eedat))).. (set
8810: 21 20 72 75 6e 73 2d 74 6f 2d 70 72 6f 63 65 73 ! runs-to-proces
8820: 73 20 72 75 6e 73 29 0a 09 20 20 28 73 3a 6f 75 s runs).. (s:ou
8830: 74 70 75 74 2d 6e 65 77 0a 09 20 20 20 6f 75 70 tput-new.. oup
8840: 0a 09 20 20 20 28 73 3a 68 74 6d 6c 20 74 65 73 .. (s:html tes
8850: 74 73 3a 63 73 73 2d 6a 73 63 72 69 70 74 2d 62 ts:css-jscript-b
8860: 6c 6f 63 6b 0a 09 09 20 20 20 28 73 3a 74 69 74 lock... (s:tit
8870: 6c 65 20 22 53 75 6d 6d 61 72 79 20 66 6f 72 20 le "Summary for
8880: 22 20 61 72 65 61 2d 6e 61 6d 65 29 0a 09 09 20 " area-name)...
8890: 20 20 28 73 3a 62 6f 64 79 20 27 6f 6e 6c 6f 61 (s:body 'onloa
88a0: 64 20 22 61 64 64 45 76 65 6e 74 73 28 29 3b 22 d "addEvents();"
88b0: 0a 09 09 09 20 20 20 28 73 3a 68 31 20 22 53 75 .... (s:h1 "Su
88c0: 6d 6d 61 72 79 20 66 6f 72 20 22 20 61 72 65 61 mmary for " area
88d0: 2d 6e 61 6d 65 29 0a 09 09 09 20 20 20 3b 3b 20 -name).... ;;
88e0: 74 6f 70 20 6c 69 73 74 0a 09 09 09 20 20 20 28 top list.... (
88f0: 73 3a 75 6c 20 27 69 64 20 22 4c 69 6e 6b 65 64 s:ul 'id "Linked
8900: 4c 69 73 74 31 22 20 27 63 6c 61 73 73 20 22 4c List1" 'class "L
8910: 69 6e 6b 65 64 4c 69 73 74 22 0a 09 09 09 09 20 inkedList".....
8920: 28 73 3a 6c 69 0a 09 09 09 09 20 20 22 52 75 6e (s:li..... "Run
8930: 73 22 0a 09 09 09 09 20 20 28 63 6f 6d 6d 6f 6e s"..... (common
8940: 3a 68 74 72 65 65 2d 3e 68 74 6d 6c 20 72 75 6e :htree->html run
8950: 73 2d 68 74 72 65 65 0a 09 09 09 09 09 09 20 20 s-htree.......
8960: 20 20 20 20 27 28 29 0a 09 09 09 09 09 09 20 20 '().......
8970: 20 20 20 20 28 6c 61 6d 62 64 61 20 28 78 20 70 (lambda (x p
8980: 29 0a 09 09 09 09 09 09 09 28 6c 65 74 2a 20 28 )........(let* (
8990: 28 74 61 72 67 2d 70 61 74 68 20 28 73 74 72 69 (targ-path (stri
89a0: 6e 67 2d 69 6e 74 65 72 73 70 65 72 73 65 20 70 ng-intersperse p
89b0: 20 22 2f 22 29 29 0a 20 20 20 20 20 20 20 20 20 "/")).
89c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
89d0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
89e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
89f0: 20 20 20 20 20 20 28 66 75 6c 6c 2d 70 61 74 68 (full-path
8a00: 20 28 63 6f 6e 63 20 6c 69 6e 6b 74 72 65 65 20 (conc linktree
8a10: 22 2f 22 20 74 61 72 67 2d 70 61 74 68 29 29 0a "/" targ-path)).
8a20: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8a30: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8a40: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8a50: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
8a60: 72 75 6e 2d 6e 61 6d 65 20 20 28 63 61 72 20 28 run-name (car (
8a70: 72 65 76 65 72 73 65 20 70 29 29 29 29 0a 20 20 reverse p)))).
8a80: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8a90: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8aa0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8ab0: 20 20 20 20 20 20 20 20 28 69 66 20 28 61 6e 64 (if (and
8ac0: 20 28 66 69 6c 65 2d 65 78 69 73 74 73 3f 20 66 (file-exists? f
8ad0: 75 6c 6c 2d 70 61 74 68 29 0a 20 20 20 20 20 20 ull-path).
8ae0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8af0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8b00: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8b10: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 64 69 (di
8b20: 72 65 63 74 6f 72 79 3f 20 20 20 66 75 6c 6c 2d rectory? full-
8b30: 70 61 74 68 29 0a 20 20 20 20 20 20 20 20 20 20 path).
8b40: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8b50: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8b60: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8b70: 20 20 20 20 20 20 20 20 20 28 66 69 6c 65 2d 77 (file-w
8b80: 72 69 74 65 2d 61 63 63 65 73 73 3f 20 66 75 6c rite-access? ful
8b90: 6c 2d 70 61 74 68 29 29 0a 20 20 20 20 20 20 20 l-path)).
8ba0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8bb0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8bc0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8bd0: 20 20 20 20 20 20 20 28 73 3a 61 20 72 75 6e 2d (s:a run-
8be0: 6e 61 6d 65 20 27 68 72 65 66 20 28 63 6f 6e 63 name 'href (conc
8bf0: 20 74 61 72 67 2d 70 61 74 68 20 22 2f 72 75 6e targ-path "/run
8c00: 2d 73 75 6d 6d 61 72 79 2e 68 74 6d 6c 22 29 29 -summary.html"))
8c10: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
8c20: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8c30: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8c40: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
8c50: 62 65 67 69 6e 0a 20 20 20 20 20 20 20 20 20 20 begin.
8c60: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8c70: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8c80: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8c90: 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 (debug:pri
8ca0: 6e 74 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f nt 0 *default-lo
8cb0: 67 2d 70 6f 72 74 2a 20 22 49 4e 46 4f 3a 20 43 g-port* "INFO: C
8cc0: 61 6e 27 74 20 63 72 65 61 74 65 20 22 20 74 61 an't create " ta
8cd0: 72 67 2d 70 61 74 68 20 22 2f 72 75 6e 2d 73 75 rg-path "/run-su
8ce0: 6d 6d 61 72 79 2e 68 74 6d 6c 22 29 0a 20 20 20 mmary.html").
8cf0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8d00: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8d10: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8d20: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 63 6f (co
8d30: 6e 63 20 72 75 6e 2d 6e 61 6d 65 20 22 20 28 4e nc run-name " (N
8d40: 6f 74 20 61 62 6c 65 20 74 6f 20 63 72 65 61 74 ot able to creat
8d50: 65 20 73 75 6d 6d 61 72 79 20 61 74 20 22 20 74 e summary at " t
8d60: 61 72 67 2d 70 61 74 68 20 22 29 22 29 29 29 29 arg-path ")"))))
8d70: 29 29 29 29 29 29 29 0a 20 20 20 20 20 20 20 20 ))))))).
8d80: 20 20 28 63 6c 6f 73 65 2d 6f 75 74 70 75 74 2d (close-output-
8d90: 70 6f 72 74 20 6f 75 70 29 0a 09 20 20 28 63 6f port oup).. (co
8da0: 6d 6d 6f 6e 3a 73 69 6d 70 6c 65 2d 66 69 6c 65 mmon:simple-file
8db0: 2d 72 65 6c 65 61 73 65 2d 6c 6f 63 6b 20 6c 6f -release-lock lo
8dc0: 63 6b 66 69 6c 65 29 0a 20 20 20 20 20 20 20 20 ckfile).
8dd0: 20 20 20 20 20 20 20 0a 09 20 20 28 66 6f 72 2d .. (for-
8de0: 65 61 63 68 0a 09 20 20 20 28 6c 61 6d 62 64 61 each.. (lambda
8df0: 20 28 72 75 6e 29 0a 09 20 20 20 20 20 28 6c 65 (run).. (le
8e00: 74 2a 20 28 28 74 65 73 74 2d 73 75 62 70 61 74 t* ((test-subpat
8e10: 68 20 28 74 65 73 74 73 3a 72 75 6e 2d 72 65 63 h (tests:run-rec
8e20: 6f 72 64 2d 3e 74 65 73 74 2d 70 61 74 68 20 72 ord->test-path r
8e30: 75 6e 20 6e 75 6d 6b 65 79 73 29 29 0a 09 09 20 un numkeys))...
8e40: 20 20 20 28 72 75 6e 2d 69 64 20 20 20 20 20 20 (run-id
8e50: 20 28 64 62 3a 67 65 74 2d 76 61 6c 75 65 2d 62 (db:get-value-b
8e60: 79 2d 68 65 61 64 65 72 20 72 75 6e 20 68 65 61 y-header run hea
8e70: 64 65 72 20 22 69 64 22 29 29 0a 20 20 20 20 20 der "id")).
8e80: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
8e90: 72 75 6e 2d 64 69 72 20 20 20 20 20 20 28 74 65 run-dir (te
8ea0: 73 74 73 3a 72 75 6e 2d 72 65 63 6f 72 64 2d 3e sts:run-record->
8eb0: 74 65 73 74 2d 70 61 74 68 20 72 75 6e 20 6e 75 test-path run nu
8ec0: 6d 6b 65 79 73 29 29 0a 09 09 20 20 20 20 28 74 mkeys))... (t
8ed0: 65 73 74 2d 64 61 74 73 20 20 20 20 28 72 6d 74 est-dats (rmt
8ee0: 3a 67 65 74 2d 74 65 73 74 73 2d 66 6f 72 2d 72 :get-tests-for-r
8ef0: 75 6e 0a 09 09 09 09 20 20 20 72 75 6e 2d 69 64 un..... run-id
8f00: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
8f10: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8f20: 20 20 20 20 22 25 2f 22 20 20 20 20 20 20 20 3b "%/" ;
8f30: 3b 20 74 65 73 74 6e 61 6d 65 70 61 74 74 0a 09 ; testnamepatt..
8f40: 09 09 09 20 20 20 27 28 29 20 20 20 20 20 20 20 ... '()
8f50: 20 3b 3b 20 73 74 61 74 65 73 0a 09 09 09 09 20 ;; states.....
8f60: 20 20 27 28 29 20 20 20 20 20 20 20 20 3b 3b 20 '() ;;
8f70: 73 74 61 74 75 73 65 73 0a 09 09 09 09 20 20 20 statuses.....
8f80: 23 66 20 20 20 20 20 20 20 20 20 3b 3b 20 6f 66 #f ;; of
8f90: 66 73 65 74 0a 09 09 09 09 20 20 20 23 66 20 20 fset..... #f
8fa0: 20 20 20 20 20 20 20 3b 3b 20 6e 75 6d 2d 74 6f ;; num-to
8fb0: 2d 67 65 74 0a 09 09 09 09 20 20 20 23 66 20 20 -get..... #f
8fc0: 20 20 20 20 20 20 20 3b 3b 20 68 69 64 65 2f 6e ;; hide/n
8fd0: 6f 74 2d 68 69 64 65 0a 09 09 09 09 20 20 20 23 ot-hide..... #
8fe0: 66 20 20 20 20 20 20 20 20 20 3b 3b 20 73 6f 72 f ;; sor
8ff0: 74 2d 62 79 0a 09 09 09 09 20 20 20 23 66 20 20 t-by..... #f
9000: 20 20 20 20 20 20 20 3b 3b 20 73 6f 72 74 2d 6f ;; sort-o
9010: 72 64 65 72 0a 09 09 09 09 20 20 20 23 66 20 20 rder..... #f
9020: 20 20 20 20 20 20 20 3b 3b 20 27 73 68 6f 72 74 ;; 'short
9030: 6c 69 73 74 20 20 20 20 20 20 20 20 20 20 20 20 list
9040: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 3b ;
9050: 3b 20 71 72 79 74 79 70 65 0a 20 20 20 20 20 20 ; qrytype.
9060: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9070: 20 20 20 20 20 20 20 20 20 20 20 20 20 30 20 20 0
9080: 20 20 20 20 20 20 20 3b 3b 20 6c 61 73 74 20 75 ;; last u
9090: 70 64 61 74 65 0a 09 09 09 09 20 20 20 23 66 29 pdate..... #f)
90a0: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
90b0: 20 20 20 20 20 20 28 74 65 73 74 73 2d 74 72 65 (tests-tre
90c0: 65 2d 64 61 74 20 28 6d 61 70 20 28 6c 61 6d 62 e-dat (map (lamb
90d0: 64 61 20 28 74 65 73 74 2d 64 61 74 29 0a 20 20 da (test-dat).
90e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
90f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9100: 20 20 20 20 20 20 20 3b 3b 20 28 74 65 73 74 73 ;; (tests
9110: 3a 72 75 6e 2d 72 65 63 6f 72 64 2d 3e 74 65 73 :run-record->tes
9120: 74 2d 70 61 74 68 20 78 20 6e 75 6d 6b 65 79 73 t-path x numkeys
9130: 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 )).
9140: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9150: 20 20 20 20 20 20 20 20 20 20 20 20 28 6c 65 74 (let
9160: 2a 20 28 28 74 65 73 74 2d 6e 61 6d 65 20 20 28 * ((test-name (
9170: 64 62 3a 74 65 73 74 2d 67 65 74 2d 74 65 73 74 db:test-get-test
9180: 6e 61 6d 65 20 74 65 73 74 2d 64 61 74 29 29 0a name test-dat)).
9190: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
91a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
91b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
91c0: 28 69 74 65 6d 2d 70 61 74 68 20 20 28 64 62 3a (item-path (db:
91d0: 74 65 73 74 2d 67 65 74 2d 69 74 65 6d 2d 70 61 test-get-item-pa
91e0: 74 68 20 74 65 73 74 2d 64 61 74 29 29 0a 20 20 th test-dat)).
91f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9200: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9210: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 66 (f
9220: 75 6c 6c 2d 6e 61 6d 65 20 20 28 64 62 3a 74 65 ull-name (db:te
9230: 73 74 2d 6d 61 6b 65 2d 66 75 6c 6c 2d 6e 61 6d st-make-full-nam
9240: 65 20 74 65 73 74 2d 6e 61 6d 65 20 69 74 65 6d e test-name item
9250: 2d 70 61 74 68 29 29 0a 20 20 20 20 20 20 20 20 -path)).
9260: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9270: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9280: 20 20 20 20 20 20 20 20 28 70 61 74 68 2d 70 61 (path-pa
9290: 72 74 73 20 28 73 74 72 69 6e 67 2d 73 70 6c 69 rts (string-spli
92a0: 74 20 66 75 6c 6c 2d 6e 61 6d 65 29 29 29 0a 20 t full-name))).
92b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
92c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
92d0: 20 20 20 20 20 20 20 20 20 20 70 61 74 68 2d 70 path-p
92e0: 61 72 74 73 29 29 0a 20 20 20 20 20 20 20 20 20 arts)).
92f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9300: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 74 65 te
9310: 73 74 2d 64 61 74 73 29 29 0a 20 20 20 20 20 20 st-dats)).
9320: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 74 (t
9330: 65 73 74 73 2d 68 74 72 65 65 20 28 63 6f 6d 6d ests-htree (comm
9340: 6f 6e 3a 6c 69 73 74 2d 3e 68 74 72 65 65 20 74 on:list->htree t
9350: 65 73 74 73 2d 74 72 65 65 2d 64 61 74 29 29 0a ests-tree-dat)).
9360: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9370: 20 20 20 20 28 68 74 6d 6c 2d 64 69 72 20 20 20 (html-dir
9380: 20 28 63 6f 6e 63 20 6c 69 6e 6b 74 72 65 65 20 (conc linktree
9390: 22 2f 22 20 28 73 74 72 69 6e 67 2d 69 6e 74 65 "/" (string-inte
93a0: 72 73 70 65 72 73 65 20 72 75 6e 2d 64 69 72 20 rsperse run-dir
93b0: 22 2f 22 29 29 29 0a 20 20 20 20 20 20 20 20 20 "/"))).
93c0: 20 20 20 20 20 20 20 20 20 20 20 28 68 74 6d 6c (html
93d0: 2d 70 61 74 68 20 20 20 28 63 6f 6e 63 20 68 74 -path (conc ht
93e0: 6d 6c 2d 64 69 72 20 22 2f 72 75 6e 2d 73 75 6d ml-dir "/run-sum
93f0: 6d 61 72 79 2e 68 74 6d 6c 22 29 29 0a 20 20 20 mary.html")).
9400: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9410: 20 28 6f 75 70 20 20 20 20 20 20 20 20 20 28 69 (oup (i
9420: 66 20 28 61 6e 64 20 28 66 69 6c 65 2d 65 78 69 f (and (file-exi
9430: 73 74 73 3f 20 68 74 6d 6c 2d 64 69 72 29 0a 20 sts? html-dir).
9440: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9450: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9460: 20 20 20 20 20 20 20 20 20 28 64 69 72 65 63 74 (direct
9470: 6f 72 79 3f 20 20 20 68 74 6d 6c 2d 64 69 72 29 ory? html-dir)
9480: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
9490: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
94a0: 20 20 20 20 20 20 20 20 20 20 20 28 66 69 6c 65 (file
94b0: 2d 77 72 69 74 65 2d 61 63 63 65 73 73 3f 20 68 -write-access? h
94c0: 74 6d 6c 2d 64 69 72 29 29 0a 20 20 20 20 20 20 tml-dir)).
94d0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
94e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
94f0: 6f 70 65 6e 2d 6f 75 74 70 75 74 2d 66 69 6c 65 open-output-file
9500: 20 20 68 74 6d 6c 2d 70 61 74 68 29 0a 20 20 20 html-path).
9510: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9520: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9530: 20 20 23 66 29 29 29 0a 20 20 20 20 20 20 20 20 #f))).
9540: 20 20 20 20 20 20 20 3b 3b 20 28 70 72 69 6e 74 ;; (print
9550: 20 22 72 75 6e 2d 64 69 72 3a 20 22 20 72 75 6e "run-dir: " run
9560: 2d 64 69 72 20 22 2c 20 74 65 73 74 73 2d 74 72 -dir ", tests-tr
9570: 65 65 2d 64 61 74 3a 20 22 20 74 65 73 74 73 2d ee-dat: " tests-
9580: 74 72 65 65 2d 64 61 74 29 0a 20 20 20 20 20 20 tree-dat).
9590: 20 20 20 20 20 20 20 20 20 28 69 66 20 6f 75 70 (if oup
95a0: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
95b0: 20 20 20 20 28 62 65 67 69 6e 0a 20 20 20 20 20 (begin.
95c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
95d0: 28 73 3a 6f 75 74 70 75 74 2d 6e 65 77 0a 20 20 (s:output-new.
95e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
95f0: 20 20 20 20 6f 75 70 0a 20 20 20 20 20 20 20 20 oup.
9600: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 73 (s
9610: 3a 68 74 6d 6c 20 74 65 73 74 73 3a 63 73 73 2d :html tests:css-
9620: 6a 73 63 72 69 70 74 2d 62 6c 6f 63 6b 0a 20 20 jscript-block.
9630: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9640: 20 20 20 20 20 20 20 20 20 20 20 20 28 73 3a 74 (s:t
9650: 69 74 6c 65 20 22 53 75 6d 6d 61 72 79 20 66 6f itle "Summary fo
9660: 72 20 22 20 61 72 65 61 2d 6e 61 6d 65 29 0a 20 r " area-name).
9670: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9680: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 73 3a (s:
9690: 62 6f 64 79 20 27 6f 6e 6c 6f 61 64 20 22 61 64 body 'onload "ad
96a0: 64 45 76 65 6e 74 73 28 29 3b 22 0a 20 20 20 20 dEvents();".
96b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
96c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
96d0: 20 20 28 73 3a 68 31 20 22 53 75 6d 6d 61 72 79 (s:h1 "Summary
96e0: 20 66 6f 72 20 22 20 28 73 74 72 69 6e 67 2d 69 for " (string-i
96f0: 6e 74 65 72 73 70 65 72 73 65 20 72 75 6e 2d 64 ntersperse run-d
9700: 69 72 20 22 2f 22 29 29 0a 20 20 20 20 20 20 20 ir "/")).
9710: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9720: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 3b ;
9730: 3b 20 74 6f 70 20 6c 69 73 74 0a 20 20 20 20 20 ; top list.
9740: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9750: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9760: 20 28 73 3a 75 6c 20 27 69 64 20 22 4c 69 6e 6b (s:ul 'id "Link
9770: 65 64 4c 69 73 74 31 22 20 27 63 6c 61 73 73 20 edList1" 'class
9780: 22 4c 69 6e 6b 65 64 4c 69 73 74 22 0a 20 20 20 "LinkedList".
9790: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
97a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
97b0: 20 20 20 20 20 20 20 20 20 28 73 3a 6c 69 0a 20 (s:li.
97c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
97d0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
97e0: 20 20 20 20 20 20 20 20 20 20 20 20 22 54 65 73 "Tes
97f0: 74 73 22 0a 20 20 20 20 20 20 20 20 20 20 20 20 ts".
9800: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9810: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9820: 20 28 63 6f 6d 6d 6f 6e 3a 68 74 72 65 65 2d 3e (common:htree->
9830: 68 74 6d 6c 20 74 65 73 74 73 2d 68 74 72 65 65 html tests-htree
9840: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
9850: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9860: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9870: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9880: 20 20 27 28 29 0a 20 20 20 20 20 20 20 20 20 20 '().
9890: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
98a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
98b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
98c0: 20 20 20 20 20 20 20 28 6c 61 6d 62 64 61 20 28 (lambda (
98d0: 78 20 70 29 0a 20 20 20 20 20 20 20 20 20 20 20 x p).
98e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
98f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9900: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9910: 20 20 20 20 20 20 20 20 28 6c 65 74 2a 20 28 28 (let* ((
9920: 74 61 72 67 2d 70 61 74 68 20 28 73 74 72 69 6e targ-path (strin
9930: 67 2d 69 6e 74 65 72 73 70 65 72 73 65 20 70 20 g-intersperse p
9940: 22 2f 22 29 29 0a 20 20 20 20 20 20 20 20 20 20 "/")).
9950: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9960: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9970: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9980: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9990: 28 74 65 73 74 2d 6e 61 6d 65 20 28 63 61 72 20 (test-name (car
99a0: 70 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 p)).
99b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
99c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
99d0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
99e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 69 (i
99f0: 74 65 6d 2d 70 61 74 68 20 3b 3b 20 28 69 66 20 tem-path ;; (if
9a00: 28 3e 20 28 6c 65 6e 67 74 68 20 70 29 20 32 29 (> (length p) 2)
9a10: 20 3b 3b 20 74 65 73 74 2d 6e 61 6d 65 20 2b 20 ;; test-name +
9a20: 72 75 6e 2d 6e 61 6d 65 0a 20 20 20 20 20 20 20 run-name.
9a30: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9a40: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9a50: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9a60: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9a70: 20 20 20 20 28 73 74 72 69 6e 67 2d 69 6e 74 65 (string-inte
9a80: 72 73 70 65 72 73 65 20 70 20 22 2f 22 29 29 0a rsperse p "/")).
9a90: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9aa0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9ab0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9ac0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9ad0: 20 20 20 20 20 20 20 20 20 20 28 66 75 6c 6c 2d (full-
9ae0: 74 61 72 67 20 28 63 6f 6e 63 20 68 74 6d 6c 2d targ (conc html-
9af0: 64 69 72 20 22 2f 22 20 74 61 72 67 2d 70 61 74 dir "/" targ-pat
9b00: 68 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 h)).
9b10: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9b20: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9b30: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9b40: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 73 (s
9b50: 74 64 2d 66 69 6c 65 20 20 28 63 6f 6e 63 20 66 td-file (conc f
9b60: 75 6c 6c 2d 74 61 72 67 20 22 2f 74 65 73 74 2d ull-targ "/test-
9b70: 73 75 6d 6d 61 72 79 2e 68 74 6d 6c 22 29 29 0a summary.html")).
9b80: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9b90: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9ba0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9bb0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9bc0: 20 20 20 20 20 20 20 20 20 20 28 61 6c 74 2d 66 (alt-f
9bd0: 69 6c 65 20 20 28 63 6f 6e 63 20 66 75 6c 6c 2d ile (conc full-
9be0: 74 61 72 67 20 22 2f 6d 65 67 61 74 65 73 74 2d targ "/megatest-
9bf0: 72 6f 6c 6c 75 70 2d 22 20 74 65 73 74 2d 6e 61 rollup-" test-na
9c00: 6d 65 20 22 2e 68 74 6d 6c 22 29 29 0a 20 20 20 me ".html")).
9c10: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9c20: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9c30: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9c40: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9c50: 20 20 20 20 20 20 20 28 68 74 6d 6c 2d 66 69 6c (html-fil
9c60: 65 20 28 69 66 20 28 66 69 6c 65 2d 65 78 69 73 e (if (file-exis
9c70: 74 73 3f 20 61 6c 74 2d 66 69 6c 65 29 0a 20 20 ts? alt-file).
9c80: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9c90: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9ca0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9cb0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9cc0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9cd0: 20 20 20 20 20 20 20 61 6c 74 2d 66 69 6c 65 0a alt-file.
9ce0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9cf0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9d00: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9d10: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9d20: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9d30: 20 20 20 20 20 20 20 20 20 73 74 64 2d 66 69 6c std-fil
9d40: 65 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 e)).
9d50: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9d60: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9d70: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9d80: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 72 (r
9d90: 75 6e 2d 6e 61 6d 65 20 20 28 63 61 72 20 28 72 un-name (car (r
9da0: 65 76 65 72 73 65 20 70 29 29 29 29 0a 20 20 20 everse p)))).
9db0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9dc0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9dd0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9de0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9df0: 20 20 28 69 66 20 28 61 6e 64 20 28 6e 6f 74 20 (if (and (not
9e00: 28 66 69 6c 65 2d 65 78 69 73 74 73 3f 20 66 75 (file-exists? fu
9e10: 6c 6c 2d 74 61 72 67 29 29 0a 20 20 20 20 20 20 ll-targ)).
9e20: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9e30: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9e40: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9e50: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9e60: 20 20 20 20 20 20 20 20 28 64 69 72 65 63 74 6f (directo
9e70: 72 79 3f 20 66 75 6c 6c 2d 74 61 72 67 29 0a 20 ry? full-targ).
9e80: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9e90: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9ea0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9eb0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9ec0: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 66 69 (fi
9ed0: 6c 65 2d 77 72 69 74 65 2d 61 63 63 65 73 73 3f le-write-access?
9ee0: 20 66 75 6c 6c 2d 74 61 72 67 29 29 0a 20 20 20 full-targ)).
9ef0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9f00: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9f10: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9f20: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9f30: 20 20 20 20 20 20 28 74 65 73 74 73 3a 73 75 6d (tests:sum
9f40: 6d 61 72 69 7a 65 2d 74 65 73 74 20 0a 20 20 20 marize-test .
9f50: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9f60: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9f70: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9f80: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9f90: 20 20 20 20 20 20 20 72 75 6e 2d 69 64 20 0a 20 run-id .
9fa0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9fb0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9fc0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9fd0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9fe0: 20 20 20 20 20 20 20 20 20 28 72 6d 74 3a 67 65 (rmt:ge
9ff0: 74 2d 74 65 73 74 2d 69 64 20 72 75 6e 2d 69 64 t-test-id run-id
a000: 20 74 65 73 74 2d 6e 61 6d 65 20 69 74 65 6d 2d test-name item-
a010: 70 61 74 68 29 29 29 0a 20 20 20 20 20 20 20 20 path))).
a020: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
a030: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
a040: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
a050: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 69 66 (if
a060: 20 28 66 69 6c 65 2d 65 78 69 73 74 73 3f 20 66 (file-exists? f
a070: 75 6c 6c 2d 74 61 72 67 29 0a 20 20 20 20 20 20 ull-targ).
a080: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
a090: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
a0a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
a0b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
a0c0: 20 20 20 28 73 3a 61 20 72 75 6e 2d 6e 61 6d 65 (s:a run-name
a0d0: 20 27 68 72 65 66 20 68 74 6d 6c 2d 66 69 6c 65 'href html-file
a0e0: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
a0f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
a100: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
a110: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
a120: 20 20 20 20 20 20 20 20 20 20 20 28 62 65 67 69 (begi
a130: 6e 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 n.
a140: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
a150: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
a160: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
a170: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 64 65 (de
a180: 62 75 67 3a 70 72 69 6e 74 20 30 20 2a 64 65 66 bug:print 0 *def
a190: 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 ault-log-port* "
a1a0: 45 52 52 4f 52 3a 20 63 61 6e 27 74 20 61 63 63 ERROR: can't acc
a1b0: 65 73 73 20 22 20 66 75 6c 6c 2d 74 61 72 67 29 ess " full-targ)
a1c0: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
a1d0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
a1e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
a1f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
a200: 20 20 20 20 20 20 20 20 20 20 20 20 28 63 6f 6e (con
a210: 63 20 22 4e 6f 20 73 75 6d 6d 61 72 79 20 66 6f c "No summary fo
a220: 72 20 22 20 72 75 6e 2d 6e 61 6d 65 29 29 29 29 r " run-name))))
a230: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
a240: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
a250: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
a260: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
a270: 20 20 20 29 29 29 29 29 29 0a 20 20 20 20 20 20 )))))).
a280: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
a290: 63 6c 6f 73 65 2d 6f 75 74 70 75 74 2d 70 6f 72 close-output-por
a2a0: 74 20 6f 75 70 29 29 29 29 29 0a 20 20 20 20 20 t oup))))).
a2b0: 20 20 20 20 20 20 72 75 6e 73 29 0a 20 20 20 20 runs).
a2c0: 20 20 20 20 20 20 23 74 29 0a 09 23 66 29 29 29 #t)..#f)))
a2d0: 0a 0a 0a 0a 0a 0a 0a 0a 3b 3b 20 43 48 45 43 4b ........;; CHECK
a2e0: 20 2d 20 57 41 53 20 54 48 49 53 20 41 44 44 45 - WAS THIS ADDE
a2f0: 44 20 4f 52 20 52 45 4d 4f 56 45 44 3f 20 4d 41 D OR REMOVED? MA
a300: 4e 55 41 4c 20 4d 45 52 47 45 20 57 49 54 48 20 NUAL MERGE WITH
a310: 41 50 49 20 53 54 55 46 46 21 21 21 0a 3b 3b 0a API STUFF!!!.;;.
a320: 3b 3b 20 67 65 74 20 61 20 70 72 65 74 74 79 20 ;; get a pretty
a330: 74 61 62 6c 65 20 74 6f 20 73 75 6d 6d 61 72 69 table to summari
a340: 7a 65 20 73 74 65 70 73 0a 3b 3b 0a 3b 3b 20 28 ze steps.;;.;; (
a350: 64 65 66 69 6e 65 20 28 64 63 6f 6d 6d 6f 6e 3a define (dcommon:
a360: 70 72 6f 63 65 73 73 2d 73 74 65 70 73 2d 74 61 process-steps-ta
a370: 62 6c 65 20 73 74 65 70 73 29 3b 3b 20 64 62 20 ble steps);; db
a380: 74 65 73 74 2d 69 64 20 23 21 6b 65 79 20 28 77 test-id #!key (w
a390: 6f 72 6b 2d 61 72 65 61 20 23 66 29 29 0a 28 64 ork-area #f)).(d
a3a0: 65 66 69 6e 65 20 28 74 65 73 74 73 3a 70 72 6f efine (tests:pro
a3b0: 63 65 73 73 2d 73 74 65 70 73 2d 74 61 62 6c 65 cess-steps-table
a3c0: 20 73 74 65 70 73 29 3b 3b 20 64 62 20 74 65 73 steps);; db tes
a3d0: 74 2d 69 64 20 23 21 6b 65 79 20 28 77 6f 72 6b t-id #!key (work
a3e0: 2d 61 72 65 61 20 23 66 29 29 0a 3b 3b 20 20 28 -area #f)).;; (
a3f0: 6c 65 74 20 28 28 73 74 65 70 73 20 20 20 28 64 let ((steps (d
a400: 62 3a 67 65 74 2d 73 74 65 70 73 2d 66 6f 72 2d b:get-steps-for-
a410: 74 65 73 74 20 64 62 20 74 65 73 74 2d 69 64 20 test db test-id
a420: 77 6f 72 6b 2d 61 72 65 61 3a 20 77 6f 72 6b 2d work-area: work-
a430: 61 72 65 61 29 29 29 0a 20 20 20 20 3b 3b 20 6f area))). ;; o
a440: 72 67 61 6e 69 73 65 20 74 68 65 20 73 74 65 70 rganise the step
a450: 73 20 66 6f 72 20 62 65 74 74 65 72 20 72 65 61 s for better rea
a460: 64 61 62 69 6c 69 74 79 0a 20 20 20 20 28 6c 65 dability. (le
a470: 74 20 28 28 72 65 73 20 28 6d 61 6b 65 2d 68 61 t ((res (make-ha
a480: 73 68 2d 74 61 62 6c 65 29 29 29 0a 20 20 20 20 sh-table))).
a490: 20 20 28 66 6f 72 2d 65 61 63 68 20 0a 20 20 20 (for-each .
a4a0: 20 20 20 20 28 6c 61 6d 62 64 61 20 28 73 74 65 (lambda (ste
a4b0: 70 29 0a 09 20 28 64 65 62 75 67 3a 70 72 69 6e p).. (debug:prin
a4c0: 74 20 36 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 t 6 *default-log
a4d0: 2d 70 6f 72 74 2a 20 22 73 74 65 70 3d 22 20 73 -port* "step=" s
a4e0: 74 65 70 29 0a 09 20 28 6c 65 74 20 28 28 72 65 tep).. (let ((re
a4f0: 63 6f 72 64 20 28 68 61 73 68 2d 74 61 62 6c 65 cord (hash-table
a500: 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 0a 09 09 -ref/default ...
a510: 09 72 65 73 20 0a 09 09 09 28 74 64 62 3a 73 74 .res ....(tdb:st
a520: 65 70 2d 67 65 74 2d 73 74 65 70 6e 61 6d 65 20 ep-get-stepname
a530: 73 74 65 70 29 20 0a 09 09 09 3b 3b 20 20 20 20 step) ....;;
a540: 20 20 20 20 73 74 65 70 6e 61 6d 65 20 20 20 20 stepname
a550: 20 20 20 20 20 20 20 20 20 20 20 20 73 74 61 72 star
a560: 74 20 65 6e 64 20 73 74 61 74 75 73 20 44 75 72 t end status Dur
a570: 61 74 69 6f 6e 20 20 4c 6f 67 66 69 6c 65 20 43 ation Logfile C
a580: 6f 6d 6d 65 6e 74 0a 09 09 09 28 76 65 63 74 6f omment....(vecto
a590: 72 20 28 74 64 62 3a 73 74 65 70 2d 67 65 74 2d r (tdb:step-get-
a5a0: 73 74 65 70 6e 61 6d 65 20 73 74 65 70 29 20 22 stepname step) "
a5b0: 22 20 20 20 22 22 20 22 22 20 20 20 20 20 22 22 " "" "" ""
a5c0: 20 20 20 20 20 20 20 20 22 22 20 20 20 20 20 22 "" "
a5d0: 22 29 29 29 29 0a 09 20 20 20 28 64 65 62 75 67 ")))).. (debug
a5e0: 3a 70 72 69 6e 74 20 36 20 2a 64 65 66 61 75 6c :print 6 *defaul
a5f0: 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 72 65 63 t-log-port* "rec
a600: 6f 72 64 28 62 65 66 6f 72 65 29 20 3d 20 22 20 ord(before) = "
a610: 72 65 63 6f 72 64 20 0a 09 09 09 22 5c 6e 69 64 record ...."\nid
a620: 3a 20 20 20 20 20 20 20 22 20 28 74 64 62 3a 73 : " (tdb:s
a630: 74 65 70 2d 67 65 74 2d 69 64 20 73 74 65 70 29 tep-get-id step)
a640: 0a 09 09 09 22 5c 6e 73 74 65 70 6e 61 6d 65 3a ...."\nstepname:
a650: 20 22 20 28 74 64 62 3a 73 74 65 70 2d 67 65 74 " (tdb:step-get
a660: 2d 73 74 65 70 6e 61 6d 65 20 73 74 65 70 29 0a -stepname step).
a670: 09 09 09 22 5c 6e 73 74 61 74 65 3a 20 20 20 20 ..."\nstate:
a680: 22 20 28 74 64 62 3a 73 74 65 70 2d 67 65 74 2d " (tdb:step-get-
a690: 73 74 61 74 65 20 73 74 65 70 29 0a 09 09 09 22 state step)...."
a6a0: 5c 6e 73 74 61 74 75 73 3a 20 20 20 22 20 28 74 \nstatus: " (t
a6b0: 64 62 3a 73 74 65 70 2d 67 65 74 2d 73 74 61 74 db:step-get-stat
a6c0: 75 73 20 73 74 65 70 29 0a 09 09 09 22 5c 6e 74 us step)...."\nt
a6d0: 69 6d 65 3a 20 20 20 20 20 22 20 28 74 64 62 3a ime: " (tdb:
a6e0: 73 74 65 70 2d 67 65 74 2d 65 76 65 6e 74 5f 74 step-get-event_t
a6f0: 69 6d 65 20 73 74 65 70 29 29 0a 09 20 20 20 28 ime step)).. (
a700: 63 61 73 65 20 28 73 74 72 69 6e 67 2d 3e 73 79 case (string->sy
a710: 6d 62 6f 6c 20 28 74 64 62 3a 73 74 65 70 2d 67 mbol (tdb:step-g
a720: 65 74 2d 73 74 61 74 65 20 73 74 65 70 29 29 0a et-state step)).
a730: 09 20 20 20 20 20 28 28 73 74 61 72 74 29 28 76 . ((start)(v
a740: 65 63 74 6f 72 2d 73 65 74 21 20 72 65 63 6f 72 ector-set! recor
a750: 64 20 31 20 28 74 64 62 3a 73 74 65 70 2d 67 65 d 1 (tdb:step-ge
a760: 74 2d 65 76 65 6e 74 5f 74 69 6d 65 20 73 74 65 t-event_time ste
a770: 70 29 29 0a 09 20 20 20 20 20 20 28 76 65 63 74 p)).. (vect
a780: 6f 72 2d 73 65 74 21 20 72 65 63 6f 72 64 20 33 or-set! record 3
a790: 20 28 69 66 20 28 65 71 75 61 6c 3f 20 28 76 65 (if (equal? (ve
a7a0: 63 74 6f 72 2d 72 65 66 20 72 65 63 6f 72 64 20 ctor-ref record
a7b0: 33 29 20 22 22 29 0a 09 09 09 09 09 28 74 64 62 3) "")......(tdb
a7c0: 3a 73 74 65 70 2d 67 65 74 2d 73 74 61 74 75 73 :step-get-status
a7d0: 20 73 74 65 70 29 29 29 0a 09 20 20 20 20 20 20 step)))..
a7e0: 28 69 66 20 28 3e 20 28 73 74 72 69 6e 67 2d 6c (if (> (string-l
a7f0: 65 6e 67 74 68 20 28 74 64 62 3a 73 74 65 70 2d ength (tdb:step-
a800: 67 65 74 2d 6c 6f 67 66 69 6c 65 20 73 74 65 70 get-logfile step
a810: 29 29 0a 09 09 20 20 20 20 20 30 29 0a 09 09 20 ))... 0)...
a820: 20 28 76 65 63 74 6f 72 2d 73 65 74 21 20 72 65 (vector-set! re
a830: 63 6f 72 64 20 35 20 28 74 64 62 3a 73 74 65 70 cord 5 (tdb:step
a840: 2d 67 65 74 2d 6c 6f 67 66 69 6c 65 20 73 74 65 -get-logfile ste
a850: 70 29 29 29 29 0a 09 20 20 20 20 20 28 28 65 6e p)))).. ((en
a860: 64 29 20 20 0a 09 20 20 20 20 20 20 28 76 65 63 d) .. (vec
a870: 74 6f 72 2d 73 65 74 21 20 72 65 63 6f 72 64 20 tor-set! record
a880: 32 20 28 61 6e 79 2d 3e 6e 75 6d 62 65 72 20 28 2 (any->number (
a890: 74 64 62 3a 73 74 65 70 2d 67 65 74 2d 65 76 65 tdb:step-get-eve
a8a0: 6e 74 5f 74 69 6d 65 20 73 74 65 70 29 29 29 0a nt_time step))).
a8b0: 09 20 20 20 20 20 20 28 76 65 63 74 6f 72 2d 73 . (vector-s
a8c0: 65 74 21 20 72 65 63 6f 72 64 20 33 20 28 74 64 et! record 3 (td
a8d0: 62 3a 73 74 65 70 2d 67 65 74 2d 73 74 61 74 75 b:step-get-statu
a8e0: 73 20 73 74 65 70 29 29 0a 09 20 20 20 20 20 20 s step))..
a8f0: 28 76 65 63 74 6f 72 2d 73 65 74 21 20 72 65 63 (vector-set! rec
a900: 6f 72 64 20 34 20 28 6c 65 74 20 28 28 73 74 61 ord 4 (let ((sta
a910: 72 74 74 20 28 61 6e 79 2d 3e 6e 75 6d 62 65 72 rtt (any->number
a920: 20 28 76 65 63 74 6f 72 2d 72 65 66 20 72 65 63 (vector-ref rec
a930: 6f 72 64 20 31 29 29 29 0a 09 09 09 09 09 20 20 ord 1)))......
a940: 28 65 6e 64 74 20 20 20 28 61 6e 79 2d 3e 6e 75 (endt (any->nu
a950: 6d 62 65 72 20 28 76 65 63 74 6f 72 2d 72 65 66 mber (vector-ref
a960: 20 72 65 63 6f 72 64 20 32 29 29 29 29 0a 09 09 record 2))))...
a970: 09 09 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 .. (debug:p
a980: 72 69 6e 74 20 34 20 2a 64 65 66 61 75 6c 74 2d rint 4 *default-
a990: 6c 6f 67 2d 70 6f 72 74 2a 20 22 72 65 63 6f 72 log-port* "recor
a9a0: 64 5b 31 5d 3d 22 20 28 76 65 63 74 6f 72 2d 72 d[1]=" (vector-r
a9b0: 65 66 20 72 65 63 6f 72 64 20 31 29 20 0a 09 09 ef record 1) ...
a9c0: 09 09 09 09 20 20 20 22 2c 20 73 74 61 72 74 74 .... ", startt
a9d0: 3d 22 20 73 74 61 72 74 74 20 22 2c 20 65 6e 64 =" startt ", end
a9e0: 74 3d 22 20 65 6e 64 74 0a 09 09 09 09 09 09 20 t=" endt.......
a9f0: 20 20 22 2c 20 67 65 74 2d 73 74 61 74 75 73 3a ", get-status:
aa00: 20 22 20 28 74 64 62 3a 73 74 65 70 2d 67 65 74 " (tdb:step-get
aa10: 2d 73 74 61 74 75 73 20 73 74 65 70 29 29 0a 09 -status step))..
aa20: 09 09 09 20 20 20 20 20 20 28 69 66 20 28 61 6e ... (if (an
aa30: 64 20 28 6e 75 6d 62 65 72 3f 20 73 74 61 72 74 d (number? start
aa40: 74 29 28 6e 75 6d 62 65 72 3f 20 65 6e 64 74 29 t)(number? endt)
aa50: 29 0a 09 09 09 09 09 20 20 28 73 65 63 6f 6e 64 )...... (second
aa60: 73 2d 3e 68 72 2d 6d 69 6e 2d 73 65 63 20 28 2d s->hr-min-sec (-
aa70: 20 65 6e 64 74 20 73 74 61 72 74 74 29 29 20 22 endt startt)) "
aa80: 2d 31 22 29 29 29 0a 09 20 20 20 20 20 20 28 69 -1"))).. (i
aa90: 66 20 28 3e 20 28 73 74 72 69 6e 67 2d 6c 65 6e f (> (string-len
aaa0: 67 74 68 20 28 74 64 62 3a 73 74 65 70 2d 67 65 gth (tdb:step-ge
aab0: 74 2d 6c 6f 67 66 69 6c 65 20 73 74 65 70 29 29 t-logfile step))
aac0: 0a 09 09 20 20 20 20 20 30 29 0a 09 09 20 20 28 ... 0)... (
aad0: 76 65 63 74 6f 72 2d 73 65 74 21 20 72 65 63 6f vector-set! reco
aae0: 72 64 20 35 20 28 74 64 62 3a 73 74 65 70 2d 67 rd 5 (tdb:step-g
aaf0: 65 74 2d 6c 6f 67 66 69 6c 65 20 73 74 65 70 29 et-logfile step)
ab00: 29 29 0a 09 20 20 20 20 20 20 28 69 66 20 28 3e )).. (if (>
ab10: 20 28 73 74 72 69 6e 67 2d 6c 65 6e 67 74 68 20 (string-length
ab20: 28 74 64 62 3a 73 74 65 70 2d 67 65 74 2d 63 6f (tdb:step-get-co
ab30: 6d 6d 65 6e 74 20 73 74 65 70 29 29 0a 09 09 20 mment step))...
ab40: 20 20 20 20 30 29 0a 09 09 20 20 28 76 65 63 74 0)... (vect
ab50: 6f 72 2d 73 65 74 21 20 72 65 63 6f 72 64 20 36 or-set! record 6
ab60: 20 28 74 64 62 3a 73 74 65 70 2d 67 65 74 2d 63 (tdb:step-get-c
ab70: 6f 6d 6d 65 6e 74 20 73 74 65 70 29 29 29 29 0a omment step)))).
ab80: 09 20 20 20 20 20 28 65 6c 73 65 0a 09 20 20 20 . (else..
ab90: 20 20 20 28 76 65 63 74 6f 72 2d 73 65 74 21 20 (vector-set!
aba0: 72 65 63 6f 72 64 20 32 20 28 74 64 62 3a 73 74 record 2 (tdb:st
abb0: 65 70 2d 67 65 74 2d 73 74 61 74 65 20 73 74 65 ep-get-state ste
abc0: 70 29 29 0a 09 20 20 20 20 20 20 28 76 65 63 74 p)).. (vect
abd0: 6f 72 2d 73 65 74 21 20 72 65 63 6f 72 64 20 33 or-set! record 3
abe0: 20 28 74 64 62 3a 73 74 65 70 2d 67 65 74 2d 73 (tdb:step-get-s
abf0: 74 61 74 75 73 20 73 74 65 70 29 29 0a 09 20 20 tatus step))..
ac00: 20 20 20 20 28 76 65 63 74 6f 72 2d 73 65 74 21 (vector-set!
ac10: 20 72 65 63 6f 72 64 20 34 20 28 74 64 62 3a 73 record 4 (tdb:s
ac20: 74 65 70 2d 67 65 74 2d 65 76 65 6e 74 5f 74 69 tep-get-event_ti
ac30: 6d 65 20 73 74 65 70 29 29 0a 09 20 20 20 20 20 me step))..
ac40: 20 28 76 65 63 74 6f 72 2d 73 65 74 21 20 72 65 (vector-set! re
ac50: 63 6f 72 64 20 36 20 28 74 64 62 3a 73 74 65 70 cord 6 (tdb:step
ac60: 2d 67 65 74 2d 63 6f 6d 6d 65 6e 74 20 73 74 65 -get-comment ste
ac70: 70 29 29 29 29 0a 09 20 20 20 28 68 61 73 68 2d p)))).. (hash-
ac80: 74 61 62 6c 65 2d 73 65 74 21 20 72 65 73 20 28 table-set! res (
ac90: 74 64 62 3a 73 74 65 70 2d 67 65 74 2d 73 74 65 tdb:step-get-ste
aca0: 70 6e 61 6d 65 20 73 74 65 70 29 20 72 65 63 6f pname step) reco
acb0: 72 64 29 0a 09 20 20 20 28 64 65 62 75 67 3a 70 rd).. (debug:p
acc0: 72 69 6e 74 20 36 20 2a 64 65 66 61 75 6c 74 2d rint 6 *default-
acd0: 6c 6f 67 2d 70 6f 72 74 2a 20 22 72 65 63 6f 72 log-port* "recor
ace0: 64 28 61 66 74 65 72 29 20 20 3d 20 22 20 72 65 d(after) = " re
acf0: 63 6f 72 64 20 0a 09 09 09 22 5c 6e 69 64 3a 20 cord ...."\nid:
ad00: 20 20 20 20 20 20 22 20 28 74 64 62 3a 73 74 65 " (tdb:ste
ad10: 70 2d 67 65 74 2d 69 64 20 73 74 65 70 29 0a 09 p-get-id step)..
ad20: 09 09 22 5c 6e 73 74 65 70 6e 61 6d 65 3a 20 22 .."\nstepname: "
ad30: 20 28 74 64 62 3a 73 74 65 70 2d 67 65 74 2d 73 (tdb:step-get-s
ad40: 74 65 70 6e 61 6d 65 20 73 74 65 70 29 0a 09 09 tepname step)...
ad50: 09 22 5c 6e 73 74 61 74 65 3a 20 20 20 20 22 20 ."\nstate: "
ad60: 28 74 64 62 3a 73 74 65 70 2d 67 65 74 2d 73 74 (tdb:step-get-st
ad70: 61 74 65 20 73 74 65 70 29 0a 09 09 09 22 5c 6e ate step)...."\n
ad80: 73 74 61 74 75 73 3a 20 20 20 22 20 28 74 64 62 status: " (tdb
ad90: 3a 73 74 65 70 2d 67 65 74 2d 73 74 61 74 75 73 :step-get-status
ada0: 20 73 74 65 70 29 0a 09 09 09 22 5c 6e 74 69 6d step)...."\ntim
adb0: 65 3a 20 20 20 20 20 22 20 28 74 64 62 3a 73 74 e: " (tdb:st
adc0: 65 70 2d 67 65 74 2d 65 76 65 6e 74 5f 74 69 6d ep-get-event_tim
add0: 65 20 73 74 65 70 29 29 29 29 0a 20 20 20 20 20 e step)))).
ade0: 20 20 3b 3b 20 28 65 6c 73 65 20 20 20 28 76 65 ;; (else (ve
adf0: 63 74 6f 72 2d 73 65 74 21 20 72 65 63 6f 72 64 ctor-set! record
ae00: 20 31 20 28 74 64 62 3a 73 74 65 70 2d 67 65 74 1 (tdb:step-get
ae10: 2d 65 76 65 6e 74 5f 74 69 6d 65 20 73 74 65 70 -event_time step
ae20: 29 29 29 0a 20 20 20 20 20 20 20 28 73 6f 72 74 ))). (sort
ae30: 20 73 74 65 70 73 20 28 6c 61 6d 62 64 61 20 28 steps (lambda (
ae40: 61 20 62 29 0a 09 09 20 20 20 20 20 28 63 6f 6e a b)... (con
ae50: 64 0a 09 09 20 20 20 20 20 20 28 28 3c 20 20 20 d... ((<
ae60: 28 74 64 62 3a 73 74 65 70 2d 67 65 74 2d 65 76 (tdb:step-get-ev
ae70: 65 6e 74 5f 74 69 6d 65 20 61 29 28 74 64 62 3a ent_time a)(tdb:
ae80: 73 74 65 70 2d 67 65 74 2d 65 76 65 6e 74 5f 74 step-get-event_t
ae90: 69 6d 65 20 62 29 29 20 23 74 29 0a 09 09 20 20 ime b)) #t)...
aea0: 20 20 20 20 28 28 65 71 3f 20 28 74 64 62 3a 73 ((eq? (tdb:s
aeb0: 74 65 70 2d 67 65 74 2d 65 76 65 6e 74 5f 74 69 tep-get-event_ti
aec0: 6d 65 20 61 29 28 74 64 62 3a 73 74 65 70 2d 67 me a)(tdb:step-g
aed0: 65 74 2d 65 76 65 6e 74 5f 74 69 6d 65 20 62 29 et-event_time b)
aee0: 29 20 0a 09 09 20 20 20 20 20 20 20 28 3c 20 20 ) ... (<
aef0: 20 28 74 64 62 3a 73 74 65 70 2d 67 65 74 2d 69 (tdb:step-get-i
af00: 64 20 61 29 20 20 20 20 20 20 20 20 28 74 64 62 d a) (tdb
af10: 3a 73 74 65 70 2d 67 65 74 2d 69 64 20 62 29 29 :step-get-id b))
af20: 29 0a 09 09 20 20 20 20 20 20 28 65 6c 73 65 20 )... (else
af30: 23 66 29 29 29 29 29 0a 20 20 20 20 20 20 72 65 #f))))). re
af40: 73 29 29 0a 0a 3b 3b 20 0a 3b 3b 0a 28 64 65 66 s))..;; .;;.(def
af50: 69 6e 65 20 28 74 65 73 74 73 3a 67 65 74 2d 63 ine (tests:get-c
af60: 6f 6d 70 72 65 73 73 65 64 2d 73 74 65 70 73 20 ompressed-steps
af70: 72 75 6e 2d 69 64 20 74 65 73 74 2d 69 64 29 0a run-id test-id).
af80: 20 20 28 6c 65 74 2a 20 28 28 73 74 65 70 73 2d (let* ((steps-
af90: 64 61 74 61 20 20 28 72 6d 74 3a 67 65 74 2d 73 data (rmt:get-s
afa0: 74 65 70 73 2d 66 6f 72 2d 74 65 73 74 20 72 75 teps-for-test ru
afb0: 6e 2d 69 64 20 74 65 73 74 2d 69 64 29 29 0a 09 n-id test-id))..
afc0: 20 28 63 6f 6d 70 72 73 74 65 70 73 20 20 28 74 (comprsteps (t
afd0: 65 73 74 73 3a 70 72 6f 63 65 73 73 2d 73 74 65 ests:process-ste
afe0: 70 73 2d 74 61 62 6c 65 20 73 74 65 70 73 2d 64 ps-table steps-d
aff0: 61 74 61 29 29 29 20 3b 3b 20 28 6f 70 65 6e 2d ata))) ;; (open-
b000: 72 75 6e 2d 63 6c 6f 73 65 20 64 62 3a 67 65 74 run-close db:get
b010: 2d 73 74 65 70 73 2d 74 61 62 6c 65 20 23 66 20 -steps-table #f
b020: 74 65 73 74 2d 69 64 20 77 6f 72 6b 2d 61 72 65 test-id work-are
b030: 61 3a 20 77 6f 72 6b 2d 61 72 65 61 29 29 29 0a a: work-area))).
b040: 20 20 20 20 28 6d 61 70 20 28 6c 61 6d 62 64 61 (map (lambda
b050: 20 28 78 29 0a 09 20 20 20 3b 3b 20 74 61 6b 65 (x).. ;; take
b060: 20 61 64 76 61 6e 74 61 67 65 20 6f 66 20 74 68 advantage of th
b070: 65 20 5c 6e 20 6f 6e 20 74 69 6d 65 2d 3e 73 74 e \n on time->st
b080: 72 69 6e 67 0a 09 20 20 20 28 76 65 63 74 6f 72 ring.. (vector
b090: 0a 09 20 20 20 20 28 76 65 63 74 6f 72 2d 72 65 .. (vector-re
b0a0: 66 20 78 20 30 29 0a 09 20 20 20 20 28 6c 65 74 f x 0).. (let
b0b0: 20 28 28 73 20 28 76 65 63 74 6f 72 2d 72 65 66 ((s (vector-ref
b0c0: 20 78 20 31 29 29 29 0a 09 20 20 20 20 20 20 28 x 1))).. (
b0d0: 69 66 20 28 6e 75 6d 62 65 72 3f 20 73 29 28 73 if (number? s)(s
b0e0: 65 63 6f 6e 64 73 2d 3e 74 69 6d 65 2d 73 74 72 econds->time-str
b0f0: 69 6e 67 20 73 29 20 73 29 29 0a 09 20 20 20 20 ing s) s))..
b100: 28 6c 65 74 20 28 28 73 20 28 76 65 63 74 6f 72 (let ((s (vector
b110: 2d 72 65 66 20 78 20 32 29 29 29 0a 09 20 20 20 -ref x 2)))..
b120: 20 20 20 28 69 66 20 28 6e 75 6d 62 65 72 3f 20 (if (number?
b130: 73 29 28 73 65 63 6f 6e 64 73 2d 3e 74 69 6d 65 s)(seconds->time
b140: 2d 73 74 72 69 6e 67 20 73 29 20 73 29 29 0a 09 -string s) s))..
b150: 20 20 20 20 28 76 65 63 74 6f 72 2d 72 65 66 20 (vector-ref
b160: 78 20 33 29 20 20 20 20 3b 3b 20 73 74 61 74 75 x 3) ;; statu
b170: 73 0a 09 20 20 20 20 28 76 65 63 74 6f 72 2d 72 s.. (vector-r
b180: 65 66 20 78 20 34 29 0a 09 20 20 20 20 28 76 65 ef x 4).. (ve
b190: 63 74 6f 72 2d 72 65 66 20 78 20 35 29 20 20 3b ctor-ref x 5) ;
b1a0: 3b 20 74 69 6d 65 20 64 65 6c 74 61 0a 09 20 20 ; time delta..
b1b0: 20 20 28 76 65 63 74 6f 72 2d 72 65 66 20 78 20 (vector-ref x
b1c0: 36 29 29 29 0a 09 20 28 73 6f 72 74 20 28 68 61 6))).. (sort (ha
b1d0: 73 68 2d 74 61 62 6c 65 2d 76 61 6c 75 65 73 20 sh-table-values
b1e0: 63 6f 6d 70 72 73 74 65 70 73 29 0a 09 20 20 20 comprsteps)..
b1f0: 20 20 20 20 28 6c 61 6d 62 64 61 20 28 61 20 62 (lambda (a b
b200: 29 0a 09 09 20 28 6c 65 74 20 28 28 74 69 6d 65 )... (let ((time
b210: 2d 61 20 28 76 65 63 74 6f 72 2d 72 65 66 20 61 -a (vector-ref a
b220: 20 31 29 29 0a 09 09 20 20 20 20 20 20 20 28 74 1))... (t
b230: 69 6d 65 2d 62 20 28 76 65 63 74 6f 72 2d 72 65 ime-b (vector-re
b240: 66 20 62 20 31 29 29 29 0a 09 09 20 20 20 28 69 f b 1)))... (i
b250: 66 20 28 61 6e 64 20 28 6e 75 6d 62 65 72 3f 20 f (and (number?
b260: 74 69 6d 65 2d 61 29 28 6e 75 6d 62 65 72 3f 20 time-a)(number?
b270: 74 69 6d 65 2d 62 29 29 0a 09 09 20 20 20 20 20 time-b))...
b280: 20 20 28 69 66 20 28 3c 20 74 69 6d 65 2d 61 20 (if (< time-a
b290: 74 69 6d 65 2d 62 29 0a 09 09 09 20 20 20 23 74 time-b).... #t
b2a0: 0a 09 09 09 20 20 20 28 69 66 20 28 65 71 3f 20 .... (if (eq?
b2b0: 74 69 6d 65 2d 61 20 74 69 6d 65 2d 62 29 0a 09 time-a time-b)..
b2c0: 09 09 20 20 20 20 20 20 20 28 73 74 72 69 6e 67 .. (string
b2d0: 3c 3f 20 28 63 6f 6e 63 20 28 76 65 63 74 6f 72 <? (conc (vector
b2e0: 2d 72 65 66 20 61 20 32 29 29 0a 09 09 09 09 09 -ref a 2))......
b2f0: 20 28 63 6f 6e 63 20 28 76 65 63 74 6f 72 2d 72 (conc (vector-r
b300: 65 66 20 62 20 32 29 29 29 0a 09 09 09 20 20 20 ef b 2)))....
b310: 20 20 20 20 23 66 29 29 0a 09 09 20 20 20 20 20 #f))...
b320: 20 20 28 73 74 72 69 6e 67 3c 3f 20 28 63 6f 6e (string<? (con
b330: 63 20 74 69 6d 65 2d 61 29 28 63 6f 6e 63 20 74 c time-a)(conc t
b340: 69 6d 65 2d 62 29 29 29 29 29 29 29 29 29 0a 0a ime-b)))))))))..
b350: 0a 3b 3b 20 73 75 6d 6d 61 72 69 7a 65 20 74 65 .;; summarize te
b360: 73 74 20 69 6e 20 74 6f 20 61 20 66 69 6c 65 20 st in to a file
b370: 74 65 73 74 2d 73 75 6d 6d 61 72 79 2e 68 74 6d test-summary.htm
b380: 6c 20 69 6e 20 74 68 65 20 74 65 73 74 20 64 69 l in the test di
b390: 72 65 63 74 6f 72 79 0a 3b 3b 0a 28 64 65 66 69 rectory.;;.(defi
b3a0: 6e 65 20 28 74 65 73 74 73 3a 73 75 6d 6d 61 72 ne (tests:summar
b3b0: 69 7a 65 2d 74 65 73 74 20 72 75 6e 2d 69 64 20 ize-test run-id
b3c0: 74 65 73 74 2d 69 64 29 0a 20 20 28 6c 65 74 2a test-id). (let*
b3d0: 20 28 28 74 65 73 74 2d 64 61 74 20 20 28 72 6d ((test-dat (rm
b3e0: 74 3a 67 65 74 2d 74 65 73 74 2d 69 6e 66 6f 2d t:get-test-info-
b3f0: 62 79 2d 69 64 20 72 75 6e 2d 69 64 20 74 65 73 by-id run-id tes
b400: 74 2d 69 64 29 29 0a 09 20 28 73 74 65 70 73 2d t-id)).. (steps-
b410: 64 61 74 20 28 72 6d 74 3a 67 65 74 2d 73 74 65 dat (rmt:get-ste
b420: 70 73 2d 66 6f 72 2d 74 65 73 74 20 72 75 6e 2d ps-for-test run-
b430: 69 64 20 74 65 73 74 2d 69 64 29 29 0a 09 20 28 id test-id)).. (
b440: 74 65 73 74 2d 6e 61 6d 65 20 28 64 62 3a 74 65 test-name (db:te
b450: 73 74 2d 67 65 74 2d 74 65 73 74 6e 61 6d 65 20 st-get-testname
b460: 74 65 73 74 2d 64 61 74 29 29 0a 09 20 28 69 74 test-dat)).. (it
b470: 65 6d 2d 70 61 74 68 20 28 64 62 3a 74 65 73 74 em-path (db:test
b480: 2d 67 65 74 2d 69 74 65 6d 2d 70 61 74 68 20 74 -get-item-path t
b490: 65 73 74 2d 64 61 74 29 29 0a 09 20 28 66 75 6c est-dat)).. (ful
b4a0: 6c 2d 6e 61 6d 65 20 28 64 62 3a 74 65 73 74 2d l-name (db:test-
b4b0: 6d 61 6b 65 2d 66 75 6c 6c 2d 6e 61 6d 65 20 74 make-full-name t
b4c0: 65 73 74 2d 6e 61 6d 65 20 69 74 65 6d 2d 70 61 est-name item-pa
b4d0: 74 68 29 29 0a 09 20 28 6f 75 70 20 20 20 20 20 th)).. (oup
b4e0: 20 20 28 6f 70 65 6e 2d 6f 75 74 70 75 74 2d 66 (open-output-f
b4f0: 69 6c 65 20 28 63 6f 6e 63 20 28 64 62 3a 74 65 ile (conc (db:te
b500: 73 74 2d 67 65 74 2d 72 75 6e 64 69 72 20 74 65 st-get-rundir te
b510: 73 74 2d 64 61 74 29 20 22 2f 74 65 73 74 2d 73 st-dat) "/test-s
b520: 75 6d 6d 61 72 79 2e 68 74 6d 6c 22 29 29 29 0a ummary.html"))).
b530: 09 20 28 73 74 61 74 75 73 20 20 20 20 28 64 62 . (status (db
b540: 3a 74 65 73 74 2d 67 65 74 2d 73 74 61 74 75 73 :test-get-status
b550: 20 20 20 74 65 73 74 2d 64 61 74 29 29 0a 09 20 test-dat))..
b560: 28 63 6f 6c 6f 72 20 20 20 20 20 28 63 6f 6d 6d (color (comm
b570: 6f 6e 3a 67 65 74 2d 63 6f 6c 6f 72 2d 66 72 6f on:get-color-fro
b580: 6d 2d 73 74 61 74 75 73 20 73 74 61 74 75 73 29 m-status status)
b590: 29 0a 09 20 28 6c 6f 67 66 20 20 20 20 20 20 28 ).. (logf (
b5a0: 64 62 3a 74 65 73 74 2d 67 65 74 2d 66 69 6e 61 db:test-get-fina
b5b0: 6c 5f 6c 6f 67 66 20 74 65 73 74 2d 64 61 74 29 l_logf test-dat)
b5c0: 29 0a 09 20 28 73 74 65 70 73 2d 64 61 74 20 28 ).. (steps-dat (
b5d0: 74 65 73 74 73 3a 67 65 74 2d 63 6f 6d 70 72 65 tests:get-compre
b5e0: 73 73 65 64 2d 73 74 65 70 73 20 72 75 6e 2d 69 ssed-steps run-i
b5f0: 64 20 74 65 73 74 2d 69 64 29 29 29 0a 20 20 20 d test-id))).
b600: 20 3b 3b 20 28 64 63 6f 6d 6d 6f 6e 3a 67 65 74 ;; (dcommon:get
b610: 2d 63 6f 6d 70 72 65 73 73 65 64 2d 73 74 65 70 -compressed-step
b620: 73 20 23 66 20 31 20 33 30 30 34 35 29 0a 20 20 s #f 1 30045).
b630: 20 20 3b 3b 20 28 23 28 22 77 61 73 74 69 6e 67 ;; (#("wasting
b640: 5f 74 69 6d 65 22 20 22 32 33 3a 33 36 3a 31 33 _time" "23:36:13
b650: 22 20 22 32 33 3a 33 36 3a 32 31 22 20 22 30 22 " "23:36:21" "0"
b660: 20 22 38 2e 30 73 22 20 22 77 61 73 74 69 6e 67 "8.0s" "wasting
b670: 5f 74 69 6d 65 2e 6c 6f 67 22 29 29 0a 0a 20 20 _time.log"))..
b680: 20 20 28 73 3a 6f 75 74 70 75 74 2d 6e 65 77 0a (s:output-new.
b690: 20 20 20 20 20 6f 75 70 0a 20 20 20 20 20 28 73 oup. (s
b6a0: 3a 68 74 6d 6c 0a 20 20 20 20 20 20 28 73 3a 74 :html. (s:t
b6b0: 69 74 6c 65 20 22 53 75 6d 6d 61 72 79 20 66 6f itle "Summary fo
b6c0: 72 20 22 20 66 75 6c 6c 2d 6e 61 6d 65 29 0a 20 r " full-name).
b6d0: 20 20 20 20 20 28 73 3a 62 6f 64 79 20 0a 20 20 (s:body .
b6e0: 20 20 20 20 20 28 73 3a 68 32 20 22 53 75 6d 6d (s:h2 "Summ
b6f0: 61 72 79 20 66 6f 72 20 22 20 66 75 6c 6c 2d 6e ary for " full-n
b700: 61 6d 65 29 0a 20 20 20 20 20 20 20 28 73 3a 74 ame). (s:t
b710: 61 62 6c 65 20 27 63 65 6c 6c 73 70 61 63 69 6e able 'cellspacin
b720: 67 20 22 30 22 20 27 62 6f 72 64 65 72 20 22 31 g "0" 'border "1
b730: 22 0a 09 28 73 3a 74 72 20 28 73 3a 74 64 20 22 "..(s:tr (s:td "
b740: 72 75 6e 20 69 64 22 29 20 20 20 28 73 3a 74 64 run id") (s:td
b750: 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 72 75 (db:test-get-ru
b760: 6e 5f 69 64 20 20 20 74 65 73 74 2d 64 61 74 29 n_id test-dat)
b770: 29 0a 09 20 20 20 20 20 20 28 73 3a 74 64 20 22 ).. (s:td "
b780: 74 65 73 74 20 69 64 22 29 20 20 28 73 3a 74 64 test id") (s:td
b790: 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 69 64 (db:test-get-id
b7a0: 20 20 20 20 20 20 20 74 65 73 74 2d 64 61 74 29 test-dat)
b7b0: 29 29 0a 09 28 73 3a 74 72 20 28 73 3a 74 64 20 ))..(s:tr (s:td
b7c0: 22 74 65 73 74 6e 61 6d 65 22 29 20 28 73 3a 74 "testname") (s:t
b7d0: 64 20 74 65 73 74 2d 6e 61 6d 65 29 0a 09 20 20 d test-name)..
b7e0: 20 20 20 20 28 73 3a 74 64 20 22 69 74 65 6d 70 (s:td "itemp
b7f0: 61 74 68 22 29 20 28 73 3a 74 64 20 69 74 65 6d ath") (s:td item
b800: 2d 70 61 74 68 29 29 0a 09 28 73 3a 74 72 20 28 -path))..(s:tr (
b810: 73 3a 74 64 20 22 73 74 61 74 65 22 29 20 20 20 s:td "state")
b820: 20 28 73 3a 74 64 20 28 64 62 3a 74 65 73 74 2d (s:td (db:test-
b830: 67 65 74 2d 73 74 61 74 65 20 20 20 20 74 65 73 get-state tes
b840: 74 2d 64 61 74 29 29 0a 09 20 20 20 20 20 20 28 t-dat)).. (
b850: 73 3a 74 64 20 22 73 74 61 74 75 73 22 29 20 20 s:td "status")
b860: 20 28 73 3a 74 64 20 28 73 3a 61 20 27 68 72 65 (s:td (s:a 'hre
b870: 66 20 6c 6f 67 66 20 28 73 3a 66 6f 6e 74 20 27 f logf (s:font '
b880: 63 6f 6c 6f 72 20 63 6f 6c 6f 72 20 73 74 61 74 color color stat
b890: 75 73 29 29 29 29 0a 09 28 73 3a 74 72 20 28 73 us))))..(s:tr (s
b8a0: 3a 74 64 20 22 54 65 73 74 44 61 74 65 22 29 20 :td "TestDate")
b8b0: 28 73 3a 74 64 20 28 73 65 63 6f 6e 64 73 2d 3e (s:td (seconds->
b8c0: 77 6f 72 6b 2d 77 65 65 6b 2f 64 61 79 2d 74 69 work-week/day-ti
b8d0: 6d 65 20 0a 09 09 09 09 20 20 20 20 20 20 20 28 me ..... (
b8e0: 64 62 3a 74 65 73 74 2d 67 65 74 2d 65 76 65 6e db:test-get-even
b8f0: 74 5f 74 69 6d 65 20 74 65 73 74 2d 64 61 74 29 t_time test-dat)
b900: 29 29 0a 09 20 20 20 20 20 20 28 73 3a 74 64 20 )).. (s:td
b910: 22 44 75 72 61 74 69 6f 6e 22 29 20 28 73 3a 74 "Duration") (s:t
b920: 64 20 28 73 65 63 6f 6e 64 73 2d 3e 68 72 2d 6d d (seconds->hr-m
b930: 69 6e 2d 73 65 63 20 28 64 62 3a 74 65 73 74 2d in-sec (db:test-
b940: 67 65 74 2d 72 75 6e 5f 64 75 72 61 74 69 6f 6e get-run_duration
b950: 20 74 65 73 74 2d 64 61 74 29 29 29 29 29 0a 20 test-dat))))).
b960: 20 20 20 20 20 20 28 73 3a 68 33 20 22 4c 6f 67 (s:h3 "Log
b970: 20 66 69 6c 65 73 22 29 0a 20 20 20 20 20 20 20 files").
b980: 28 73 3a 74 61 62 6c 65 0a 09 27 63 65 6c 6c 73 (s:table..'cells
b990: 70 61 63 69 6e 67 20 22 30 22 20 27 62 6f 72 64 pacing "0" 'bord
b9a0: 65 72 20 22 31 22 0a 09 28 73 3a 74 72 20 28 73 er "1"..(s:tr (s
b9b0: 3a 74 64 20 22 46 69 6e 61 6c 20 6c 6f 67 22 29 :td "Final log")
b9c0: 28 73 3a 74 64 20 28 73 3a 61 20 27 68 72 65 66 (s:td (s:a 'href
b9d0: 20 6c 6f 67 66 20 6c 6f 67 66 29 29 29 29 0a 20 logf logf)))).
b9e0: 20 20 20 20 20 20 28 73 3a 74 61 62 6c 65 0a 09 (s:table..
b9f0: 27 63 65 6c 6c 73 70 61 63 69 6e 67 20 22 30 22 'cellspacing "0"
ba00: 20 27 62 6f 72 64 65 72 20 22 31 22 0a 09 28 73 'border "1"..(s
ba10: 3a 74 72 20 28 73 3a 74 64 20 22 53 74 65 70 20 :tr (s:td "Step
ba20: 4e 61 6d 65 22 29 28 73 3a 74 64 20 22 53 74 61 Name")(s:td "Sta
ba30: 72 74 22 29 28 73 3a 74 64 20 22 45 6e 64 22 29 rt")(s:td "End")
ba40: 28 73 3a 74 64 20 22 53 74 61 74 75 73 22 29 28 (s:td "Status")(
ba50: 73 3a 74 64 20 22 44 75 72 61 74 69 6f 6e 22 29 s:td "Duration")
ba60: 28 73 3a 74 64 20 22 4c 6f 67 20 46 69 6c 65 22 (s:td "Log File"
ba70: 29 29 0a 09 28 6d 61 70 20 28 6c 61 6d 62 64 61 ))..(map (lambda
ba80: 20 28 73 74 65 70 2d 64 61 74 29 0a 09 20 20 20 (step-dat)..
ba90: 20 20 20 20 28 73 3a 74 72 20 28 73 3a 74 64 20 (s:tr (s:td
baa0: 28 74 64 62 3a 73 74 65 70 73 2d 74 61 62 6c 65 (tdb:steps-table
bab0: 2d 67 65 74 2d 73 74 65 70 6e 61 6d 65 20 73 74 -get-stepname st
bac0: 65 70 2d 64 61 74 29 29 0a 09 09 20 20 20 20 20 ep-dat))...
bad0: 28 73 3a 74 64 20 28 74 64 62 3a 73 74 65 70 73 (s:td (tdb:steps
bae0: 2d 74 61 62 6c 65 2d 67 65 74 2d 73 74 61 72 74 -table-get-start
baf0: 20 20 20 20 73 74 65 70 2d 64 61 74 29 29 0a 09 step-dat))..
bb00: 09 20 20 20 20 20 28 73 3a 74 64 20 28 74 64 62 . (s:td (tdb
bb10: 3a 73 74 65 70 73 2d 74 61 62 6c 65 2d 67 65 74 :steps-table-get
bb20: 2d 65 6e 64 20 20 20 20 20 20 73 74 65 70 2d 64 -end step-d
bb30: 61 74 29 29 0a 09 09 20 20 20 20 20 28 73 3a 74 at))... (s:t
bb40: 64 20 28 74 64 62 3a 73 74 65 70 73 2d 74 61 62 d (tdb:steps-tab
bb50: 6c 65 2d 67 65 74 2d 73 74 61 74 75 73 20 20 20 le-get-status
bb60: 73 74 65 70 2d 64 61 74 29 29 0a 09 09 20 20 20 step-dat))...
bb70: 20 20 28 73 3a 74 64 20 28 74 64 62 3a 73 74 65 (s:td (tdb:ste
bb80: 70 73 2d 74 61 62 6c 65 2d 67 65 74 2d 72 75 6e ps-table-get-run
bb90: 74 69 6d 65 20 20 73 74 65 70 2d 64 61 74 29 29 time step-dat))
bba0: 0a 09 09 20 20 20 20 20 28 73 3a 74 64 20 28 6c ... (s:td (l
bbb0: 65 74 20 28 28 73 74 65 70 2d 6c 6f 67 20 28 74 et ((step-log (t
bbc0: 64 62 3a 73 74 65 70 73 2d 74 61 62 6c 65 2d 67 db:steps-table-g
bbd0: 65 74 2d 6c 6f 67 2d 66 69 6c 65 20 73 74 65 70 et-log-file step
bbe0: 2d 64 61 74 29 29 29 0a 09 09 09 20 20 20 20 20 -dat)))....
bbf0: 28 73 3a 61 20 27 68 72 65 66 20 73 74 65 70 2d (s:a 'href step-
bc00: 6c 6f 67 20 73 74 65 70 2d 6c 6f 67 29 29 29 29 log step-log))))
bc10: 29 0a 09 20 20 20 20 20 73 74 65 70 73 2d 64 61 ).. steps-da
bc20: 74 29 29 0a 09 29 29 29 0a 20 20 20 20 28 63 6c t))..))). (cl
bc30: 6f 73 65 2d 6f 75 74 70 75 74 2d 70 6f 72 74 20 ose-output-port
bc40: 6f 75 70 29 29 29 0a 09 20 20 0a 09 20 20 0a 3b oup))).. .. .;
bc50: 3b 20 4d 55 53 54 20 42 45 20 43 41 4c 4c 45 44 ; MUST BE CALLED
bc60: 20 6c 6f 63 61 6c 21 0a 3b 3b 0a 28 64 65 66 69 local!.;;.(defi
bc70: 6e 65 20 28 74 65 73 74 73 3a 74 65 73 74 2d 67 ne (tests:test-g
bc80: 65 74 2d 70 61 74 68 73 2d 6d 61 74 63 68 69 6e et-paths-matchin
bc90: 67 20 6b 65 79 6e 61 6d 65 73 20 74 61 72 67 65 g keynames targe
bca0: 74 20 66 6e 61 6d 65 70 61 74 74 20 23 21 6b 65 t fnamepatt #!ke
bcb0: 79 20 28 72 65 73 20 27 28 29 29 29 0a 20 20 3b y (res '())). ;
bcc0: 3b 20 42 55 47 3a 20 4d 6f 76 65 20 74 68 65 20 ; BUG: Move the
bcd0: 76 61 6c 75 65 73 20 64 65 72 69 76 65 64 20 66 values derived f
bce0: 72 6f 6d 20 61 72 67 73 20 74 6f 20 70 61 72 61 rom args to para
bcf0: 6d 65 74 65 72 73 20 61 6e 64 20 70 75 73 68 20 meters and push
bd00: 74 6f 20 6d 65 67 61 74 65 73 74 2e 73 63 6d 0a to megatest.scm.
bd10: 20 20 28 6c 65 74 2a 20 28 28 74 65 73 74 70 61 (let* ((testpa
bd20: 74 74 20 20 20 28 6f 72 20 28 61 72 67 73 3a 67 tt (or (args:g
bd30: 65 74 2d 61 72 67 20 22 2d 74 65 73 74 70 61 74 et-arg "-testpat
bd40: 74 22 29 28 61 72 67 73 3a 67 65 74 2d 61 72 67 t")(args:get-arg
bd50: 20 22 2d 74 65 73 74 70 61 74 74 22 29 20 22 25 "-testpatt") "%
bd60: 22 29 29 0a 09 20 28 73 74 61 74 65 70 61 74 74 ")).. (statepatt
bd70: 20 20 28 6f 72 20 28 61 72 67 73 3a 67 65 74 2d (or (args:get-
bd80: 61 72 67 20 22 2d 73 74 61 74 65 22 29 20 20 20 arg "-state")
bd90: 28 61 72 67 73 3a 67 65 74 2d 61 72 67 20 22 3a (args:get-arg ":
bda0: 73 74 61 74 65 22 29 20 20 20 20 22 25 22 29 29 state") "%"))
bdb0: 0a 09 20 28 73 74 61 74 75 73 70 61 74 74 20 28 .. (statuspatt (
bdc0: 6f 72 20 28 61 72 67 73 3a 67 65 74 2d 61 72 67 or (args:get-arg
bdd0: 20 22 2d 73 74 61 74 75 73 22 29 20 20 28 61 72 "-status") (ar
bde0: 67 73 3a 67 65 74 2d 61 72 67 20 22 3a 73 74 61 gs:get-arg ":sta
bdf0: 74 75 73 22 29 20 20 20 22 25 22 29 29 0a 09 20 tus") "%"))..
be00: 28 72 75 6e 6e 61 6d 65 20 20 20 20 28 6f 72 20 (runname (or
be10: 28 61 72 67 73 3a 67 65 74 2d 61 72 67 20 22 2d (args:get-arg "-
be20: 72 75 6e 6e 61 6d 65 22 29 20 28 61 72 67 73 3a runname") (args:
be30: 67 65 74 2d 61 72 67 20 22 3a 72 75 6e 6e 61 6d get-arg ":runnam
be40: 65 22 29 20 20 22 25 22 29 29 0a 09 20 28 70 61 e") "%")).. (pa
be50: 74 68 73 2d 66 72 6f 6d 2d 64 62 20 28 72 6d 74 ths-from-db (rmt
be60: 3a 74 65 73 74 2d 67 65 74 2d 70 61 74 68 73 2d :test-get-paths-
be70: 6d 61 74 63 68 69 6e 67 2d 6b 65 79 6e 61 6d 65 matching-keyname
be80: 73 2d 74 61 72 67 65 74 2d 6e 65 77 20 6b 65 79 s-target-new key
be90: 6e 61 6d 65 73 20 74 61 72 67 65 74 20 72 65 73 names target res
bea0: 0a 09 09 09 09 09 74 65 73 74 70 61 74 74 0a 09 ......testpatt..
beb0: 09 09 09 09 73 74 61 74 65 70 61 74 74 0a 09 09 ....statepatt...
bec0: 09 09 09 73 74 61 74 75 73 70 61 74 74 0a 09 09 ...statuspatt...
bed0: 09 09 09 72 75 6e 6e 61 6d 65 29 29 29 0a 20 20 ...runname))).
bee0: 20 20 28 69 66 20 66 6e 61 6d 65 70 61 74 74 0a (if fnamepatt.
bef0: 09 28 61 70 70 6c 79 20 61 70 70 65 6e 64 20 0a .(apply append .
bf00: 09 20 20 20 20 20 20 20 28 6d 61 70 20 28 6c 61 . (map (la
bf10: 6d 62 64 61 20 28 70 29 0a 09 09 20 20 20 20 20 mbda (p)...
bf20: 20 28 69 66 20 28 64 69 72 65 63 74 6f 72 79 2d (if (directory-
bf30: 65 78 69 73 74 73 3f 20 70 29 0a 09 09 09 20 20 exists? p)....
bf40: 28 6c 65 74 20 28 28 67 6c 6f 62 2d 71 75 65 72 (let ((glob-quer
bf50: 79 20 28 63 6f 6e 63 20 70 20 22 2f 22 20 66 6e y (conc p "/" fn
bf60: 61 6d 65 70 61 74 74 29 29 29 0a 09 09 09 20 20 amepatt)))....
bf70: 20 20 28 68 61 6e 64 6c 65 2d 65 78 63 65 70 74 (handle-except
bf80: 69 6f 6e 73 0a 09 09 09 09 65 78 6e 0a 09 09 09 ions.....exn....
bf90: 09 28 77 69 74 68 2d 69 6e 70 75 74 2d 66 72 6f .(with-input-fro
bfa0: 6d 2d 70 69 70 65 0a 09 09 09 09 20 20 20 20 28 m-pipe..... (
bfb0: 63 6f 6e 63 20 22 65 63 68 6f 20 22 20 67 6c 6f conc "echo " glo
bfc0: 62 2d 71 75 65 72 79 29 0a 09 09 09 09 20 20 72 b-query)..... r
bfd0: 65 61 64 2d 6c 69 6e 65 73 29 20 20 3b 3b 20 77 ead-lines) ;; w
bfe0: 65 20 61 72 65 6e 27 74 20 67 6f 69 6e 67 20 74 e aren't going t
bff0: 6f 20 74 72 79 20 74 6f 6f 20 68 61 72 64 2e 20 o try too hard.
c000: 49 66 20 67 6c 6f 62 20 62 72 65 61 6b 73 20 69 If glob breaks i
c010: 74 20 69 73 20 6c 69 6b 65 6c 79 20 62 65 63 61 t is likely beca
c020: 75 73 65 20 73 6f 6d 65 6f 6e 65 20 74 72 69 65 use someone trie
c030: 64 20 74 6f 20 64 6f 20 2a 2f 2a 2f 2a 2e 6c 6f d to do */*/*.lo
c040: 67 20 6f 72 20 73 69 6d 69 6c 61 72 0a 09 09 09 g or similar....
c050: 20 20 20 20 20 20 28 67 6c 6f 62 20 67 6c 6f 62 (glob glob
c060: 2d 71 75 65 72 79 29 29 29 0a 09 09 09 20 20 27 -query))).... '
c070: 28 29 29 29 0a 09 09 20 20 20 20 70 61 74 68 73 ()))... paths
c080: 2d 66 72 6f 6d 2d 64 62 29 29 0a 09 70 61 74 68 -from-db))..path
c090: 73 2d 66 72 6f 6d 2d 64 62 29 29 29 0a 0a 09 09 s-from-db)))....
c0a0: 09 20 20 20 20 20 20 0a 3b 3b 3d 3d 3d 3d 3d 3d . .;;======
c0b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
c0c0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
c0d0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
c0e0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
c0f0: 0a 3b 3b 20 47 61 74 68 65 72 20 64 61 74 61 20 .;; Gather data
c100: 66 72 6f 6d 20 74 65 73 74 2f 74 61 73 6b 20 73 from test/task s
c110: 70 65 63 69 66 69 63 61 74 69 6f 6e 73 0a 3b 3b pecifications.;;
c120: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
c130: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
c140: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
c150: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
c160: 3d 3d 3d 3d 3d 3d 0a 0a 3b 3b 20 28 64 65 66 69 ======..;; (defi
c170: 6e 65 20 28 74 65 73 74 73 3a 67 65 74 2d 76 61 ne (tests:get-va
c180: 6c 69 64 2d 74 65 73 74 73 20 74 65 73 74 73 64 lid-tests testsd
c190: 69 72 20 74 65 73 74 2d 70 61 74 74 73 29 20 3b ir test-patts) ;
c1a0: 3b 20 20 23 21 6b 65 79 20 28 74 65 73 74 2d 6e ; #!key (test-n
c1b0: 61 6d 65 73 20 27 28 29 29 29 0a 3b 3b 20 20 20 ames '())).;;
c1c0: 28 6c 65 74 20 28 28 74 65 73 74 73 20 28 67 6c (let ((tests (gl
c1d0: 6f 62 20 28 63 6f 6e 63 20 74 65 73 74 73 64 69 ob (conc testsdi
c1e0: 72 20 22 2f 74 65 73 74 73 2f 2a 22 29 29 29 29 r "/tests/*"))))
c1f0: 20 3b 3b 20 22 20 28 73 74 72 69 6e 67 2d 74 72 ;; " (string-tr
c200: 61 6e 73 6c 61 74 65 20 70 61 74 74 20 22 25 22 anslate patt "%"
c210: 20 22 2a 22 29 29 29 29 29 0a 3b 3b 20 20 20 20 "*"))))).;;
c220: 20 28 73 65 74 21 20 74 65 73 74 73 20 28 66 69 (set! tests (fi
c230: 6c 74 65 72 20 28 6c 61 6d 62 64 61 20 28 74 65 lter (lambda (te
c240: 73 74 29 28 66 69 6c 65 2d 65 78 69 73 74 73 3f st)(file-exists?
c250: 20 28 63 6f 6e 63 20 74 65 73 74 20 22 2f 74 65 (conc test "/te
c260: 73 74 63 6f 6e 66 69 67 22 29 29 29 20 74 65 73 stconfig"))) tes
c270: 74 73 29 29 0a 3b 3b 20 20 20 20 20 28 64 65 6c ts)).;; (del
c280: 65 74 65 2d 64 75 70 6c 69 63 61 74 65 73 0a 3b ete-duplicates.;
c290: 3b 20 20 20 20 20 20 28 66 69 6c 74 65 72 20 28 ; (filter (
c2a0: 6c 61 6d 62 64 61 20 28 74 65 73 74 6e 61 6d 65 lambda (testname
c2b0: 29 0a 3b 3b 20 09 20 20 20 20 20 20 20 28 74 65 ).;; . (te
c2c0: 73 74 73 3a 6d 61 74 63 68 20 74 65 73 74 2d 70 sts:match test-p
c2d0: 61 74 74 73 20 74 65 73 74 6e 61 6d 65 20 23 66 atts testname #f
c2e0: 29 29 0a 3b 3b 20 09 20 20 20 20 20 28 6d 61 70 )).;; . (map
c2f0: 20 28 6c 61 6d 62 64 61 20 28 74 65 73 74 70 29 (lambda (testp)
c300: 0a 3b 3b 20 09 09 20 20 20 20 28 6c 61 73 74 20 .;; .. (last
c310: 28 73 74 72 69 6e 67 2d 73 70 6c 69 74 20 74 65 (string-split te
c320: 73 74 70 20 22 2f 22 29 29 29 0a 3b 3b 20 09 09 stp "/"))).;; ..
c330: 20 20 74 65 73 74 73 29 29 29 29 29 0a 0a 28 64 tests)))))..(d
c340: 65 66 69 6e 65 20 28 74 65 73 74 73 3a 67 65 74 efine (tests:get
c350: 2d 74 65 73 74 2d 70 61 74 68 2d 66 72 6f 6d 2d -test-path-from-
c360: 65 6e 76 69 72 6f 6e 6d 65 6e 74 29 0a 20 20 28 environment). (
c370: 69 66 20 28 61 6e 64 20 28 67 65 74 65 6e 76 20 if (and (getenv
c380: 22 4d 54 5f 4c 49 4e 4b 54 52 45 45 22 29 0a 09 "MT_LINKTREE")..
c390: 20 20 20 28 67 65 74 65 6e 76 20 22 4d 54 5f 54 (getenv "MT_T
c3a0: 41 52 47 45 54 22 29 0a 09 20 20 20 28 67 65 74 ARGET").. (get
c3b0: 65 6e 76 20 22 4d 54 5f 52 55 4e 4e 41 4d 45 22 env "MT_RUNNAME"
c3c0: 29 0a 09 20 20 20 28 67 65 74 65 6e 76 20 22 4d ).. (getenv "M
c3d0: 54 5f 54 45 53 54 5f 4e 41 4d 45 22 29 0a 09 20 T_TEST_NAME")..
c3e0: 20 20 28 67 65 74 65 6e 76 20 22 4d 54 5f 49 54 (getenv "MT_IT
c3f0: 45 4d 50 41 54 48 22 29 29 0a 20 20 20 20 20 20 EMPATH")).
c400: 28 63 6f 6e 63 20 28 67 65 74 65 6e 76 20 22 4d (conc (getenv "M
c410: 54 5f 4c 49 4e 4b 54 52 45 45 22 29 20 20 22 2f T_LINKTREE") "/
c420: 22 0a 09 20 20 20 20 28 67 65 74 65 6e 76 20 22 ".. (getenv "
c430: 4d 54 5f 54 41 52 47 45 54 22 29 20 20 20 20 22 MT_TARGET") "
c440: 2f 22 0a 09 20 20 20 20 28 67 65 74 65 6e 76 20 /".. (getenv
c450: 22 4d 54 5f 52 55 4e 4e 41 4d 45 22 29 20 20 20 "MT_RUNNAME")
c460: 22 2f 22 0a 09 20 20 20 20 28 67 65 74 65 6e 76 "/".. (getenv
c470: 20 22 4d 54 5f 54 45 53 54 5f 4e 41 4d 45 22 29 "MT_TEST_NAME")
c480: 20 22 2f 22 0a 09 20 20 20 20 28 69 66 20 28 6f "/".. (if (o
c490: 72 20 28 67 65 74 65 6e 76 20 22 4d 54 5f 49 54 r (getenv "MT_IT
c4a0: 45 4d 50 41 54 48 22 29 0a 09 09 20 20 20 20 28 EMPATH")... (
c4b0: 6e 6f 74 20 28 73 74 72 69 6e 67 3d 3f 20 22 22 not (string=? ""
c4c0: 20 28 67 65 74 65 6e 76 20 22 4d 54 5f 49 54 45 (getenv "MT_ITE
c4d0: 4d 50 41 54 48 22 29 29 29 29 0a 09 09 28 63 6f MPATH"))))...(co
c4e0: 6e 63 20 22 2f 22 20 28 67 65 74 65 6e 76 20 22 nc "/" (getenv "
c4f0: 4d 54 5f 49 54 45 4d 50 41 54 48 22 29 29 29 29 MT_ITEMPATH"))))
c500: 0a 20 20 20 20 20 20 23 66 29 29 0a 0a 3b 3b 20 . #f))..;;
c510: 69 66 20 2e 74 65 73 74 63 6f 6e 66 69 67 20 65 if .testconfig e
c520: 78 69 73 74 73 20 69 6e 20 74 65 73 74 20 64 69 xists in test di
c530: 72 65 63 74 6f 72 79 20 72 65 61 64 20 61 6e 64 rectory read and
c540: 20 72 65 74 75 72 6e 20 69 74 0a 3b 3b 20 65 6c return it.;; el
c550: 73 65 20 69 66 20 68 61 76 65 20 63 61 63 68 65 se if have cache
c560: 64 20 63 6f 70 79 20 69 6e 20 2a 74 65 73 74 63 d copy in *testc
c570: 6f 6e 66 69 67 73 2a 20 72 65 74 75 72 6e 20 69 onfigs* return i
c580: 74 20 49 46 46 20 74 68 65 72 65 20 69 73 20 61 t IFF there is a
c590: 20 73 65 63 74 69 6f 6e 20 22 68 61 76 65 20 66 section "have f
c5a0: 75 6c 6c 64 61 74 61 22 0a 3b 3b 20 65 6c 73 65 ulldata".;; else
c5b0: 20 72 65 61 64 20 74 68 65 20 74 65 73 74 63 6f read the testco
c5c0: 6e 66 69 67 20 66 69 6c 65 0a 3b 3b 20 20 20 69 nfig file.;; i
c5d0: 66 20 68 61 76 65 20 70 61 74 68 20 74 6f 20 74 f have path to t
c5e0: 65 73 74 20 64 69 72 65 63 74 6f 72 79 20 73 61 est directory sa
c5f0: 76 65 20 74 68 65 20 63 6f 6e 66 69 67 20 61 73 ve the config as
c600: 20 2e 74 65 73 74 63 6f 6e 66 69 67 20 61 6e 64 .testconfig and
c610: 20 72 65 74 75 72 6e 20 69 74 0a 3b 3b 0a 28 64 return it.;;.(d
c620: 65 66 69 6e 65 20 28 74 65 73 74 73 3a 67 65 74 efine (tests:get
c630: 2d 74 65 73 74 63 6f 6e 66 69 67 20 74 65 73 74 -testconfig test
c640: 2d 6e 61 6d 65 20 69 74 65 6d 2d 70 61 74 68 20 -name item-path
c650: 74 65 73 74 2d 72 65 67 69 73 74 72 79 20 73 79 test-registry sy
c660: 73 74 65 6d 2d 61 6c 6c 6f 77 65 64 20 23 21 6b stem-allowed #!k
c670: 65 79 20 28 66 6f 72 63 65 2d 63 72 65 61 74 65 ey (force-create
c680: 20 23 66 29 29 0a 20 20 28 6c 65 74 2a 20 28 28 #f)). (let* ((
c690: 63 61 63 68 65 2d 70 61 74 68 20 20 20 28 74 65 cache-path (te
c6a0: 73 74 73 3a 67 65 74 2d 74 65 73 74 2d 70 61 74 sts:get-test-pat
c6b0: 68 2d 66 72 6f 6d 2d 65 6e 76 69 72 6f 6e 6d 65 h-from-environme
c6c0: 6e 74 29 29 0a 09 20 28 63 61 63 68 65 2d 66 69 nt)).. (cache-fi
c6d0: 6c 65 20 20 20 28 61 6e 64 20 63 61 63 68 65 2d le (and cache-
c6e0: 70 61 74 68 20 28 63 6f 6e 63 20 63 61 63 68 65 path (conc cache
c6f0: 2d 70 61 74 68 20 22 2f 2e 74 65 73 74 63 6f 6e -path "/.testcon
c700: 66 69 67 22 29 29 29 0a 09 20 28 63 61 63 68 65 fig"))).. (cache
c710: 2d 65 78 69 73 74 73 20 28 61 6e 64 20 63 61 63 -exists (and cac
c720: 68 65 2d 66 69 6c 65 0a 09 09 09 20 20 20 20 28 he-file.... (
c730: 6e 6f 74 20 66 6f 72 63 65 2d 63 72 65 61 74 65 not force-create
c740: 29 20 20 3b 3b 20 69 66 20 66 6f 72 63 65 2d 63 ) ;; if force-c
c750: 72 65 61 74 65 20 74 68 65 6e 20 70 72 65 74 65 reate then prete
c760: 6e 64 20 74 68 65 72 65 20 69 73 20 6e 6f 20 63 nd there is no c
c770: 61 63 68 65 20 74 6f 20 72 65 61 64 0a 09 09 09 ache to read....
c780: 20 20 20 20 28 66 69 6c 65 2d 65 78 69 73 74 73 (file-exists
c790: 3f 20 63 61 63 68 65 2d 66 69 6c 65 29 29 29 0a ? cache-file))).
c7a0: 09 20 28 63 61 63 68 65 64 2d 64 61 74 20 20 20 . (cached-dat
c7b0: 28 69 66 20 28 61 6e 64 20 28 6e 6f 74 20 66 6f (if (and (not fo
c7c0: 72 63 65 2d 63 72 65 61 74 65 29 0a 09 09 09 09 rce-create).....
c7d0: 63 61 63 68 65 2d 65 78 69 73 74 73 29 0a 09 09 cache-exists)...
c7e0: 09 20 20 20 28 68 61 6e 64 6c 65 2d 65 78 63 65 . (handle-exce
c7f0: 70 74 69 6f 6e 73 0a 09 09 09 20 20 20 20 65 78 ptions.... ex
c800: 6e 0a 09 09 09 20 20 20 20 23 66 20 3b 3b 20 61 n.... #f ;; a
c810: 6e 79 20 69 73 73 75 65 73 2c 20 6a 75 73 74 20 ny issues, just
c820: 67 69 76 65 20 75 70 20 77 69 74 68 20 74 68 65 give up with the
c830: 20 63 61 63 68 65 64 20 76 65 72 73 69 6f 6e 20 cached version
c840: 61 6e 64 20 72 65 2d 72 65 61 64 0a 09 09 09 20 and re-read....
c850: 20 20 20 28 63 6f 6e 66 69 67 66 3a 72 65 61 64 (configf:read
c860: 2d 61 6c 69 73 74 20 63 61 63 68 65 2d 66 69 6c -alist cache-fil
c870: 65 29 29 0a 09 09 09 20 20 20 23 66 29 29 0a 20 e)).... #f)).
c880: 20 20 20 20 20 20 20 20 28 74 65 73 74 2d 66 75 (test-fu
c890: 6c 6c 2d 6e 61 6d 65 20 28 69 66 20 28 61 6e 64 ll-name (if (and
c8a0: 20 69 74 65 6d 2d 70 61 74 68 20 28 6e 6f 74 20 item-path (not
c8b0: 28 73 74 72 69 6e 67 2d 6e 75 6c 6c 3f 20 69 74 (string-null? it
c8c0: 65 6d 2d 70 61 74 68 29 29 29 0a 20 20 20 20 20 em-path))).
c8d0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
c8e0: 20 20 20 20 20 20 20 20 28 63 6f 6e 63 20 74 65 (conc te
c8f0: 73 74 2d 6e 61 6d 65 20 22 2f 22 20 69 74 65 6d st-name "/" item
c900: 2d 70 61 74 68 29 0a 20 20 20 20 20 20 20 20 20 -path).
c910: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
c920: 20 20 20 20 74 65 73 74 2d 6e 61 6d 65 29 29 29 test-name)))
c930: 0a 20 20 20 20 28 69 66 20 63 61 63 68 65 64 2d . (if cached-
c940: 64 61 74 0a 09 63 61 63 68 65 64 2d 64 61 74 0a dat..cached-dat.
c950: 09 28 6c 65 74 20 28 28 64 61 74 20 28 68 61 73 .(let ((dat (has
c960: 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 h-table-ref/defa
c970: 75 6c 74 20 2a 74 65 73 74 63 6f 6e 66 69 67 73 ult *testconfigs
c980: 2a 20 74 65 73 74 2d 66 75 6c 6c 2d 6e 61 6d 65 * test-full-name
c990: 20 23 66 29 29 29 0a 09 20 20 28 69 66 20 28 61 #f))).. (if (a
c9a0: 6e 64 20 20 64 61 74 20 3b 3b 20 68 61 76 65 20 nd dat ;; have
c9b0: 61 20 6c 6f 63 61 6c 6c 79 20 63 61 63 68 65 64 a locally cached
c9c0: 20 76 65 72 73 69 6f 6e 0a 09 09 20 20 20 20 28 version... (
c9d0: 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 hash-table-ref/d
c9e0: 65 66 61 75 6c 74 20 64 61 74 20 22 68 61 76 65 efault dat "have
c9f0: 20 66 75 6c 6c 64 61 74 61 22 20 23 66 29 29 20 fulldata" #f))
ca00: 3b 3b 20 6d 61 72 6b 65 64 20 61 73 20 67 6f 6f ;; marked as goo
ca10: 64 20 64 61 74 61 3f 0a 09 20 20 20 20 20 20 64 d data?.. d
ca20: 61 74 0a 09 20 20 20 20 20 20 3b 3b 20 6e 6f 20 at.. ;; no
ca30: 63 61 63 68 65 64 20 64 61 74 61 20 61 76 61 69 cached data avai
ca40: 6c 61 62 6c 65 0a 09 20 20 20 20 20 20 28 6c 65 lable.. (le
ca50: 74 2a 20 28 28 74 72 65 67 20 20 20 20 20 20 20 t* ((treg
ca60: 20 20 28 6f 72 20 74 65 73 74 2d 72 65 67 69 73 (or test-regis
ca70: 74 72 79 0a 09 09 09 09 20 20 20 20 20 20 20 28 try..... (
ca80: 74 65 73 74 73 3a 67 65 74 2d 61 6c 6c 29 29 29 tests:get-all)))
ca90: 0a 09 09 20 20 20 20 20 28 74 65 73 74 2d 70 61 ... (test-pa
caa0: 74 68 20 20 20 20 28 6f 72 20 28 68 61 73 68 2d th (or (hash-
cab0: 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c table-ref/defaul
cac0: 74 20 74 72 65 67 20 74 65 73 74 2d 6e 61 6d 65 t treg test-name
cad0: 20 23 66 29 0a 09 09 09 09 20 20 20 20 20 20 20 #f).....
cae0: 28 63 6f 6e 63 20 2a 74 6f 70 70 61 74 68 2a 20 (conc *toppath*
caf0: 22 2f 74 65 73 74 73 2f 22 20 74 65 73 74 2d 6e "/tests/" test-n
cb00: 61 6d 65 29 29 29 0a 09 09 20 20 20 20 20 28 74 ame)))... (t
cb10: 65 73 74 2d 63 6f 6e 66 69 67 66 20 28 63 6f 6e est-configf (con
cb20: 63 20 74 65 73 74 2d 70 61 74 68 20 22 2f 74 65 c test-path "/te
cb30: 73 74 63 6f 6e 66 69 67 22 29 29 0a 09 09 20 20 stconfig"))...
cb40: 20 20 20 28 74 65 73 74 65 78 69 73 74 73 20 20 (testexists
cb50: 20 28 61 6e 64 20 28 66 69 6c 65 2d 65 78 69 73 (and (file-exis
cb60: 74 73 3f 20 74 65 73 74 2d 63 6f 6e 66 69 67 66 ts? test-configf
cb70: 29 28 66 69 6c 65 2d 72 65 61 64 2d 61 63 63 65 )(file-read-acce
cb80: 73 73 3f 20 74 65 73 74 2d 63 6f 6e 66 69 67 66 ss? test-configf
cb90: 29 29 29 0a 09 09 20 20 20 20 20 28 74 63 66 67 )))... (tcfg
cba0: 20 20 20 20 20 20 20 20 20 28 69 66 20 74 65 73 (if tes
cbb0: 74 65 78 69 73 74 73 0a 09 09 09 09 20 20 20 20 texists.....
cbc0: 20 20 20 28 72 65 61 64 2d 63 6f 6e 66 69 67 20 (read-config
cbd0: 74 65 73 74 2d 63 6f 6e 66 69 67 66 20 23 66 20 test-configf #f
cbe0: 73 79 73 74 65 6d 2d 61 6c 6c 6f 77 65 64 0a 09 system-allowed..
cbf0: 09 09 09 09 09 20 20 20 20 65 6e 76 69 72 6f 6e ..... environ
cc00: 2d 70 61 74 74 3a 20 28 69 66 20 73 79 73 74 65 -patt: (if syste
cc10: 6d 2d 61 6c 6c 6f 77 65 64 0a 09 09 09 09 09 09 m-allowed.......
cc20: 09 09 20 20 20 20 20 20 22 70 72 65 2d 6c 61 75 .. "pre-lau
cc30: 6e 63 68 2d 65 6e 76 2d 76 61 72 73 22 0a 09 09 nch-env-vars"...
cc40: 09 09 09 09 09 09 20 20 20 20 20 20 23 66 29 29 ...... #f))
cc50: 0a 09 09 09 09 20 20 20 20 20 20 20 23 66 29 29 ..... #f))
cc60: 29 0a 09 09 28 69 66 20 28 61 6e 64 20 74 63 66 )...(if (and tcf
cc70: 67 20 63 61 63 68 65 2d 66 69 6c 65 29 20 28 68 g cache-file) (h
cc80: 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 74 ash-table-set! t
cc90: 63 66 67 20 22 68 61 76 65 20 66 75 6c 6c 64 61 cfg "have fullda
cca0: 74 61 22 20 23 74 29 29 20 3b 3b 20 6d 61 72 6b ta" #t)) ;; mark
ccb0: 20 74 68 69 73 20 61 73 20 66 75 6c 6c 79 20 72 this as fully r
ccc0: 65 61 64 20 64 61 74 61 0a 09 09 28 69 66 20 74 ead data...(if t
ccd0: 63 66 67 20 28 68 61 73 68 2d 74 61 62 6c 65 2d cfg (hash-table-
cce0: 73 65 74 21 20 2a 74 65 73 74 63 6f 6e 66 69 67 set! *testconfig
ccf0: 73 2a 20 74 65 73 74 2d 66 75 6c 6c 2d 6e 61 6d s* test-full-nam
cd00: 65 20 74 63 66 67 29 29 0a 09 09 28 69 66 20 28 e tcfg))...(if (
cd10: 61 6e 64 20 74 65 73 74 65 78 69 73 74 73 0a 09 and testexists..
cd20: 09 09 20 63 61 63 68 65 2d 66 69 6c 65 0a 09 09 .. cache-file...
cd30: 09 20 28 66 69 6c 65 2d 77 72 69 74 65 2d 61 63 . (file-write-ac
cd40: 63 65 73 73 3f 20 63 61 63 68 65 2d 70 61 74 68 cess? cache-path
cd50: 29 29 0a 09 09 20 20 20 20 28 6c 65 74 20 28 28 ))... (let ((
cd60: 74 70 61 74 68 20 28 63 6f 6e 63 20 63 61 63 68 tpath (conc cach
cd70: 65 2d 70 61 74 68 20 22 2f 2e 74 65 73 74 63 6f e-path "/.testco
cd80: 6e 66 69 67 22 29 29 29 0a 09 09 20 20 20 20 20 nfig")))...
cd90: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e (debug:print-in
cda0: 66 6f 20 31 20 2a 64 65 66 61 75 6c 74 2d 6c 6f fo 1 *default-lo
cdb0: 67 2d 70 6f 72 74 2a 20 22 43 61 63 68 69 6e 67 g-port* "Caching
cdc0: 20 74 65 73 74 63 6f 6e 66 69 67 20 66 6f 72 20 testconfig for
cdd0: 22 20 74 65 73 74 2d 6e 61 6d 65 20 22 20 69 6e " test-name " in
cde0: 20 22 20 74 70 61 74 68 29 0a 09 09 20 20 20 20 " tpath)...
cdf0: 20 20 28 63 6f 6e 66 69 67 66 3a 77 72 69 74 65 (configf:write
ce00: 2d 61 6c 69 73 74 20 74 63 66 67 20 74 70 61 74 -alist tcfg tpat
ce10: 68 29 29 29 0a 09 09 74 63 66 67 29 29 29 29 29 h)))...tcfg)))))
ce20: 29 0a 20 20 0a 3b 3b 20 73 6f 72 74 20 74 65 73 ). .;; sort tes
ce30: 74 73 20 62 79 20 70 72 69 6f 72 69 74 79 20 61 ts by priority a
ce40: 6e 64 20 77 61 69 74 6f 6e 0a 3b 3b 20 4d 6f 76 nd waiton.;; Mov
ce50: 65 20 74 65 73 74 20 73 70 65 63 69 66 69 63 20 e test specific
ce60: 73 74 75 66 66 20 74 6f 20 61 20 74 65 73 74 20 stuff to a test
ce70: 75 6e 69 74 20 46 49 58 4d 45 20 6f 6e 65 20 6f unit FIXME one o
ce80: 66 20 74 68 65 73 65 20 64 61 79 73 0a 28 64 65 f these days.(de
ce90: 66 69 6e 65 20 28 74 65 73 74 73 3a 73 6f 72 74 fine (tests:sort
cea0: 2d 62 79 2d 70 72 69 6f 72 69 74 79 2d 61 6e 64 -by-priority-and
ceb0: 2d 77 61 69 74 6f 6e 20 74 65 73 74 2d 72 65 63 -waiton test-rec
cec0: 6f 72 64 73 29 0a 20 20 28 69 66 20 28 65 71 3f ords). (if (eq?
ced0: 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 73 69 7a (hash-table-siz
cee0: 65 20 74 65 73 74 2d 72 65 63 6f 72 64 73 29 20 e test-records)
cef0: 30 29 0a 20 20 20 20 20 20 27 28 29 0a 20 20 20 0). '().
cf00: 20 20 20 28 6c 65 74 2a 20 28 28 6d 75 6e 67 65 (let* ((munge
cf10: 70 72 69 6f 72 69 74 79 20 28 6c 61 6d 62 64 61 priority (lambda
cf20: 20 28 70 72 69 6f 72 69 74 79 29 0a 09 09 09 20 (priority)....
cf30: 20 20 20 20 20 28 69 66 20 70 72 69 6f 72 69 74 (if priorit
cf40: 79 0a 09 09 09 09 20 20 28 6c 65 74 20 28 28 74 y..... (let ((t
cf50: 6d 70 20 28 61 6e 79 2d 3e 6e 75 6d 62 65 72 20 mp (any->number
cf60: 70 72 69 6f 72 69 74 79 29 29 29 0a 09 09 09 09 priority))).....
cf70: 20 20 20 20 28 69 66 20 74 6d 70 20 74 6d 70 20 (if tmp tmp
cf80: 28 62 65 67 69 6e 20 28 64 65 62 75 67 3a 70 72 (begin (debug:pr
cf90: 69 6e 74 2d 65 72 72 6f 72 20 30 20 2a 64 65 66 int-error 0 *def
cfa0: 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 ault-log-port* "
cfb0: 62 61 64 20 70 72 69 6f 72 69 74 79 20 76 61 6c bad priority val
cfc0: 75 65 20 22 20 70 72 69 6f 72 69 74 79 20 22 2c ue " priority ",
cfd0: 20 75 73 69 6e 67 20 30 22 29 20 30 29 29 29 0a using 0") 0))).
cfe0: 09 09 09 09 20 20 30 29 29 29 0a 09 20 20 20 20 .... 0)))..
cff0: 20 28 61 6c 6c 2d 74 65 73 74 73 20 20 20 20 20 (all-tests
d000: 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 6b 65 79 (hash-table-key
d010: 73 20 74 65 73 74 2d 72 65 63 6f 72 64 73 29 29 s test-records))
d020: 0a 09 20 20 20 20 20 28 61 6c 6c 2d 77 61 69 74 .. (all-wait
d030: 65 64 2d 6f 6e 20 20 28 6c 65 74 20 6c 6f 6f 70 ed-on (let loop
d040: 20 28 28 68 65 64 20 28 63 61 72 20 61 6c 6c 2d ((hed (car all-
d050: 74 65 73 74 73 29 29 0a 09 09 09 09 09 28 74 61 tests))......(ta
d060: 6c 20 28 63 64 72 20 61 6c 6c 2d 74 65 73 74 73 l (cdr all-tests
d070: 29 29 0a 09 09 09 09 09 28 72 65 73 20 27 28 29 ))......(res '()
d080: 29 29 0a 09 09 09 20 20 20 20 20 20 20 28 6c 65 )).... (le
d090: 74 2a 20 28 28 74 72 65 63 20 20 20 20 28 68 61 t* ((trec (ha
d0a0: 73 68 2d 74 61 62 6c 65 2d 72 65 66 20 74 65 73 sh-table-ref tes
d0b0: 74 2d 72 65 63 6f 72 64 73 20 68 65 64 29 29 0a t-records hed)).
d0c0: 09 09 09 09 20 20 20 20 20 20 28 77 61 69 74 6f .... (waito
d0d0: 6e 73 20 28 6f 72 20 28 74 65 73 74 73 3a 74 65 ns (or (tests:te
d0e0: 73 74 71 75 65 75 65 2d 67 65 74 2d 77 61 69 74 stqueue-get-wait
d0f0: 6f 6e 73 20 74 72 65 63 29 20 27 28 29 29 29 29 ons trec) '())))
d100: 0a 09 09 09 09 20 28 69 66 20 28 6e 75 6c 6c 3f ..... (if (null?
d110: 20 74 61 6c 29 0a 09 09 09 09 20 20 20 20 20 28 tal)..... (
d120: 61 70 70 65 6e 64 20 72 65 73 20 77 61 69 74 6f append res waito
d130: 6e 73 29 0a 09 09 09 09 20 20 20 20 20 28 6c 6f ns)..... (lo
d140: 6f 70 20 28 63 61 72 20 74 61 6c 29 28 63 64 72 op (car tal)(cdr
d150: 20 74 61 6c 29 28 61 70 70 65 6e 64 20 72 65 73 tal)(append res
d160: 20 77 61 69 74 6f 6e 73 29 29 29 29 29 29 0a 09 waitons))))))..
d170: 20 20 20 20 20 28 73 6f 72 74 2d 66 6e 31 20 0a (sort-fn1 .
d180: 09 20 20 20 20 20 20 28 6c 61 6d 62 64 61 20 28 . (lambda (
d190: 61 20 62 29 0a 09 09 28 6c 65 74 2a 20 28 28 61 a b)...(let* ((a
d1a0: 2d 72 65 63 6f 72 64 20 20 20 28 68 61 73 68 2d -record (hash-
d1b0: 74 61 62 6c 65 2d 72 65 66 20 74 65 73 74 2d 72 table-ref test-r
d1c0: 65 63 6f 72 64 73 20 61 29 29 0a 09 09 20 20 20 ecords a))...
d1d0: 20 20 20 20 28 62 2d 72 65 63 6f 72 64 20 20 20 (b-record
d1e0: 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 20 (hash-table-ref
d1f0: 74 65 73 74 2d 72 65 63 6f 72 64 73 20 62 29 29 test-records b))
d200: 0a 09 09 20 20 20 20 20 20 20 28 61 2d 77 61 69 ... (a-wai
d210: 74 6f 6e 73 20 20 28 6f 72 20 28 74 65 73 74 73 tons (or (tests
d220: 3a 74 65 73 74 71 75 65 75 65 2d 67 65 74 2d 77 :testqueue-get-w
d230: 61 69 74 6f 6e 73 20 61 2d 72 65 63 6f 72 64 29 aitons a-record)
d240: 20 27 28 29 29 29 0a 09 09 20 20 20 20 20 20 20 '()))...
d250: 28 62 2d 77 61 69 74 6f 6e 73 20 20 28 6f 72 20 (b-waitons (or
d260: 28 74 65 73 74 73 3a 74 65 73 74 71 75 65 75 65 (tests:testqueue
d270: 2d 67 65 74 2d 77 61 69 74 6f 6e 73 20 62 2d 72 -get-waitons b-r
d280: 65 63 6f 72 64 29 20 27 28 29 29 29 0a 09 09 20 ecord) '()))...
d290: 20 20 20 20 20 20 28 61 2d 63 6f 6e 66 69 67 20 (a-config
d2a0: 20 20 28 74 65 73 74 73 3a 74 65 73 74 71 75 65 (tests:testque
d2b0: 75 65 2d 67 65 74 2d 74 65 73 74 63 6f 6e 66 69 ue-get-testconfi
d2c0: 67 20 20 61 2d 72 65 63 6f 72 64 29 29 0a 09 09 g a-record))...
d2d0: 20 20 20 20 20 20 20 28 62 2d 63 6f 6e 66 69 67 (b-config
d2e0: 20 20 20 28 74 65 73 74 73 3a 74 65 73 74 71 75 (tests:testqu
d2f0: 65 75 65 2d 67 65 74 2d 74 65 73 74 63 6f 6e 66 eue-get-testconf
d300: 69 67 20 20 62 2d 72 65 63 6f 72 64 29 29 0a 09 ig b-record))..
d310: 09 20 20 20 20 20 20 20 28 61 2d 72 61 77 2d 70 . (a-raw-p
d320: 72 69 20 20 28 63 6f 6e 66 69 67 2d 6c 6f 6f 6b ri (config-look
d330: 75 70 20 61 2d 63 6f 6e 66 69 67 20 22 72 65 71 up a-config "req
d340: 75 69 72 65 6d 65 6e 74 73 22 20 22 70 72 69 6f uirements" "prio
d350: 72 69 74 79 22 29 29 0a 09 09 20 20 20 20 20 20 rity"))...
d360: 20 28 62 2d 72 61 77 2d 70 72 69 20 20 28 63 6f (b-raw-pri (co
d370: 6e 66 69 67 2d 6c 6f 6f 6b 75 70 20 62 2d 63 6f nfig-lookup b-co
d380: 6e 66 69 67 20 22 72 65 71 75 69 72 65 6d 65 6e nfig "requiremen
d390: 74 73 22 20 22 70 72 69 6f 72 69 74 79 22 29 29 ts" "priority"))
d3a0: 0a 09 09 20 20 20 20 20 20 20 28 61 2d 70 72 69 ... (a-pri
d3b0: 6f 72 69 74 79 20 28 6d 75 6e 67 65 70 72 69 6f ority (mungeprio
d3c0: 72 69 74 79 20 61 2d 72 61 77 2d 70 72 69 29 29 rity a-raw-pri))
d3d0: 0a 09 09 20 20 20 20 20 20 20 28 62 2d 70 72 69 ... (b-pri
d3e0: 6f 72 69 74 79 20 28 6d 75 6e 67 65 70 72 69 6f ority (mungeprio
d3f0: 72 69 74 79 20 62 2d 72 61 77 2d 70 72 69 29 29 rity b-raw-pri))
d400: 29 0a 09 09 20 20 28 74 65 73 74 73 3a 74 65 73 )... (tests:tes
d410: 74 71 75 65 75 65 2d 73 65 74 2d 70 72 69 6f 72 tqueue-set-prior
d420: 69 74 79 21 20 61 2d 72 65 63 6f 72 64 20 61 2d ity! a-record a-
d430: 70 72 69 6f 72 69 74 79 29 0a 09 09 20 20 28 74 priority)... (t
d440: 65 73 74 73 3a 74 65 73 74 71 75 65 75 65 2d 73 ests:testqueue-s
d450: 65 74 2d 70 72 69 6f 72 69 74 79 21 20 62 2d 72 et-priority! b-r
d460: 65 63 6f 72 64 20 62 2d 70 72 69 6f 72 69 74 79 ecord b-priority
d470: 29 0a 09 09 20 20 3b 3b 20 28 64 65 62 75 67 3a )... ;; (debug:
d480: 70 72 69 6e 74 20 30 20 2a 64 65 66 61 75 6c 74 print 0 *default
d490: 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 61 3d 22 20 -log-port* "a="
d4a0: 61 20 22 2c 20 62 3d 22 20 62 20 22 2c 20 61 2d a ", b=" b ", a-
d4b0: 77 61 69 74 6f 6e 73 3d 22 20 61 2d 77 61 69 74 waitons=" a-wait
d4c0: 6f 6e 73 20 22 2c 20 62 2d 77 61 69 74 6f 6e 73 ons ", b-waitons
d4d0: 3d 22 20 62 2d 77 61 69 74 6f 6e 73 29 0a 09 09 =" b-waitons)...
d4e0: 20 20 28 63 6f 6e 64 0a 09 09 20 20 20 3b 3b 20 (cond... ;;
d4f0: 69 73 20 0a 09 09 20 20 20 28 28 6d 65 6d 62 65 is ... ((membe
d500: 72 20 61 20 62 2d 77 61 69 74 6f 6e 73 29 20 20 r a b-waitons)
d510: 20 20 20 20 20 20 20 20 3b 3b 20 69 73 20 62 20 ;; is b
d520: 77 61 69 74 69 6e 67 20 6f 6e 20 61 3f 0a 09 09 waiting on a?...
d530: 20 20 20 20 3b 3b 20 28 64 65 62 75 67 3a 70 72 ;; (debug:pr
d540: 69 6e 74 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c int 0 *default-l
d550: 6f 67 2d 70 6f 72 74 2a 20 22 63 61 73 65 31 22 og-port* "case1"
d560: 29 0a 09 09 20 20 20 20 23 74 29 0a 09 09 20 20 )... #t)...
d570: 20 28 28 6d 65 6d 62 65 72 20 62 20 61 2d 77 61 ((member b a-wa
d580: 69 74 6f 6e 73 29 20 20 20 20 20 20 20 20 20 20 itons)
d590: 3b 3b 20 69 73 20 61 20 77 61 69 74 69 6e 67 20 ;; is a waiting
d5a0: 6f 6e 20 62 3f 0a 09 09 20 20 20 20 3b 3b 20 28 on b?... ;; (
d5b0: 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 2a 64 debug:print 0 *d
d5c0: 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a efault-log-port*
d5d0: 20 22 63 61 73 65 32 22 29 0a 09 09 20 20 20 20 "case2")...
d5e0: 23 66 29 0a 09 09 20 20 20 28 28 61 6e 64 20 28 #f)... ((and (
d5f0: 6e 6f 74 20 28 6e 75 6c 6c 3f 20 61 2d 77 61 69 not (null? a-wai
d600: 74 6f 6e 73 29 29 20 20 3b 3b 20 62 6f 74 68 20 tons)) ;; both
d610: 68 61 76 65 20 77 61 69 74 6f 6e 73 20 2d 20 64 have waitons - d
d620: 6f 20 6e 6f 74 20 64 69 73 74 75 72 62 0a 09 09 o not disturb...
d630: 09 20 28 6e 6f 74 20 28 6e 75 6c 6c 3f 20 62 2d . (not (null? b-
d640: 77 61 69 74 6f 6e 73 29 29 29 0a 09 09 20 20 20 waitons)))...
d650: 20 3b 3b 20 28 64 65 62 75 67 3a 70 72 69 6e 74 ;; (debug:print
d660: 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 0 *default-log-
d670: 70 6f 72 74 2a 20 22 63 61 73 65 32 2e 31 22 29 port* "case2.1")
d680: 0a 09 09 20 20 20 20 23 74 29 0a 09 09 20 20 20 ... #t)...
d690: 28 28 61 6e 64 20 28 6e 75 6c 6c 3f 20 61 2d 77 ((and (null? a-w
d6a0: 61 69 74 6f 6e 73 29 20 20 20 20 20 20 20 20 3b aitons) ;
d6b0: 3b 20 6e 6f 20 77 61 69 74 6f 6e 73 20 66 6f 72 ; no waitons for
d6c0: 20 61 20 62 75 74 20 62 20 68 61 73 20 77 61 69 a but b has wai
d6d0: 74 6f 6e 73 0a 09 09 09 20 28 6e 6f 74 20 28 6e tons.... (not (n
d6e0: 75 6c 6c 3f 20 62 2d 77 61 69 74 6f 6e 73 29 29 ull? b-waitons))
d6f0: 29 0a 09 09 20 20 20 20 3b 3b 20 28 64 65 62 75 )... ;; (debu
d700: 67 3a 70 72 69 6e 74 20 30 20 2a 64 65 66 61 75 g:print 0 *defau
d710: 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 63 61 lt-log-port* "ca
d720: 73 65 33 22 29 0a 09 09 20 20 20 20 23 66 29 0a se3")... #f).
d730: 09 09 20 20 20 28 28 61 6e 64 20 28 6e 6f 74 20 .. ((and (not
d740: 28 6e 75 6c 6c 3f 20 61 2d 77 61 69 74 6f 6e 73 (null? a-waitons
d750: 29 29 20 20 3b 3b 20 61 20 68 61 73 20 77 61 69 )) ;; a has wai
d760: 74 6f 6e 73 20 62 75 74 20 62 20 64 6f 65 73 20 tons but b does
d770: 6e 6f 74 0a 09 09 09 20 28 6e 75 6c 6c 3f 20 62 not.... (null? b
d780: 2d 77 61 69 74 6f 6e 73 29 29 20 0a 09 09 20 20 -waitons)) ...
d790: 20 20 3b 3b 20 28 64 65 62 75 67 3a 70 72 69 6e ;; (debug:prin
d7a0: 74 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 t 0 *default-log
d7b0: 2d 70 6f 72 74 2a 20 22 63 61 73 65 34 22 29 0a -port* "case4").
d7c0: 09 09 20 20 20 20 23 74 29 0a 09 09 20 20 20 28 .. #t)... (
d7d0: 28 6e 6f 74 20 28 65 71 3f 20 61 2d 70 72 69 6f (not (eq? a-prio
d7e0: 72 69 74 79 20 62 2d 70 72 69 6f 72 69 74 79 29 rity b-priority)
d7f0: 29 20 3b 3b 20 75 73 65 0a 09 09 20 20 20 20 28 ) ;; use... (
d800: 3e 20 61 2d 70 72 69 6f 72 69 74 79 20 62 2d 70 > a-priority b-p
d810: 72 69 6f 72 69 74 79 29 29 0a 09 09 20 20 20 28 riority))... (
d820: 65 6c 73 65 0a 09 09 20 20 20 20 3b 3b 20 28 64 else... ;; (d
d830: 65 62 75 67 3a 70 72 69 6e 74 20 30 20 2a 64 65 ebug:print 0 *de
d840: 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 fault-log-port*
d850: 22 63 61 73 65 35 22 29 0a 09 09 20 20 20 20 28 "case5")... (
d860: 73 74 72 69 6e 67 3e 3f 20 61 20 62 29 29 29 29 string>? a b))))
d870: 29 29 0a 09 20 20 20 20 20 0a 09 20 20 20 20 20 )).. ..
d880: 28 73 6f 72 74 2d 66 6e 32 0a 09 20 20 20 20 20 (sort-fn2..
d890: 20 28 6c 61 6d 62 64 61 20 28 61 20 62 29 0a 09 (lambda (a b)..
d8a0: 09 28 3e 20 28 6d 75 6e 67 65 70 72 69 6f 72 69 .(> (mungepriori
d8b0: 74 79 20 28 74 65 73 74 73 3a 74 65 73 74 71 75 ty (tests:testqu
d8c0: 65 75 65 2d 67 65 74 2d 70 72 69 6f 72 69 74 79 eue-get-priority
d8d0: 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 (hash-table-ref
d8e0: 20 74 65 73 74 2d 72 65 63 6f 72 64 73 20 61 29 test-records a)
d8f0: 29 29 0a 09 09 20 20 20 28 6d 75 6e 67 65 70 72 ))... (mungepr
d900: 69 6f 72 69 74 79 20 28 74 65 73 74 73 3a 74 65 iority (tests:te
d910: 73 74 71 75 65 75 65 2d 67 65 74 2d 70 72 69 6f stqueue-get-prio
d920: 72 69 74 79 20 28 68 61 73 68 2d 74 61 62 6c 65 rity (hash-table
d930: 2d 72 65 66 20 74 65 73 74 2d 72 65 63 6f 72 64 -ref test-record
d940: 73 20 62 29 29 29 29 29 29 29 0a 09 3b 3b 20 28 s b)))))))..;; (
d950: 6c 65 74 20 28 28 64 6f 74 2d 72 65 73 20 28 74 let ((dot-res (t
d960: 65 73 74 73 3a 72 75 6e 2d 64 6f 74 20 28 74 65 ests:run-dot (te
d970: 73 74 73 3a 74 65 73 74 73 2d 3e 64 6f 74 20 74 sts:tests->dot t
d980: 65 73 74 2d 72 65 63 6f 72 64 73 29 20 22 70 6c est-records) "pl
d990: 61 69 6e 22 29 29 29 0a 09 3b 3b 20 20 20 28 64 ain")))..;; (d
d9a0: 65 62 75 67 3a 70 72 69 6e 74 20 22 64 6f 74 2d ebug:print "dot-
d9b0: 72 65 73 3d 22 20 64 6f 74 2d 72 65 73 29 29 0a res=" dot-res)).
d9c0: 09 3b 3b 20 28 6c 65 74 20 28 28 64 61 74 61 20 .;; (let ((data
d9d0: 28 6d 61 70 20 63 64 72 20 28 66 69 6c 74 65 72 (map cdr (filter
d9e0: 0a 09 3b 3b 20 20 20 20 20 09 09 20 20 28 6c 61 ..;; .. (la
d9f0: 6d 62 64 61 20 28 78 29 28 65 71 75 61 6c 3f 20 mbda (x)(equal?
da00: 22 6e 6f 64 65 22 20 28 63 61 72 20 78 29 29 29 "node" (car x)))
da10: 0a 09 3b 3b 20 20 20 20 20 09 09 20 20 28 6d 61 ..;; .. (ma
da20: 70 20 73 74 72 69 6e 67 2d 73 70 6c 69 74 20 28 p string-split (
da30: 74 65 73 74 73 3a 65 61 73 79 2d 64 6f 74 20 74 tests:easy-dot t
da40: 65 73 74 2d 72 65 63 6f 72 64 73 20 22 70 6c 61 est-records "pla
da50: 69 6e 22 29 29 29 29 29 29 0a 09 3b 3b 20 20 20 in"))))))..;;
da60: 28 6d 61 70 20 63 61 72 20 28 73 6f 72 74 20 64 (map car (sort d
da70: 61 74 61 20 28 6c 61 6d 62 64 61 20 28 61 20 62 ata (lambda (a b
da80: 29 0a 09 3b 3b 20 20 20 20 20 09 09 20 20 20 20 )..;; ..
da90: 28 3e 20 28 73 74 72 69 6e 67 2d 3e 6e 75 6d 62 (> (string->numb
daa0: 65 72 20 28 63 61 64 64 72 20 61 29 29 28 73 74 er (caddr a))(st
dab0: 72 69 6e 67 2d 3e 6e 75 6d 62 65 72 20 28 63 61 ring->number (ca
dac0: 64 64 72 20 62 29 29 29 29 29 29 29 0a 09 3b 3b ddr b)))))))..;;
dad0: 20 29 29 0a 09 28 73 6f 72 74 20 61 6c 6c 2d 74 ))..(sort all-t
dae0: 65 73 74 73 20 73 6f 72 74 2d 66 6e 31 29 29 29 ests sort-fn1)))
daf0: 29 20 3b 3b 20 61 76 6f 69 64 20 64 65 61 6c 69 ) ;; avoid deali
db00: 6e 67 20 77 69 74 68 20 64 65 6c 65 74 65 64 20 ng with deleted
db10: 74 65 73 74 73 2c 20 6c 6f 6f 6b 20 61 74 20 74 tests, look at t
db20: 68 65 20 68 61 73 68 20 74 61 62 6c 65 0a 0a 28 he hash table..(
db30: 64 65 66 69 6e 65 20 28 74 65 73 74 73 3a 65 61 define (tests:ea
db40: 73 79 2d 64 6f 74 20 74 65 73 74 2d 72 65 63 6f sy-dot test-reco
db50: 72 64 73 20 6f 75 74 74 79 70 65 29 0a 20 20 28 rds outtype). (
db60: 6c 65 74 2d 76 61 6c 75 65 73 20 28 28 28 66 64 let-values (((fd
db70: 20 74 65 6d 70 2d 70 61 74 68 29 20 28 66 69 6c temp-path) (fil
db80: 65 2d 6d 6b 73 74 65 6d 70 20 28 63 6f 6e 63 20 e-mkstemp (conc
db90: 22 2f 74 6d 70 2f 22 20 28 63 75 72 72 65 6e 74 "/tmp/" (current
dba0: 2d 75 73 65 72 2d 6e 61 6d 65 29 20 22 2e 58 58 -user-name) ".XX
dbb0: 58 58 58 58 22 29 29 29 29 0a 20 20 20 20 28 6c XXXX")))). (l
dbc0: 65 74 20 28 28 61 6c 6c 2d 74 65 73 74 6e 61 6d et ((all-testnam
dbd0: 65 73 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 6b es (hash-table-k
dbe0: 65 79 73 20 74 65 73 74 2d 72 65 63 6f 72 64 73 eys test-records
dbf0: 29 29 0a 09 20 20 28 74 65 6d 70 2d 70 6f 72 74 )).. (temp-port
dc00: 20 20 20 20 20 28 6f 70 65 6e 2d 6f 75 74 70 75 (open-outpu
dc10: 74 2d 66 69 6c 65 2a 20 66 64 29 29 29 0a 20 20 t-file* fd))).
dc20: 20 20 20 20 3b 3b 20 28 66 6f 72 6d 61 74 20 74 ;; (format t
dc30: 65 6d 70 2d 70 6f 72 74 20 22 54 68 69 73 20 66 emp-port "This f
dc40: 69 6c 65 20 69 73 20 7e 41 2e 7e 25 22 20 74 65 ile is ~A.~%" te
dc50: 6d 70 2d 70 61 74 68 29 0a 20 20 20 20 20 20 28 mp-path). (
dc60: 66 6f 72 6d 61 74 20 74 65 6d 70 2d 70 6f 72 74 format temp-port
dc70: 20 22 64 69 67 72 61 70 68 20 74 65 73 74 73 20 "digraph tests
dc80: 7b 5c 6e 22 29 0a 20 20 20 20 20 20 28 66 6f 72 {\n"). (for
dc90: 6d 61 74 20 74 65 6d 70 2d 70 6f 72 74 20 22 20 mat temp-port "
dca0: 20 73 69 7a 65 3d 34 2c 38 5c 6e 22 29 0a 20 20 size=4,8\n").
dcb0: 20 20 20 20 3b 3b 20 28 66 6f 72 6d 61 74 20 74 ;; (format t
dcc0: 65 6d 70 2d 70 6f 72 74 20 22 20 20 20 73 70 6c emp-port " spl
dcd0: 69 6e 65 73 3d 6e 6f 6e 65 5c 6e 22 29 0a 20 20 ines=none\n").
dce0: 20 20 20 20 28 66 6f 72 2d 65 61 63 68 0a 20 20 (for-each.
dcf0: 20 20 20 20 20 28 6c 61 6d 62 64 61 20 28 74 65 (lambda (te
dd00: 73 74 6e 61 6d 65 29 0a 09 20 28 6c 65 74 2a 20 stname).. (let*
dd10: 28 28 74 65 73 74 72 65 63 20 28 68 61 73 68 2d ((testrec (hash-
dd20: 74 61 62 6c 65 2d 72 65 66 20 74 65 73 74 2d 72 table-ref test-r
dd30: 65 63 6f 72 64 73 20 74 65 73 74 6e 61 6d 65 29 ecords testname)
dd40: 29 0a 09 09 28 77 61 69 74 6f 6e 73 20 28 6f 72 )...(waitons (or
dd50: 20 28 74 65 73 74 73 3a 74 65 73 74 71 75 65 75 (tests:testqueu
dd60: 65 2d 67 65 74 2d 77 61 69 74 6f 6e 73 20 74 65 e-get-waitons te
dd70: 73 74 72 65 63 29 20 27 28 29 29 29 29 0a 09 20 strec) '())))..
dd80: 20 20 28 66 6f 72 2d 65 61 63 68 0a 09 20 20 20 (for-each..
dd90: 20 28 6c 61 6d 62 64 61 20 28 77 61 69 74 6f 6e (lambda (waiton
dda0: 29 0a 09 20 20 20 20 20 20 28 66 6f 72 6d 61 74 ).. (format
ddb0: 20 74 65 6d 70 2d 70 6f 72 74 20 28 63 6f 6e 63 temp-port (conc
ddc0: 20 22 20 20 20 22 20 77 61 69 74 6f 6e 20 22 20 " " waiton "
ddd0: 2d 3e 20 22 20 74 65 73 74 6e 61 6d 65 20 22 20 -> " testname "
dde0: 5b 73 70 6c 69 6e 65 73 3d 6f 72 74 68 6f 5d 5c [splines=ortho]\
ddf0: 6e 22 29 29 29 0a 09 20 20 20 20 77 61 69 74 6f n"))).. waito
de00: 6e 73 29 29 29 0a 20 20 20 20 20 20 20 61 6c 6c ns))). all
de10: 2d 74 65 73 74 6e 61 6d 65 73 29 0a 20 20 20 20 -testnames).
de20: 20 20 28 66 6f 72 6d 61 74 20 74 65 6d 70 2d 70 (format temp-p
de30: 6f 72 74 20 22 7d 5c 6e 22 29 0a 20 20 20 20 20 ort "}\n").
de40: 20 28 63 6c 6f 73 65 2d 6f 75 74 70 75 74 2d 70 (close-output-p
de50: 6f 72 74 20 74 65 6d 70 2d 70 6f 72 74 29 0a 20 ort temp-port).
de60: 20 20 20 20 20 28 77 69 74 68 2d 69 6e 70 75 74 (with-input
de70: 2d 66 72 6f 6d 2d 70 69 70 65 0a 20 20 20 20 20 -from-pipe.
de80: 20 20 28 63 6f 6e 63 20 22 65 6e 76 20 2d 69 20 (conc "env -i
de90: 50 41 54 48 3d 24 50 41 54 48 20 64 6f 74 20 2d PATH=$PATH dot -
dea0: 54 22 20 6f 75 74 74 79 70 65 20 22 20 3c 20 22 T" outtype " < "
deb0: 20 74 65 6d 70 2d 70 61 74 68 29 0a 20 20 20 20 temp-path).
dec0: 20 20 20 28 6c 61 6d 62 64 61 20 28 29 0a 09 20 (lambda ()..
ded0: 28 6c 65 74 20 28 28 72 65 73 20 28 72 65 61 64 (let ((res (read
dee0: 2d 6c 69 6e 65 73 29 29 29 0a 09 20 20 20 3b 3b -lines))).. ;;
def0: 20 28 64 65 6c 65 74 65 2d 66 69 6c 65 20 74 65 (delete-file te
df00: 6d 70 2d 70 61 74 68 29 0a 09 20 20 20 72 65 73 mp-path).. res
df10: 29 29 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 ))))))..(define
df20: 28 74 65 73 74 73 3a 77 72 69 74 65 2d 64 6f 74 (tests:write-dot
df30: 2d 66 69 6c 65 20 74 65 73 74 2d 72 65 63 6f 72 -file test-recor
df40: 64 73 20 66 6e 61 6d 65 20 73 69 7a 65 78 20 73 ds fname sizex s
df50: 69 7a 65 79 29 0a 20 20 28 69 66 20 28 66 69 6c izey). (if (fil
df60: 65 2d 77 72 69 74 65 2d 61 63 63 65 73 73 3f 20 e-write-access?
df70: 28 70 61 74 68 6e 61 6d 65 2d 64 69 72 65 63 74 (pathname-direct
df80: 6f 72 79 20 66 6e 61 6d 65 29 29 0a 20 20 20 20 ory fname)).
df90: 20 20 28 77 69 74 68 2d 6f 75 74 70 75 74 2d 74 (with-output-t
dfa0: 6f 2d 66 69 6c 65 20 66 6e 61 6d 65 0a 09 28 6c o-file fname..(l
dfb0: 61 6d 62 64 61 20 28 29 0a 09 20 20 28 6d 61 70 ambda ().. (map
dfc0: 20 70 72 69 6e 74 20 28 74 65 73 74 73 3a 74 65 print (tests:te
dfd0: 73 74 73 2d 3e 64 6f 74 20 74 65 73 74 2d 72 65 sts->dot test-re
dfe0: 63 6f 72 64 73 20 73 69 7a 65 78 20 73 69 7a 65 cords sizex size
dff0: 79 29 29 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 y))))))..(define
e000: 20 28 74 65 73 74 73 3a 74 65 73 74 73 2d 3e 64 (tests:tests->d
e010: 6f 74 20 74 65 73 74 2d 72 65 63 6f 72 64 73 20 ot test-records
e020: 73 69 7a 65 78 20 73 69 7a 65 79 29 0a 20 20 28 sizex sizey). (
e030: 6c 65 74 20 28 28 61 6c 6c 2d 74 65 73 74 6e 61 let ((all-testna
e040: 6d 65 73 20 28 68 61 73 68 2d 74 61 62 6c 65 2d mes (hash-table-
e050: 6b 65 79 73 20 74 65 73 74 2d 72 65 63 6f 72 64 keys test-record
e060: 73 29 29 29 0a 20 20 20 20 28 69 66 20 28 6e 75 s))). (if (nu
e070: 6c 6c 3f 20 61 6c 6c 2d 74 65 73 74 6e 61 6d 65 ll? all-testname
e080: 73 29 0a 09 27 28 29 0a 09 28 6c 65 74 20 6c 6f s)..'()..(let lo
e090: 6f 70 20 28 28 68 65 64 20 28 63 61 72 20 61 6c op ((hed (car al
e0a0: 6c 2d 74 65 73 74 6e 61 6d 65 73 29 29 0a 09 09 l-testnames))...
e0b0: 20 20 20 28 74 61 6c 20 28 63 64 72 20 61 6c 6c (tal (cdr all
e0c0: 2d 74 65 73 74 6e 61 6d 65 73 29 29 0a 09 09 20 -testnames))...
e0d0: 20 20 28 72 65 73 20 28 6c 69 73 74 20 22 64 69 (res (list "di
e0e0: 67 72 61 70 68 20 74 65 73 74 73 20 7b 22 0a 09 graph tests {"..
e0f0: 09 09 20 20 20 20 20 20 28 63 6f 6e 63 20 22 20 .. (conc "
e100: 73 69 7a 65 3d 5c 22 22 20 28 6f 72 20 73 69 7a size=\"" (or siz
e110: 65 78 20 31 31 29 20 22 2c 22 20 28 6f 72 20 73 ex 11) "," (or s
e120: 69 7a 65 79 20 31 31 29 20 22 5c 22 3b 22 29 0a izey 11) "\";").
e130: 09 09 09 20 20 20 20 20 20 22 20 72 61 74 69 6f ... " ratio
e140: 3d 30 2e 39 35 3b 22 0a 09 09 09 20 20 20 20 20 =0.95;"....
e150: 20 29 29 29 0a 09 20 20 28 6c 65 74 2a 20 28 28 ))).. (let* ((
e160: 74 65 73 74 72 65 63 20 28 68 61 73 68 2d 74 61 testrec (hash-ta
e170: 62 6c 65 2d 72 65 66 20 74 65 73 74 2d 72 65 63 ble-ref test-rec
e180: 6f 72 64 73 20 68 65 64 29 29 0a 09 09 20 28 77 ords hed))... (w
e190: 61 69 74 6f 6e 73 20 28 6f 72 20 28 74 65 73 74 aitons (or (test
e1a0: 73 3a 74 65 73 74 71 75 65 75 65 2d 67 65 74 2d s:testqueue-get-
e1b0: 77 61 69 74 6f 6e 73 20 74 65 73 74 72 65 63 29 waitons testrec)
e1c0: 20 27 28 29 29 29 0a 09 09 20 28 6e 65 77 72 65 '()))... (newre
e1d0: 73 20 20 28 61 70 70 65 6e 64 20 72 65 73 0a 09 s (append res..
e1e0: 09 09 09 20 20 28 69 66 20 28 6e 75 6c 6c 3f 20 ... (if (null?
e1f0: 77 61 69 74 6f 6e 73 29 0a 09 09 09 09 20 20 20 waitons).....
e200: 20 20 20 28 6c 69 73 74 20 28 63 6f 6e 63 20 22 (list (conc "
e210: 20 20 20 5c 22 22 20 68 65 64 20 22 5c 22 20 5b \"" hed "\" [
e220: 73 68 61 70 65 3d 62 6f 78 5d 3b 22 29 29 0a 09 shape=box];"))..
e230: 09 09 09 20 20 20 20 20 20 28 6d 61 70 20 28 6c ... (map (l
e240: 61 6d 62 64 61 20 28 77 61 69 74 6f 6e 29 0a 09 ambda (waiton)..
e250: 09 09 09 09 20 20 20 20 20 28 63 6f 6e 63 20 22 .... (conc "
e260: 20 20 20 5c 22 22 20 77 61 69 74 6f 6e 20 22 5c \"" waiton "\
e270: 22 20 2d 3e 20 5c 22 22 20 68 65 64 20 22 5c 22 " -> \"" hed "\"
e280: 20 5b 73 68 61 70 65 3d 62 6f 78 5d 3b 22 29 29 [shape=box];"))
e290: 0a 09 09 09 09 09 20 20 20 77 61 69 74 6f 6e 73 ...... waitons
e2a0: 29 0a 09 09 09 09 20 20 20 20 20 20 29 29 29 29 )..... ))))
e2b0: 0a 09 20 20 20 20 28 69 66 20 28 6e 75 6c 6c 3f .. (if (null?
e2c0: 20 74 61 6c 29 0a 09 09 28 61 70 70 65 6e 64 20 tal)...(append
e2d0: 6e 65 77 72 65 73 20 28 6c 69 73 74 20 22 7d 22 newres (list "}"
e2e0: 29 29 0a 09 09 28 6c 6f 6f 70 20 28 63 61 72 20 ))...(loop (car
e2f0: 74 61 6c 29 28 63 64 72 20 74 61 6c 29 20 6e 65 tal)(cdr tal) ne
e300: 77 72 65 73 29 0a 09 09 29 29 29 29 29 29 0a 0a wres)...))))))..
e310: 3b 3b 20 28 74 65 73 74 73 3a 72 75 6e 2d 64 6f ;; (tests:run-do
e320: 74 20 28 6c 69 73 74 20 22 64 69 67 72 61 70 68 t (list "digraph
e330: 20 74 65 73 74 73 20 7b 22 20 22 61 20 2d 3e 20 tests {" "a ->
e340: 62 22 20 22 7d 22 29 20 22 70 6c 61 69 6e 22 29 b" "}") "plain")
e350: 0a 0a 28 64 65 66 69 6e 65 20 28 74 65 73 74 73 ..(define (tests
e360: 3a 72 75 6e 2d 64 6f 74 20 69 6e 64 61 74 20 6f :run-dot indat o
e370: 75 74 74 79 70 65 29 20 3b 3b 20 6f 75 74 74 79 uttype) ;; outty
e380: 70 65 20 69 73 20 70 6c 61 69 6e 2c 20 66 69 67 pe is plain, fig
e390: 2c 20 64 6f 74 2c 20 65 74 63 2e 20 68 74 74 70 , dot, etc. http
e3a0: 3a 2f 2f 77 77 77 2e 67 72 61 70 68 76 69 7a 2e ://www.graphviz.
e3b0: 6f 72 67 2f 63 6f 6e 74 65 6e 74 2f 6f 75 74 70 org/content/outp
e3c0: 75 74 2d 66 6f 72 6d 61 74 73 0a 20 20 28 6c 65 ut-formats. (le
e3d0: 74 2d 76 61 6c 75 65 73 20 28 28 28 69 6e 70 20 t-values (((inp
e3e0: 6f 75 70 20 70 69 64 29 28 70 72 6f 63 65 73 73 oup pid)(process
e3f0: 20 22 65 6e 76 20 2d 69 20 50 41 54 48 3d 24 50 "env -i PATH=$P
e400: 41 54 48 20 64 6f 74 22 20 28 6c 69 73 74 20 22 ATH dot" (list "
e410: 2d 54 22 20 6f 75 74 74 79 70 65 29 29 29 29 0a -T" outtype)))).
e420: 20 20 20 20 28 77 69 74 68 2d 6f 75 74 70 75 74 (with-output
e430: 2d 74 6f 2d 70 6f 72 74 20 6f 75 70 0a 20 20 20 -to-port oup.
e440: 20 20 20 28 6c 61 6d 62 64 61 20 28 29 0a 09 28 (lambda ()..(
e450: 6d 61 70 20 70 72 69 6e 74 20 69 6e 64 61 74 29 map print indat)
e460: 29 29 0a 20 20 20 20 28 63 6c 6f 73 65 2d 6f 75 )). (close-ou
e470: 74 70 75 74 2d 70 6f 72 74 20 6f 75 70 29 0a 20 tput-port oup).
e480: 20 20 20 28 6c 65 74 20 28 28 72 65 73 20 28 77 (let ((res (w
e490: 69 74 68 2d 69 6e 70 75 74 2d 66 72 6f 6d 2d 70 ith-input-from-p
e4a0: 6f 72 74 20 69 6e 70 0a 09 09 20 28 6c 61 6d 62 ort inp... (lamb
e4b0: 64 61 20 28 29 0a 09 09 20 20 20 28 72 65 61 64 da ()... (read
e4c0: 2d 6c 69 6e 65 73 29 29 29 29 29 0a 20 20 20 20 -lines))))).
e4d0: 20 20 28 63 6c 6f 73 65 2d 69 6e 70 75 74 2d 70 (close-input-p
e4e0: 6f 72 74 20 69 6e 70 29 0a 20 20 20 20 20 20 72 ort inp). r
e4f0: 65 73 29 29 29 0a 0a 3b 3b 20 72 65 61 64 20 64 es)))..;; read d
e500: 61 74 61 20 66 72 6f 6d 20 74 6d 70 20 66 69 6c ata from tmp fil
e510: 65 20 6f 72 20 63 72 65 61 74 65 20 69 66 20 6e e or create if n
e520: 6f 74 20 65 78 69 73 74 73 0a 3b 3b 20 69 66 20 ot exists.;; if
e530: 65 78 69 73 74 73 20 72 65 67 65 6e 20 69 6e 20 exists regen in
e540: 62 61 63 6b 67 72 6f 75 6e 64 0a 3b 3b 0a 28 64 background.;;.(d
e550: 65 66 69 6e 65 20 28 74 65 73 74 73 3a 6c 61 7a efine (tests:laz
e560: 79 2d 64 6f 74 20 74 65 73 74 72 65 63 6f 72 64 y-dot testrecord
e570: 73 20 20 6f 75 74 74 79 70 65 20 73 69 7a 65 78 s outtype sizex
e580: 20 73 69 7a 65 79 29 0a 20 20 28 6c 65 74 20 28 sizey). (let (
e590: 28 64 66 69 6c 65 20 28 63 6f 6e 63 20 22 2f 74 (dfile (conc "/t
e5a0: 6d 70 2f 2e 22 20 28 63 75 72 72 65 6e 74 2d 75 mp/." (current-u
e5b0: 73 65 72 2d 6e 61 6d 65 29 20 22 2d 22 20 28 73 ser-name) "-" (s
e5c0: 65 72 76 65 72 3a 6d 6b 2d 73 69 67 6e 61 74 75 erver:mk-signatu
e5d0: 72 65 29 20 22 2e 64 6f 74 22 29 29 0a 09 28 66 re) ".dot"))..(f
e5e0: 6e 61 6d 65 20 28 63 6f 6e 63 20 22 2f 74 6d 70 name (conc "/tmp
e5f0: 2f 2e 22 20 28 63 75 72 72 65 6e 74 2d 75 73 65 /." (current-use
e600: 72 2d 6e 61 6d 65 29 20 22 2d 22 20 28 73 65 72 r-name) "-" (ser
e610: 76 65 72 3a 6d 6b 2d 73 69 67 6e 61 74 75 72 65 ver:mk-signature
e620: 29 20 22 2e 64 6f 74 64 61 74 22 29 29 29 0a 20 ) ".dotdat"))).
e630: 20 20 20 28 74 65 73 74 73 3a 77 72 69 74 65 2d (tests:write-
e640: 64 6f 74 2d 66 69 6c 65 20 74 65 73 74 72 65 63 dot-file testrec
e650: 6f 72 64 73 20 64 66 69 6c 65 20 73 69 7a 65 78 ords dfile sizex
e660: 20 73 69 7a 65 79 29 0a 20 20 20 20 28 69 66 20 sizey). (if
e670: 28 66 69 6c 65 2d 65 78 69 73 74 73 3f 20 66 6e (file-exists? fn
e680: 61 6d 65 29 0a 09 28 6c 65 74 20 28 28 72 65 73 ame)..(let ((res
e690: 20 28 77 69 74 68 2d 69 6e 70 75 74 2d 66 72 6f (with-input-fro
e6a0: 6d 2d 66 69 6c 65 20 66 6e 61 6d 65 0a 09 09 20 m-file fname...
e6b0: 20 20 20 20 28 6c 61 6d 62 64 61 20 28 29 0a 09 (lambda ()..
e6c0: 09 20 20 20 20 20 20 20 28 72 65 61 64 2d 6c 69 . (read-li
e6d0: 6e 65 73 29 29 29 29 29 0a 09 20 20 28 73 79 73 nes))))).. (sys
e6e0: 74 65 6d 20 28 63 6f 6e 63 20 22 65 6e 76 20 2d tem (conc "env -
e6f0: 69 20 50 41 54 48 3d 24 50 41 54 48 20 64 6f 74 i PATH=$PATH dot
e700: 20 2d 54 20 22 20 6f 75 74 74 79 70 65 20 22 20 -T " outtype "
e710: 3c 20 22 20 64 66 69 6c 65 20 22 20 3e 20 22 20 < " dfile " > "
e720: 66 6e 61 6d 65 20 22 26 22 29 29 0a 09 20 20 72 fname "&")).. r
e730: 65 73 29 0a 09 28 62 65 67 69 6e 0a 09 20 20 28 es)..(begin.. (
e740: 73 79 73 74 65 6d 20 28 63 6f 6e 63 20 22 65 6e system (conc "en
e750: 76 20 2d 69 20 50 41 54 48 3d 24 50 41 54 48 20 v -i PATH=$PATH
e760: 64 6f 74 20 2d 54 20 22 20 6f 75 74 74 79 70 65 dot -T " outtype
e770: 20 22 20 3c 20 22 20 64 66 69 6c 65 20 22 20 3e " < " dfile " >
e780: 20 22 20 66 6e 61 6d 65 29 29 0a 09 20 20 28 77 " fname)).. (w
e790: 69 74 68 2d 69 6e 70 75 74 2d 66 72 6f 6d 2d 66 ith-input-from-f
e7a0: 69 6c 65 20 66 6e 61 6d 65 0a 09 20 20 20 20 28 ile fname.. (
e7b0: 6c 61 6d 62 64 61 20 28 29 0a 09 20 20 20 20 20 lambda ()..
e7c0: 20 28 72 65 61 64 2d 6c 69 6e 65 73 29 29 29 29 (read-lines))))
e7d0: 29 29 29 0a 09 20 20 0a 0a 3b 3b 20 66 6f 72 20 ))).. ..;; for
e7e0: 65 61 63 68 20 74 65 73 74 3a 0a 3b 3b 20 20 20 each test:.;;
e7f0: 0a 28 64 65 66 69 6e 65 20 28 74 65 73 74 73 3a .(define (tests:
e800: 66 69 6c 74 65 72 2d 6e 6f 6e 2d 72 75 6e 6e 61 filter-non-runna
e810: 62 6c 65 20 72 75 6e 2d 69 64 20 74 65 73 74 6b ble run-id testk
e820: 65 79 6e 61 6d 65 73 20 74 65 73 74 72 65 63 6f eynames testreco
e830: 72 64 73 68 61 73 68 29 0a 20 20 28 6c 65 74 20 rdshash). (let
e840: 28 28 72 75 6e 6e 61 62 6c 65 73 20 27 28 29 29 ((runnables '())
e850: 29 0a 20 20 20 20 28 66 6f 72 2d 65 61 63 68 0a ). (for-each.
e860: 20 20 20 20 20 28 6c 61 6d 62 64 61 20 28 74 65 (lambda (te
e870: 73 74 6b 65 79 6e 61 6d 65 29 0a 20 20 20 20 20 stkeyname).
e880: 20 20 28 6c 65 74 2a 20 28 28 74 65 73 74 2d 72 (let* ((test-r
e890: 65 63 6f 72 64 20 28 68 61 73 68 2d 74 61 62 6c ecord (hash-tabl
e8a0: 65 2d 72 65 66 20 74 65 73 74 72 65 63 6f 72 64 e-ref testrecord
e8b0: 73 68 61 73 68 20 74 65 73 74 6b 65 79 6e 61 6d shash testkeynam
e8c0: 65 29 29 0a 09 20 20 20 20 20 20 28 74 65 73 74 e)).. (test
e8d0: 2d 6e 61 6d 65 20 20 20 28 74 65 73 74 73 3a 74 -name (tests:t
e8e0: 65 73 74 71 75 65 75 65 2d 67 65 74 2d 74 65 73 estqueue-get-tes
e8f0: 74 6e 61 6d 65 20 20 74 65 73 74 2d 72 65 63 6f tname test-reco
e900: 72 64 29 29 0a 09 20 20 20 20 20 20 28 69 74 65 rd)).. (ite
e910: 6d 64 61 74 20 20 20 20 20 28 74 65 73 74 73 3a mdat (tests:
e920: 74 65 73 74 71 75 65 75 65 2d 67 65 74 2d 69 74 testqueue-get-it
e930: 65 6d 64 61 74 20 20 20 74 65 73 74 2d 72 65 63 emdat test-rec
e940: 6f 72 64 29 29 0a 09 20 20 20 20 20 20 28 69 74 ord)).. (it
e950: 65 6d 2d 70 61 74 68 20 20 20 28 74 65 73 74 73 em-path (tests
e960: 3a 74 65 73 74 71 75 65 75 65 2d 67 65 74 2d 69 :testqueue-get-i
e970: 74 65 6d 5f 70 61 74 68 20 74 65 73 74 2d 72 65 tem_path test-re
e980: 63 6f 72 64 29 29 0a 09 20 20 20 20 20 20 28 77 cord)).. (w
e990: 61 69 74 6f 6e 73 20 20 20 20 20 28 74 65 73 74 aitons (test
e9a0: 73 3a 74 65 73 74 71 75 65 75 65 2d 67 65 74 2d s:testqueue-get-
e9b0: 77 61 69 74 6f 6e 73 20 20 20 74 65 73 74 2d 72 waitons test-r
e9c0: 65 63 6f 72 64 29 29 0a 09 20 20 20 20 20 20 28 ecord)).. (
e9d0: 6b 65 65 70 2d 74 65 73 74 20 20 20 23 74 29 0a keep-test #t).
e9e0: 09 20 20 20 20 20 20 28 74 65 73 74 2d 69 64 20 . (test-id
e9f0: 20 20 20 20 28 72 6d 74 3a 67 65 74 2d 74 65 73 (rmt:get-tes
ea00: 74 2d 69 64 20 72 75 6e 2d 69 64 20 74 65 73 74 t-id run-id test
ea10: 2d 6e 61 6d 65 20 69 74 65 6d 2d 70 61 74 68 29 -name item-path)
ea20: 29 0a 09 20 20 20 20 20 20 28 74 64 61 74 20 20 ).. (tdat
ea30: 20 20 20 20 20 20 28 72 6d 74 3a 67 65 74 2d 74 (rmt:get-t
ea40: 65 73 74 69 6e 66 6f 2d 73 74 61 74 65 2d 73 74 estinfo-state-st
ea50: 61 74 75 73 20 72 75 6e 2d 69 64 20 74 65 73 74 atus run-id test
ea60: 2d 69 64 29 29 29 20 3b 3b 20 28 63 64 62 3a 67 -id))) ;; (cdb:g
ea70: 65 74 2d 74 65 73 74 2d 69 6e 66 6f 2d 62 79 2d et-test-info-by-
ea80: 69 64 20 2a 72 75 6e 72 65 6d 6f 74 65 2a 20 74 id *runremote* t
ea90: 65 73 74 2d 69 64 29 29 29 0a 09 20 28 69 66 20 est-id))).. (if
eaa0: 74 64 61 74 0a 09 20 20 20 20 20 28 62 65 67 69 tdat.. (begi
eab0: 6e 0a 09 20 20 20 20 20 20 20 3b 3b 20 4c 6f 6f n.. ;; Loo
eac0: 6b 20 61 74 20 74 68 65 20 74 65 73 74 20 73 74 k at the test st
ead0: 61 74 65 20 61 6e 64 20 73 74 61 74 75 73 0a 09 ate and status..
eae0: 20 20 20 20 20 20 20 28 69 66 20 28 6f 72 20 28 (if (or (
eaf0: 61 6e 64 20 28 6d 65 6d 62 65 72 20 28 64 62 3a and (member (db:
eb00: 74 65 73 74 2d 67 65 74 2d 73 74 61 74 75 73 20 test-get-status
eb10: 74 64 61 74 29 20 0a 09 09 09 09 20 20 20 20 27 tdat) ..... '
eb20: 28 22 50 41 53 53 22 20 22 57 41 52 4e 22 20 22 ("PASS" "WARN" "
eb30: 57 41 49 56 45 44 22 20 22 43 48 45 43 4b 22 20 WAIVED" "CHECK"
eb40: 22 53 4b 49 50 22 29 29 0a 09 09 09 20 20 20 20 "SKIP"))....
eb50: 28 65 71 75 61 6c 3f 20 28 64 62 3a 74 65 73 74 (equal? (db:test
eb60: 2d 67 65 74 2d 73 74 61 74 65 20 74 64 61 74 29 -get-state tdat)
eb70: 20 22 43 4f 4d 50 4c 45 54 45 44 22 29 29 0a 09 "COMPLETED"))..
eb80: 09 20 20 20 20 20 20 20 28 6d 65 6d 62 65 72 20 . (member
eb90: 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 73 74 61 (db:test-get-sta
eba0: 74 65 20 74 64 61 74 29 0a 09 09 09 09 20 20 20 te tdat).....
ebb0: 20 27 28 22 49 4e 43 4f 4d 50 4c 45 54 45 22 20 '("INCOMPLETE"
ebc0: 22 4b 49 4c 4c 45 44 22 29 29 29 0a 09 09 20 20 "KILLED")))...
ebd0: 20 28 73 65 74 21 20 6b 65 65 70 2d 74 65 73 74 (set! keep-test
ebe0: 20 23 66 29 29 0a 0a 09 20 20 20 20 20 20 20 3b #f))... ;
ebf0: 3b 20 65 78 61 6d 69 6e 65 20 77 61 69 74 6f 6e ; examine waiton
ec00: 73 20 66 6f 72 20 61 6e 79 20 66 61 69 6c 73 2e s for any fails.
ec10: 20 49 66 20 69 74 20 69 73 20 46 41 49 4c 20 6f If it is FAIL o
ec20: 72 20 49 4e 43 4f 4d 50 4c 45 54 45 20 74 68 65 r INCOMPLETE the
ec30: 6e 20 65 6c 69 6d 69 6e 61 74 65 20 74 68 69 73 n eliminate this
ec40: 20 74 65 73 74 0a 09 20 20 20 20 20 20 20 3b 3b test.. ;;
ec50: 20 66 72 6f 6d 20 74 68 65 20 72 75 6e 6e 61 62 from the runnab
ec60: 6c 65 20 6c 69 73 74 0a 09 20 20 20 20 20 20 20 le list..
ec70: 28 69 66 20 6b 65 65 70 2d 74 65 73 74 0a 09 09 (if keep-test...
ec80: 20 20 20 28 66 6f 72 2d 65 61 63 68 20 28 6c 61 (for-each (la
ec90: 6d 62 64 61 20 28 77 61 69 74 6f 6e 29 0a 09 09 mbda (waiton)...
eca0: 09 20 20 20 20 20 20 20 3b 3b 20 66 6f 72 20 6e . ;; for n
ecb0: 6f 77 20 77 65 20 61 72 65 20 77 61 69 74 69 6e ow we are waitin
ecc0: 67 20 6f 6e 6c 79 20 6f 6e 20 74 68 65 20 70 61 g only on the pa
ecd0: 72 65 6e 74 20 74 65 73 74 0a 09 09 09 20 20 20 rent test....
ece0: 20 20 20 20 28 6c 65 74 2a 20 28 28 70 61 72 65 (let* ((pare
ecf0: 6e 74 2d 74 65 73 74 2d 69 64 20 28 72 6d 74 3a nt-test-id (rmt:
ed00: 67 65 74 2d 74 65 73 74 2d 69 64 20 72 75 6e 2d get-test-id run-
ed10: 69 64 20 77 61 69 74 6f 6e 20 22 22 29 29 0a 09 id waiton ""))..
ed20: 09 09 09 20 20 20 20 20 20 28 77 74 64 61 74 20 ... (wtdat
ed30: 20 20 20 20 20 20 20 20 20 28 72 6d 74 3a 67 65 (rmt:ge
ed40: 74 2d 74 65 73 74 69 6e 66 6f 2d 73 74 61 74 65 t-testinfo-state
ed50: 2d 73 74 61 74 75 73 20 72 75 6e 2d 69 64 20 74 -status run-id t
ed60: 65 73 74 2d 69 64 29 29 29 20 3b 3b 20 28 63 64 est-id))) ;; (cd
ed70: 62 3a 67 65 74 2d 74 65 73 74 2d 69 6e 66 6f 2d b:get-test-info-
ed80: 62 79 2d 69 64 20 2a 72 75 6e 72 65 6d 6f 74 65 by-id *runremote
ed90: 2a 20 74 65 73 74 2d 69 64 29 29 29 0a 09 09 09 * test-id)))....
eda0: 09 20 28 69 66 20 28 6f 72 20 28 61 6e 64 20 28 . (if (or (and (
edb0: 65 71 75 61 6c 3f 20 28 64 62 3a 74 65 73 74 2d equal? (db:test-
edc0: 67 65 74 2d 73 74 61 74 65 20 77 74 64 61 74 29 get-state wtdat)
edd0: 20 22 43 4f 4d 50 4c 45 54 45 44 22 29 0a 09 09 "COMPLETED")...
ede0: 09 09 09 20 20 20 20 20 20 28 6d 65 6d 62 65 72 ... (member
edf0: 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 73 74 (db:test-get-st
ee00: 61 74 75 73 20 77 74 64 61 74 29 20 27 28 22 46 atus wtdat) '("F
ee10: 41 49 4c 22 20 22 41 42 4f 52 54 22 29 29 29 0a AIL" "ABORT"))).
ee20: 09 09 09 09 09 20 28 6d 65 6d 62 65 72 20 28 64 ..... (member (d
ee30: 62 3a 74 65 73 74 2d 67 65 74 2d 73 74 61 74 75 b:test-get-statu
ee40: 73 20 77 74 64 61 74 29 20 20 27 28 22 4b 49 4c s wtdat) '("KIL
ee50: 4c 45 44 22 29 29 0a 09 09 09 09 09 20 28 6d 65 LED"))...... (me
ee60: 6d 62 65 72 20 28 64 62 3a 74 65 73 74 2d 67 65 mber (db:test-ge
ee70: 74 2d 73 74 61 74 65 20 77 74 64 61 74 29 20 20 t-state wtdat)
ee80: 20 27 28 22 49 4e 43 4f 4d 50 45 54 45 22 29 29 '("INCOMPETE"))
ee90: 29 0a 09 09 09 09 20 3b 3b 20 28 69 66 20 28 6f )..... ;; (if (o
eea0: 72 20 28 6d 65 6d 62 65 72 20 28 64 62 3a 74 65 r (member (db:te
eeb0: 73 74 2d 67 65 74 2d 73 74 61 74 75 73 20 77 74 st-get-status wt
eec0: 64 61 74 29 0a 09 09 09 09 20 3b 3b 20 20 20 20 dat)..... ;;
eed0: 20 20 20 20 09 20 27 28 22 46 41 49 4c 22 20 22 . '("FAIL" "
eee0: 4b 49 4c 4c 45 44 22 29 29 0a 09 09 09 09 20 3b KILLED"))..... ;
eef0: 3b 20 20 20 20 20 20 20 20 20 28 6d 65 6d 62 65 ; (membe
ef00: 72 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 73 r (db:test-get-s
ef10: 74 61 74 65 20 77 74 64 61 74 29 0a 09 09 09 09 tate wtdat).....
ef20: 20 3b 3b 20 20 20 20 20 20 20 20 09 20 27 28 22 ;; . '("
ef30: 49 4e 43 4f 4d 50 45 54 45 22 29 29 29 0a 09 09 INCOMPETE")))...
ef40: 09 09 20 20 20 20 20 28 73 65 74 21 20 6b 65 65 .. (set! kee
ef50: 70 2d 74 65 73 74 20 23 66 29 29 29 29 20 3b 3b p-test #f)))) ;;
ef60: 20 6e 6f 20 70 6f 69 6e 74 20 69 6e 20 72 75 6e no point in run
ef70: 6e 69 6e 67 20 74 68 69 73 20 6f 6e 65 20 61 67 ning this one ag
ef80: 61 69 6e 0a 09 09 09 20 20 20 20 20 77 61 69 74 ain.... wait
ef90: 6f 6e 73 29 29 29 29 0a 09 20 28 69 66 20 6b 65 ons)))).. (if ke
efa0: 65 70 2d 74 65 73 74 20 28 73 65 74 21 20 72 75 ep-test (set! ru
efb0: 6e 6e 61 62 6c 65 73 20 28 63 6f 6e 73 20 74 65 nnables (cons te
efc0: 73 74 6b 65 79 6e 61 6d 65 20 72 75 6e 6e 61 62 stkeyname runnab
efd0: 6c 65 73 29 29 29 29 29 0a 20 20 20 20 20 74 65 les))))). te
efe0: 73 74 6b 65 79 6e 61 6d 65 73 29 0a 20 20 20 20 stkeynames).
eff0: 72 75 6e 6e 61 62 6c 65 73 29 29 0a 0a 3b 3b 3d runnables))..;;=
f000: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
f010: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
f020: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
f030: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
f040: 3d 3d 3d 3d 3d 0a 3b 3b 20 72 65 66 61 63 74 6f =====.;; refacto
f050: 72 69 6e 67 20 74 68 69 73 20 62 6c 6f 63 6b 20 ring this block
f060: 69 6e 74 6f 20 74 65 73 74 73 3a 67 65 74 2d 66 into tests:get-f
f070: 75 6c 6c 2d 64 61 74 61 20 66 72 6f 6d 20 6c 69 ull-data from li
f080: 6e 65 20 32 36 33 20 6f 66 20 72 75 6e 73 2e 73 ne 263 of runs.s
f090: 63 6d 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d cm.;;===========
f0a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
f0b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
f0c0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
f0d0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 68 ===========.;; h
f0e0: 65 64 20 69 73 20 74 68 65 20 74 65 73 74 20 6e ed is the test n
f0f0: 61 6d 65 0a 3b 3b 20 74 65 73 74 2d 72 65 63 6f ame.;; test-reco
f100: 72 64 73 20 69 73 20 61 20 68 61 73 68 20 6f 66 rds is a hash of
f110: 20 74 65 73 74 2d 6e 61 6d 65 20 3d 3e 20 74 65 test-name => te
f120: 73 74 20 72 65 63 6f 72 64 0a 28 64 65 66 69 6e st record.(defin
f130: 65 20 28 74 65 73 74 73 3a 67 65 74 2d 66 75 6c e (tests:get-ful
f140: 6c 2d 64 61 74 61 20 74 65 73 74 2d 6e 61 6d 65 l-data test-name
f150: 73 20 74 65 73 74 2d 72 65 63 6f 72 64 73 20 72 s test-records r
f160: 65 71 75 69 72 65 64 2d 74 65 73 74 73 20 61 6c equired-tests al
f170: 6c 2d 74 65 73 74 73 2d 72 65 67 69 73 74 72 79 l-tests-registry
f180: 29 0a 20 20 28 69 66 20 28 6e 6f 74 20 28 6e 75 ). (if (not (nu
f190: 6c 6c 3f 20 74 65 73 74 2d 6e 61 6d 65 73 29 29 ll? test-names))
f1a0: 0a 20 20 20 20 20 20 28 6c 65 74 20 6c 6f 6f 70 . (let loop
f1b0: 20 28 28 68 65 64 20 28 63 61 72 20 74 65 73 74 ((hed (car test
f1c0: 2d 6e 61 6d 65 73 29 29 0a 09 09 20 28 74 61 6c -names))... (tal
f1d0: 20 28 63 64 72 20 74 65 73 74 2d 6e 61 6d 65 73 (cdr test-names
f1e0: 29 29 29 20 20 20 20 20 20 20 20 20 3b 3b 20 27 ))) ;; '
f1f0: 72 65 74 75 72 6e 2d 70 72 6f 63 73 20 74 65 6c return-procs tel
f200: 6c 73 20 74 68 65 20 63 6f 6e 66 69 67 20 72 65 ls the config re
f210: 61 64 65 72 20 74 6f 20 70 72 65 70 20 72 75 6e ader to prep run
f220: 6e 69 6e 67 20 73 79 73 74 65 6d 20 62 75 74 20 ning system but
f230: 72 65 74 75 72 6e 20 61 20 70 72 6f 63 0a 09 28 return a proc..(
f240: 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f debug:print-info
f250: 20 34 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 4 *default-log-
f260: 70 6f 72 74 2a 20 22 68 65 64 3d 22 20 68 65 64 port* "hed=" hed
f270: 20 22 20 61 74 20 74 6f 70 20 6f 66 20 6c 6f 6f " at top of loo
f280: 70 22 29 0a 20 20 20 20 20 20 20 20 3b 3b 20 64 p"). ;; d
f290: 6f 6e 27 74 20 6b 6e 6f 77 20 69 74 65 6d 2d 70 on't know item-p
f2a0: 61 74 68 20 61 74 20 74 68 69 73 20 74 69 6d 65 ath at this time
f2b0: 2c 20 6c 65 74 20 74 68 65 20 74 65 73 74 63 6f , let the testco
f2c0: 6e 66 69 67 20 67 65 74 20 74 68 65 20 74 6f 70 nfig get the top
f2d0: 20 6c 65 76 65 6c 20 74 65 73 74 63 6f 6e 66 69 level testconfi
f2e0: 67 0a 09 28 6c 65 74 2a 20 28 28 63 6f 6e 66 69 g..(let* ((confi
f2f0: 67 20 20 28 74 65 73 74 73 3a 67 65 74 2d 74 65 g (tests:get-te
f300: 73 74 63 6f 6e 66 69 67 20 68 65 64 20 23 66 20 stconfig hed #f
f310: 61 6c 6c 2d 74 65 73 74 73 2d 72 65 67 69 73 74 all-tests-regist
f320: 72 79 20 27 72 65 74 75 72 6e 2d 70 72 6f 63 73 ry 'return-procs
f330: 29 29 0a 09 20 20 20 20 20 20 20 28 77 61 69 74 )).. (wait
f340: 6f 6e 73 20 28 6c 65 74 20 28 28 69 6e 73 74 72 ons (let ((instr
f350: 20 28 69 66 20 63 6f 6e 66 69 67 20 0a 09 09 09 (if config ....
f360: 09 09 20 28 63 6f 6e 66 69 67 2d 6c 6f 6f 6b 75 .. (config-looku
f370: 70 20 63 6f 6e 66 69 67 20 22 72 65 71 75 69 72 p config "requir
f380: 65 6d 65 6e 74 73 22 20 22 77 61 69 74 6f 6e 22 ements" "waiton"
f390: 29 0a 09 09 09 09 09 20 28 62 65 67 69 6e 20 3b )...... (begin ;
f3a0: 3b 20 4e 6f 20 63 6f 6e 66 69 67 20 6d 65 61 6e ; No config mean
f3b0: 73 20 74 68 69 73 20 69 73 20 61 20 6e 6f 6e 2d s this is a non-
f3c0: 65 78 69 73 74 61 6e 74 20 74 65 73 74 0a 09 09 existant test...
f3d0: 09 09 09 20 20 20 28 64 65 62 75 67 3a 70 72 69 ... (debug:pri
f3e0: 6e 74 2d 65 72 72 6f 72 20 30 20 2a 64 65 66 61 nt-error 0 *defa
f3f0: 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 6e ult-log-port* "n
f400: 6f 6e 2d 65 78 69 73 74 65 6e 74 20 72 65 71 75 on-existent requ
f410: 69 72 65 64 20 74 65 73 74 20 5c 22 22 20 68 65 ired test \"" he
f420: 64 20 22 5c 22 2c 20 67 72 65 70 20 74 68 72 6f d "\", grep thro
f430: 75 67 68 20 79 6f 75 72 20 74 65 73 74 63 6f 6e ugh your testcon
f440: 66 69 67 73 20 74 6f 20 66 69 6e 64 20 61 6e 64 figs to find and
f450: 20 72 65 6d 6f 76 65 20 6f 72 20 63 72 65 61 74 remove or creat
f460: 65 20 74 68 65 20 74 65 73 74 2e 20 44 69 73 63 e the test. Disc
f470: 61 72 64 69 6e 67 20 61 6e 64 20 63 6f 6e 74 69 arding and conti
f480: 6e 75 69 6e 67 2e 22 29 0a 09 09 09 09 09 20 20 nuing.")......
f490: 20 20 20 22 22 29 29 29 29 0a 09 09 09 20 20 28 "")))).... (
f4a0: 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f debug:print-info
f4b0: 20 38 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 8 *default-log-
f4c0: 70 6f 72 74 2a 20 22 77 61 69 74 6f 6e 73 20 73 port* "waitons s
f4d0: 74 72 69 6e 67 20 69 73 20 22 20 69 6e 73 74 72 tring is " instr
f4e0: 29 0a 09 09 09 20 20 28 73 74 72 69 6e 67 2d 73 ).... (string-s
f4f0: 70 6c 69 74 20 28 63 6f 6e 64 0a 09 09 09 09 09 plit (cond......
f500: 20 28 28 70 72 6f 63 65 64 75 72 65 3f 20 69 6e ((procedure? in
f510: 73 74 72 29 0a 09 09 09 09 09 20 20 28 6c 65 74 str)...... (let
f520: 20 28 28 72 65 73 20 28 69 6e 73 74 72 29 29 29 ((res (instr)))
f530: 0a 09 09 09 09 09 20 20 20 20 28 64 65 62 75 67 ...... (debug
f540: 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 38 20 2a 64 :print-info 8 *d
f550: 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a efault-log-port*
f560: 20 22 77 61 69 74 6f 6e 20 70 72 6f 63 65 64 75 "waiton procedu
f570: 72 65 20 72 65 73 75 6c 74 73 20 69 6e 20 73 74 re results in st
f580: 72 69 6e 67 20 22 20 72 65 73 20 22 20 66 6f 72 ring " res " for
f590: 20 74 65 73 74 20 22 20 68 65 64 29 0a 09 09 09 test " hed)....
f5a0: 09 09 20 20 20 20 72 65 73 29 29 0a 09 09 09 09 .. res)).....
f5b0: 09 20 28 28 73 74 72 69 6e 67 3f 20 69 6e 73 74 . ((string? inst
f5c0: 72 29 20 20 20 20 20 69 6e 73 74 72 29 0a 09 09 r) instr)...
f5d0: 09 09 09 20 28 65 6c 73 65 20 0a 09 09 09 09 09 ... (else ......
f5e0: 20 20 3b 3b 20 4e 4f 54 45 3a 20 54 68 69 73 20 ;; NOTE: This
f5f0: 69 73 20 61 63 74 75 61 6c 6c 79 20 74 68 65 20 is actually the
f600: 63 61 73 65 20 6f 66 20 2a 6e 6f 2a 20 77 61 69 case of *no* wai
f610: 74 6f 6e 73 21 20 3b 3b 20 28 64 65 62 75 67 3a tons! ;; (debug:
f620: 70 72 69 6e 74 2d 65 72 72 6f 72 20 30 20 2a 64 print-error 0 *d
f630: 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a efault-log-port*
f640: 20 22 73 6f 6d 65 74 68 69 6e 67 20 77 65 6e 74 "something went
f650: 20 77 72 6f 6e 67 20 69 6e 20 70 72 6f 63 65 73 wrong in proces
f660: 73 69 6e 67 20 77 61 69 74 6f 6e 73 20 66 6f 72 sing waitons for
f670: 20 74 65 73 74 20 22 20 68 65 64 29 0a 09 09 09 test " hed)....
f680: 09 09 20 20 22 22 29 29 29 29 29 29 0a 09 20 20 .. ""))))))..
f690: 28 69 66 20 28 6e 6f 74 20 63 6f 6e 66 69 67 29 (if (not config)
f6a0: 20 3b 3b 20 74 68 69 73 20 69 73 20 61 20 6e 6f ;; this is a no
f6b0: 6e 2d 65 78 69 73 74 61 6e 74 20 74 65 73 74 20 n-existant test
f6c0: 63 61 6c 6c 65 64 20 69 6e 20 61 20 77 61 69 74 called in a wait
f6d0: 6f 6e 2e 20 0a 09 20 20 20 20 20 20 28 69 66 20 on. .. (if
f6e0: 28 6e 75 6c 6c 3f 20 74 61 6c 29 0a 09 09 20 20 (null? tal)...
f6f0: 74 65 73 74 2d 72 65 63 6f 72 64 73 0a 09 09 20 test-records...
f700: 20 28 6c 6f 6f 70 20 28 63 61 72 20 74 61 6c 29 (loop (car tal)
f710: 28 63 64 72 20 74 61 6c 29 29 29 0a 09 20 20 20 (cdr tal)))..
f720: 20 20 20 28 62 65 67 69 6e 0a 09 09 28 64 65 62 (begin...(deb
f730: 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 38 20 ug:print-info 8
f740: 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 *default-log-por
f750: 74 2a 20 22 77 61 69 74 6f 6e 73 3a 20 22 20 77 t* "waitons: " w
f760: 61 69 74 6f 6e 73 29 0a 09 09 3b 3b 20 63 68 65 aitons)...;; che
f770: 63 6b 20 66 6f 72 20 68 65 64 20 69 6e 20 77 61 ck for hed in wa
f780: 69 74 6f 6e 73 20 3d 3e 20 74 68 69 73 20 77 6f itons => this wo
f790: 75 6c 64 20 62 65 20 63 69 72 63 75 6c 61 72 2c uld be circular,
f7a0: 20 72 65 6d 6f 76 65 20 69 74 20 61 6e 64 20 69 remove it and i
f7b0: 73 73 75 65 20 61 6e 0a 09 09 3b 3b 20 65 72 72 ssue an...;; err
f7c0: 6f 72 0a 09 09 28 69 66 20 28 6d 65 6d 62 65 72 or...(if (member
f7d0: 20 68 65 64 20 77 61 69 74 6f 6e 73 29 0a 09 09 hed waitons)...
f7e0: 20 20 20 20 28 62 65 67 69 6e 0a 09 09 20 20 20 (begin...
f7f0: 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d (debug:print-
f800: 65 72 72 6f 72 20 30 20 2a 64 65 66 61 75 6c 74 error 0 *default
f810: 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 74 65 73 74 -log-port* "test
f820: 20 22 20 68 65 64 20 22 20 68 61 73 20 6c 69 73 " hed " has lis
f830: 74 65 64 20 69 74 73 65 6c 66 20 61 73 20 61 20 ted itself as a
f840: 77 61 69 74 6f 6e 2c 20 70 6c 65 61 73 65 20 63 waiton, please c
f850: 6f 72 72 65 63 74 20 74 68 69 73 21 22 29 0a 09 orrect this!")..
f860: 09 20 20 20 20 20 20 28 73 65 74 21 20 77 61 69 . (set! wai
f870: 74 6f 6e 73 20 28 66 69 6c 74 65 72 20 28 6c 61 tons (filter (la
f880: 6d 62 64 61 20 28 78 29 28 6e 6f 74 20 28 65 71 mbda (x)(not (eq
f890: 75 61 6c 3f 20 78 20 68 65 64 29 29 29 20 77 61 ual? x hed))) wa
f8a0: 69 74 6f 6e 73 29 29 29 29 0a 09 09 0a 09 09 3b itons))))......;
f8b0: 3b 20 28 69 74 65 6d 73 20 20 20 28 69 74 65 6d ; (items (item
f8c0: 73 3a 67 65 74 2d 69 74 65 6d 73 2d 66 72 6f 6d s:get-items-from
f8d0: 2d 63 6f 6e 66 69 67 20 63 6f 6e 66 69 67 29 29 -config config))
f8e0: 29 0a 09 09 28 69 66 20 28 6e 6f 74 20 28 68 61 )...(if (not (ha
f8f0: 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 sh-table-ref/def
f900: 61 75 6c 74 20 74 65 73 74 2d 72 65 63 6f 72 64 ault test-record
f910: 73 20 68 65 64 20 23 66 29 29 0a 09 09 20 20 20 s hed #f))...
f920: 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 (hash-table-set
f930: 21 20 74 65 73 74 2d 72 65 63 6f 72 64 73 0a 09 ! test-records..
f940: 09 09 09 20 20 20 20 20 68 65 64 20 28 76 65 63 ... hed (vec
f950: 74 6f 72 20 68 65 64 20 20 20 20 20 3b 3b 20 30 tor hed ;; 0
f960: 0a 09 09 09 09 09 09 20 63 6f 6e 66 69 67 20 20 ....... config
f970: 3b 3b 20 31 0a 09 09 09 09 09 09 20 77 61 69 74 ;; 1....... wait
f980: 6f 6e 73 20 3b 3b 20 32 0a 09 09 09 09 09 09 20 ons ;; 2.......
f990: 28 63 6f 6e 66 69 67 2d 6c 6f 6f 6b 75 70 20 63 (config-lookup c
f9a0: 6f 6e 66 69 67 20 22 72 65 71 75 69 72 65 6d 65 onfig "requireme
f9b0: 6e 74 73 22 20 22 70 72 69 6f 72 69 74 79 22 29 nts" "priority")
f9c0: 20 20 20 20 20 3b 3b 20 70 72 69 6f 72 69 74 79 ;; priority
f9d0: 20 33 0a 09 09 09 09 09 09 20 28 6c 65 74 20 28 3....... (let (
f9e0: 28 69 74 65 6d 73 20 20 20 20 20 20 28 68 61 73 (items (has
f9f0: 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 h-table-ref/defa
fa00: 75 6c 74 20 63 6f 6e 66 69 67 20 22 69 74 65 6d ult config "item
fa10: 73 22 20 23 66 29 29 20 3b 3b 20 69 74 65 6d 73 s" #f)) ;; items
fa20: 20 34 0a 09 09 09 09 09 09 20 20 20 20 20 20 20 4.......
fa30: 28 69 74 65 6d 73 74 61 62 6c 65 20 28 68 61 73 (itemstable (has
fa40: 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 h-table-ref/defa
fa50: 75 6c 74 20 63 6f 6e 66 69 67 20 22 69 74 65 6d ult config "item
fa60: 73 74 61 62 6c 65 22 20 23 66 29 29 29 20 0a 09 stable" #f))) ..
fa70: 09 09 09 09 09 20 20 20 3b 3b 20 69 66 20 65 69 ..... ;; if ei
fa80: 74 68 65 72 20 69 74 65 6d 73 20 6f 72 20 69 74 ther items or it
fa90: 65 6d 73 20 74 61 62 6c 65 20 69 73 20 61 20 70 ems table is a p
faa0: 72 6f 63 20 72 65 74 75 72 6e 20 69 74 20 73 6f roc return it so
fab0: 20 74 65 73 74 20 72 75 6e 6e 69 6e 67 0a 09 09 test running...
fac0: 09 09 09 09 20 20 20 3b 3b 20 70 72 6f 63 65 73 .... ;; proces
fad0: 73 20 63 61 6e 20 6b 6e 6f 77 20 74 6f 20 63 61 s can know to ca
fae0: 6c 6c 20 69 74 65 6d 73 3a 67 65 74 2d 69 74 65 ll items:get-ite
faf0: 6d 73 2d 66 72 6f 6d 2d 63 6f 6e 66 69 67 0a 09 ms-from-config..
fb00: 09 09 09 09 09 20 20 20 3b 3b 20 69 66 20 65 69 ..... ;; if ei
fb10: 74 68 65 72 20 69 73 20 61 20 6c 69 73 74 20 61 ther is a list a
fb20: 6e 64 20 6e 6f 6e 65 20 69 73 20 61 20 70 72 6f nd none is a pro
fb30: 63 20 67 6f 20 61 68 65 61 64 20 61 6e 64 20 63 c go ahead and c
fb40: 61 6c 6c 20 67 65 74 2d 69 74 65 6d 73 0a 09 09 all get-items...
fb50: 09 09 09 09 20 20 20 3b 3b 20 6f 74 68 65 72 77 .... ;; otherw
fb60: 69 73 65 20 72 65 74 75 72 6e 20 23 66 20 2d 20 ise return #f -
fb70: 74 68 69 73 20 69 73 20 6e 6f 74 20 61 6e 20 69 this is not an i
fb80: 74 65 72 61 74 65 64 20 74 65 73 74 0a 09 09 09 terated test....
fb90: 09 09 09 20 20 20 28 63 6f 6e 64 0a 09 09 09 09 ... (cond.....
fba0: 09 09 20 20 20 20 28 28 70 72 6f 63 65 64 75 72 .. ((procedur
fbb0: 65 3f 20 69 74 65 6d 73 29 20 20 20 20 20 20 0a e? items) .
fbc0: 09 09 09 09 09 09 20 20 20 20 20 28 64 65 62 75 ...... (debu
fbd0: 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 34 20 2a g:print-info 4 *
fbe0: 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 default-log-port
fbf0: 2a 20 22 69 74 65 6d 73 20 69 73 20 61 20 70 72 * "items is a pr
fc00: 6f 63 65 64 75 72 65 2c 20 77 69 6c 6c 20 63 61 ocedure, will ca
fc10: 6c 63 20 6c 61 74 65 72 22 29 0a 09 09 09 09 09 lc later")......
fc20: 09 20 20 20 20 20 69 74 65 6d 73 29 20 20 20 20 . items)
fc30: 20 20 20 20 20 20 20 20 3b 3b 20 63 61 6c 63 20 ;; calc
fc40: 6c 61 74 65 72 0a 09 09 09 09 09 09 20 20 20 20 later.......
fc50: 28 28 70 72 6f 63 65 64 75 72 65 3f 20 69 74 65 ((procedure? ite
fc60: 6d 73 74 61 62 6c 65 29 0a 09 09 09 09 09 09 20 mstable).......
fc70: 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 (debug:print
fc80: 2d 69 6e 66 6f 20 34 20 2a 64 65 66 61 75 6c 74 -info 4 *default
fc90: 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 69 74 65 6d -log-port* "item
fca0: 73 74 61 62 6c 65 20 69 73 20 61 20 70 72 6f 63 stable is a proc
fcb0: 65 64 75 72 65 2c 20 77 69 6c 6c 20 63 61 6c 63 edure, will calc
fcc0: 20 6c 61 74 65 72 22 29 0a 09 09 09 09 09 09 20 later").......
fcd0: 20 20 20 20 69 74 65 6d 73 74 61 62 6c 65 29 20 itemstable)
fce0: 20 20 20 20 20 20 3b 3b 20 63 61 6c 63 20 6c 61 ;; calc la
fcf0: 74 65 72 0a 09 09 09 09 09 09 20 20 20 20 28 28 ter....... ((
fd00: 66 69 6c 74 65 72 20 28 6c 61 6d 62 64 61 20 28 filter (lambda (
fd10: 78 29 0a 09 09 09 09 09 09 09 20 20 20 20 20 20 x)........
fd20: 20 28 6c 65 74 20 28 28 76 61 6c 20 28 63 61 72 (let ((val (car
fd30: 20 78 29 29 29 0a 09 09 09 09 09 09 09 09 20 28 x)))......... (
fd40: 69 66 20 28 70 72 6f 63 65 64 75 72 65 3f 20 76 if (procedure? v
fd50: 61 6c 29 20 76 61 6c 20 23 66 29 29 29 0a 09 09 al) val #f)))...
fd60: 09 09 09 09 09 20 20 20 20 20 28 61 70 70 65 6e ..... (appen
fd70: 64 20 28 69 66 20 28 6c 69 73 74 3f 20 69 74 65 d (if (list? ite
fd80: 6d 73 29 20 69 74 65 6d 73 20 27 28 29 29 0a 09 ms) items '())..
fd90: 09 09 09 09 09 09 09 20 20 20 20 20 28 69 66 20 ....... (if
fda0: 28 6c 69 73 74 3f 20 69 74 65 6d 73 74 61 62 6c (list? itemstabl
fdb0: 65 29 20 69 74 65 6d 73 74 61 62 6c 65 20 27 28 e) itemstable '(
fdc0: 29 29 29 29 0a 09 09 09 09 09 09 20 20 20 20 20 )))).......
fdd0: 27 68 61 76 65 2d 70 72 6f 63 65 64 75 72 65 29 'have-procedure)
fde0: 0a 09 09 09 09 09 09 20 20 20 20 28 28 6f 72 20 ....... ((or
fdf0: 28 6c 69 73 74 3f 20 69 74 65 6d 73 29 28 6c 69 (list? items)(li
fe00: 73 74 3f 20 69 74 65 6d 73 74 61 62 6c 65 29 29 st? itemstable))
fe10: 20 3b 3b 20 63 61 6c 63 20 6e 6f 77 0a 09 09 09 ;; calc now....
fe20: 09 09 09 20 20 20 20 20 28 64 65 62 75 67 3a 70 ... (debug:p
fe30: 72 69 6e 74 2d 69 6e 66 6f 20 34 20 2a 64 65 66 rint-info 4 *def
fe40: 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 ault-log-port* "
fe50: 69 74 65 6d 73 20 61 6e 64 20 69 74 65 6d 73 74 items and itemst
fe60: 61 62 6c 65 20 61 72 65 20 6c 69 73 74 73 2c 20 able are lists,
fe70: 63 61 6c 63 20 6e 6f 77 5c 6e 22 0a 09 09 09 09 calc now\n".....
fe80: 09 09 09 09 20 20 20 20 20 20 20 22 20 20 20 20 .... "
fe90: 69 74 65 6d 73 3a 20 22 20 69 74 65 6d 73 20 22 items: " items "
fea0: 20 69 74 65 6d 73 74 61 62 6c 65 3a 20 22 20 69 itemstable: " i
feb0: 74 65 6d 73 74 61 62 6c 65 29 0a 09 09 09 09 09 temstable)......
fec0: 09 20 20 20 20 20 28 69 74 65 6d 73 3a 67 65 74 . (items:get
fed0: 2d 69 74 65 6d 73 2d 66 72 6f 6d 2d 63 6f 6e 66 -items-from-conf
fee0: 69 67 20 63 6f 6e 66 69 67 29 29 0a 09 09 09 09 ig config)).....
fef0: 09 09 20 20 20 20 28 65 6c 73 65 20 23 66 29 29 .. (else #f))
ff00: 29 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 )
ff10: 20 20 20 20 20 20 20 20 20 20 20 20 3b 3b 20 6e ;; n
ff20: 6f 74 20 69 74 65 72 61 74 65 64 0a 09 09 09 09 ot iterated.....
ff30: 09 09 20 23 66 20 20 20 20 20 20 3b 3b 20 69 74 .. #f ;; it
ff40: 65 6d 73 64 61 74 20 35 0a 09 09 09 09 09 09 20 emsdat 5.......
ff50: 23 66 20 20 20 20 20 20 3b 3b 20 73 70 61 72 65 #f ;; spare
ff60: 20 2d 20 75 73 65 64 20 66 6f 72 20 69 74 65 6d - used for item
ff70: 2d 70 61 74 68 0a 09 09 09 09 09 09 20 29 29 29 -path....... )))
ff80: 0a 09 09 28 66 6f 72 2d 65 61 63 68 20 0a 09 09 ...(for-each ...
ff90: 20 28 6c 61 6d 62 64 61 20 28 77 61 69 74 6f 6e (lambda (waiton
ffa0: 29 0a 09 09 20 20 20 28 69 66 20 28 61 6e 64 20 )... (if (and
ffb0: 77 61 69 74 6f 6e 20 28 6e 6f 74 20 28 6d 65 6d waiton (not (mem
ffc0: 62 65 72 20 77 61 69 74 6f 6e 20 74 65 73 74 2d ber waiton test-
ffd0: 6e 61 6d 65 73 29 29 29 0a 09 09 20 20 20 20 20 names)))...
ffe0: 20 20 28 62 65 67 69 6e 0a 09 09 09 20 28 73 65 (begin.... (se
fff0: 74 21 20 72 65 71 75 69 72 65 64 2d 74 65 73 74 t! required-test
10000 73 20 28 63 6f 6e 73 20 77 61 69 74 6f 6e 20 72 s (cons waiton r
10010 65 71 75 69 72 65 64 2d 74 65 73 74 73 29 29 0a equired-tests)).
10020 09 09 09 20 28 73 65 74 21 20 74 65 73 74 2d 6e ... (set! test-n
10030 61 6d 65 73 20 28 63 6f 6e 73 20 77 61 69 74 6f ames (cons waito
10040 6e 20 74 65 73 74 2d 6e 61 6d 65 73 29 29 29 29 n test-names))))
10050 29 20 3b 3b 20 77 61 73 20 61 6e 20 61 70 70 65 ) ;; was an appe
10060 6e 64 2c 20 6e 6f 77 20 61 20 63 6f 6e 73 0a 09 nd, now a cons..
10070 09 20 77 61 69 74 6f 6e 73 29 0a 09 09 28 6c 65 . waitons)...(le
10080 74 20 28 28 72 65 6d 74 65 73 74 73 20 28 64 65 t ((remtests (de
10090 6c 65 74 65 2d 64 75 70 6c 69 63 61 74 65 73 20 lete-duplicates
100a0 28 61 70 70 65 6e 64 20 77 61 69 74 6f 6e 73 20 (append waitons
100b0 74 61 6c 29 29 29 29 0a 09 09 20 20 28 69 66 20 tal))))... (if
100c0 28 6e 6f 74 20 28 6e 75 6c 6c 3f 20 72 65 6d 74 (not (null? remt
100d0 65 73 74 73 29 29 0a 09 09 20 20 20 20 20 20 28 ests))... (
100e0 6c 6f 6f 70 20 28 63 61 72 20 72 65 6d 74 65 73 loop (car remtes
100f0 74 73 29 28 63 64 72 20 72 65 6d 74 65 73 74 73 ts)(cdr remtests
10100 29 29 0a 09 09 20 20 20 20 20 20 74 65 73 74 2d ))... test-
10110 72 65 63 6f 72 64 73 29 29 29 29 29 29 29 29 0a records)))))))).
10120 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d .;;=============
10130 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
10140 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
10150 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
10160 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 74 65 73 =========.;; tes
10170 74 20 73 74 65 70 73 0a 3b 3b 3d 3d 3d 3d 3d 3d t steps.;;======
10180 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
10190 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
101a0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
101b0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
101c0 0a 0a 3b 3b 20 74 65 73 74 73 74 65 70 2d 73 65 ..;; teststep-se
101d0 74 2d 73 74 61 74 75 73 21 20 75 73 65 64 20 74 t-status! used t
101e0 6f 20 62 65 20 68 65 72 65 0a 0a 28 64 65 66 69 o be here..(defi
101f0 6e 65 20 28 74 65 73 74 2d 67 65 74 2d 6b 69 6c ne (test-get-kil
10200 6c 2d 72 65 71 75 65 73 74 20 72 75 6e 2d 69 64 l-request run-id
10210 20 74 65 73 74 2d 69 64 29 20 3b 3b 20 72 75 6e test-id) ;; run
10220 2d 69 64 20 74 65 73 74 2d 6e 61 6d 65 20 69 74 -id test-name it
10230 65 6d 64 61 74 29 0a 20 20 28 6c 65 74 2a 20 28 emdat). (let* (
10240 28 74 65 73 74 64 61 74 20 20 20 28 72 6d 74 3a (testdat (rmt:
10250 67 65 74 2d 74 65 73 74 2d 69 6e 66 6f 2d 62 79 get-test-info-by
10260 2d 69 64 20 72 75 6e 2d 69 64 20 74 65 73 74 2d -id run-id test-
10270 69 64 29 29 29 0a 20 20 20 20 28 61 6e 64 20 74 id))). (and t
10280 65 73 74 64 61 74 0a 09 20 28 65 71 75 61 6c 3f estdat.. (equal?
10290 20 28 74 65 73 74 3a 67 65 74 2d 73 74 61 74 65 (test:get-state
102a0 20 74 65 73 74 64 61 74 29 20 22 4b 49 4c 4c 52 testdat) "KILLR
102b0 45 51 22 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 EQ"))))..(define
102c0 20 28 74 65 73 74 3a 74 64 62 2d 67 65 74 2d 72 (test:tdb-get-r
102d0 75 6e 64 61 74 2d 63 6f 75 6e 74 20 74 64 62 29 undat-count tdb)
102e0 0a 20 20 28 69 66 20 74 64 62 0a 20 20 20 20 20 . (if tdb.
102f0 20 28 6c 65 74 20 28 28 72 65 73 20 30 29 29 0a (let ((res 0)).
10300 09 28 73 71 6c 69 74 65 33 3a 66 6f 72 2d 65 61 .(sqlite3:for-ea
10310 63 68 2d 72 6f 77 0a 09 20 28 6c 61 6d 62 64 61 ch-row.. (lambda
10320 20 28 63 6f 75 6e 74 29 0a 09 20 20 20 28 73 65 (count).. (se
10330 74 21 20 72 65 73 20 63 6f 75 6e 74 29 29 0a 09 t! res count))..
10340 20 74 64 62 0a 09 20 22 53 45 4c 45 43 54 20 63 tdb.. "SELECT c
10350 6f 75 6e 74 28 69 64 29 20 46 52 4f 4d 20 74 65 ount(id) FROM te
10360 73 74 5f 72 75 6e 64 61 74 3b 22 29 0a 09 72 65 st_rundat;")..re
10370 73 29 29 0a 20 20 30 29 0a 0a 28 64 65 66 69 6e s)). 0)..(defin
10380 65 20 28 74 65 73 74 73 3a 75 70 64 61 74 65 2d e (tests:update-
10390 63 65 6e 74 72 61 6c 2d 6d 65 74 61 2d 69 6e 66 central-meta-inf
103a0 6f 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 69 64 o run-id test-id
103b0 20 63 70 75 6c 6f 61 64 20 64 69 73 6b 66 72 65 cpuload diskfre
103c0 65 20 6d 69 6e 75 74 65 73 20 75 6e 61 6d 65 20 e minutes uname
103d0 68 6f 73 74 6e 61 6d 65 29 0a 20 20 28 72 6d 74 hostname). (rmt
103e0 3a 67 65 6e 65 72 61 6c 2d 63 61 6c 6c 20 27 75 :general-call 'u
103f0 70 64 61 74 65 2d 74 65 73 74 2d 72 75 6e 64 61 pdate-test-runda
10400 74 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 69 64 t run-id test-id
10410 20 28 63 75 72 72 65 6e 74 2d 73 65 63 6f 6e 64 (current-second
10420 73 29 20 28 6f 72 20 63 70 75 6c 6f 61 64 20 2d s) (or cpuload -
10430 31 29 28 6f 72 20 64 69 73 6b 66 72 65 65 20 2d 1)(or diskfree -
10440 31 29 20 2d 31 20 28 6f 72 20 6d 69 6e 75 74 65 1) -1 (or minute
10450 73 20 2d 31 29 29 0a 20 20 28 69 66 20 28 61 6e s -1)). (if (an
10460 64 20 63 70 75 6c 6f 61 64 20 64 69 73 6b 66 72 d cpuload diskfr
10470 65 65 29 0a 20 20 20 20 20 20 28 72 6d 74 3a 67 ee). (rmt:g
10480 65 6e 65 72 61 6c 2d 63 61 6c 6c 20 27 75 70 64 eneral-call 'upd
10490 61 74 65 2d 63 70 75 6c 6f 61 64 2d 64 69 73 6b ate-cpuload-disk
104a0 66 72 65 65 20 72 75 6e 2d 69 64 20 63 70 75 6c free run-id cpul
104b0 6f 61 64 20 64 69 73 6b 66 72 65 65 20 74 65 73 oad diskfree tes
104c0 74 2d 69 64 29 29 0a 20 20 28 69 66 20 6d 69 6e t-id)). (if min
104d0 75 74 65 73 20 0a 20 20 20 20 20 20 28 72 6d 74 utes . (rmt
104e0 3a 67 65 6e 65 72 61 6c 2d 63 61 6c 6c 20 27 75 :general-call 'u
104f0 70 64 61 74 65 2d 72 75 6e 2d 64 75 72 61 74 69 pdate-run-durati
10500 6f 6e 20 72 75 6e 2d 69 64 20 6d 69 6e 75 74 65 on run-id minute
10510 73 20 74 65 73 74 2d 69 64 29 29 0a 20 20 28 69 s test-id)). (i
10520 66 20 28 61 6e 64 20 75 6e 61 6d 65 20 68 6f 73 f (and uname hos
10530 74 6e 61 6d 65 29 0a 20 20 20 20 20 20 28 72 6d tname). (rm
10540 74 3a 67 65 6e 65 72 61 6c 2d 63 61 6c 6c 20 27 t:general-call '
10550 75 70 64 61 74 65 2d 75 6e 61 6d 65 2d 68 6f 73 update-uname-hos
10560 74 20 72 75 6e 2d 69 64 20 75 6e 61 6d 65 20 68 t run-id uname h
10570 6f 73 74 6e 61 6d 65 20 74 65 73 74 2d 69 64 29 ostname test-id)
10580 29 29 0a 20 20 0a 3b 3b 20 54 68 69 73 20 6f 6e )). .;; This on
10590 65 20 69 73 20 66 6f 72 20 72 75 6e 6e 69 6e 67 e is for running
105a0 20 77 69 74 68 20 6e 6f 20 64 62 20 61 63 63 65 with no db acce
105b0 73 73 20 28 69 2e 65 2e 20 76 69 61 20 72 6d 74 ss (i.e. via rmt
105c0 3a 20 69 6e 74 65 72 6e 61 6c 6c 79 29 0a 28 64 : internally).(d
105d0 65 66 69 6e 65 20 28 74 65 73 74 73 3a 73 65 74 efine (tests:set
105e0 2d 66 75 6c 6c 2d 6d 65 74 61 2d 69 6e 66 6f 20 -full-meta-info
105f0 64 62 20 74 65 73 74 2d 69 64 20 72 75 6e 2d 69 db test-id run-i
10600 64 20 6d 69 6e 75 74 65 73 20 77 6f 72 6b 2d 61 d minutes work-a
10610 72 65 61 20 72 65 6d 74 72 69 65 73 29 0a 3b 3b rea remtries).;;
10620 20 28 64 65 66 69 6e 65 20 28 74 65 73 74 73 3a (define (tests:
10630 73 65 74 2d 66 75 6c 6c 2d 6d 65 74 61 2d 69 6e set-full-meta-in
10640 66 6f 20 74 65 73 74 2d 69 64 20 72 75 6e 2d 69 fo test-id run-i
10650 64 20 6d 69 6e 75 74 65 73 20 77 6f 72 6b 2d 61 d minutes work-a
10660 72 65 61 29 0a 3b 3b 20 20 28 6c 65 74 20 28 28 rea).;; (let ((
10670 72 65 6d 74 72 69 65 73 20 31 30 29 29 0a 20 20 remtries 10)).
10680 28 6c 65 74 2a 20 28 28 63 70 75 6c 6f 61 64 20 (let* ((cpuload
10690 20 28 67 65 74 2d 63 70 75 2d 6c 6f 61 64 29 29 (get-cpu-load))
106a0 0a 09 20 28 64 69 73 6b 66 72 65 65 20 28 67 65 .. (diskfree (ge
106b0 74 2d 64 66 20 28 63 75 72 72 65 6e 74 2d 64 69 t-df (current-di
106c0 72 65 63 74 6f 72 79 29 29 29 0a 09 20 28 75 6e rectory))).. (un
106d0 61 6d 65 20 20 20 20 28 67 65 74 2d 75 6e 61 6d ame (get-unam
106e0 65 20 22 2d 73 72 76 70 69 6f 22 29 29 0a 09 20 e "-srvpio"))..
106f0 28 68 6f 73 74 6e 61 6d 65 20 28 67 65 74 2d 68 (hostname (get-h
10700 6f 73 74 2d 6e 61 6d 65 29 29 29 0a 20 20 20 20 ost-name))).
10710 28 74 65 73 74 73 3a 75 70 64 61 74 65 2d 63 65 (tests:update-ce
10720 6e 74 72 61 6c 2d 6d 65 74 61 2d 69 6e 66 6f 20 ntral-meta-info
10730 72 75 6e 2d 69 64 20 74 65 73 74 2d 69 64 20 63 run-id test-id c
10740 70 75 6c 6f 61 64 20 64 69 73 6b 66 72 65 65 20 puload diskfree
10750 6d 69 6e 75 74 65 73 20 75 6e 61 6d 65 20 68 6f minutes uname ho
10760 73 74 6e 61 6d 65 29 29 29 0a 20 20 20 20 0a 3b stname))). .;
10770 3b 20 28 64 65 66 69 6e 65 20 28 74 65 73 74 73 ; (define (tests
10780 3a 73 65 74 2d 70 61 72 74 69 61 6c 2d 6d 65 74 :set-partial-met
10790 61 2d 69 6e 66 6f 20 74 65 73 74 2d 69 64 20 72 a-info test-id r
107a0 75 6e 2d 69 64 20 6d 69 6e 75 74 65 73 20 77 6f un-id minutes wo
107b0 72 6b 2d 61 72 65 61 29 0a 28 64 65 66 69 6e 65 rk-area).(define
107c0 20 28 74 65 73 74 73 3a 73 65 74 2d 70 61 72 74 (tests:set-part
107d0 69 61 6c 2d 6d 65 74 61 2d 69 6e 66 6f 20 74 65 ial-meta-info te
107e0 73 74 2d 69 64 20 72 75 6e 2d 69 64 20 6d 69 6e st-id run-id min
107f0 75 74 65 73 20 77 6f 72 6b 2d 61 72 65 61 20 72 utes work-area r
10800 65 6d 74 72 69 65 73 29 0a 20 20 28 6c 65 74 2a emtries). (let*
10810 20 28 28 63 70 75 6c 6f 61 64 20 20 28 67 65 74 ((cpuload (get
10820 2d 63 70 75 2d 6c 6f 61 64 29 29 0a 09 20 28 64 -cpu-load)).. (d
10830 69 73 6b 66 72 65 65 20 28 67 65 74 2d 64 66 20 iskfree (get-df
10840 28 63 75 72 72 65 6e 74 2d 64 69 72 65 63 74 6f (current-directo
10850 72 79 29 29 29 0a 09 20 28 72 65 6d 74 72 69 65 ry))).. (remtrie
10860 73 20 31 30 29 29 0a 20 20 20 20 28 68 61 6e 64 s 10)). (hand
10870 6c 65 2d 65 78 63 65 70 74 69 6f 6e 73 0a 20 20 le-exceptions.
10880 20 20 20 65 78 6e 0a 20 20 20 20 20 28 69 66 20 exn. (if
10890 28 3e 20 72 65 6d 74 72 69 65 73 20 30 29 0a 09 (> remtries 0)..
108a0 20 28 62 65 67 69 6e 0a 09 20 20 20 28 70 72 69 (begin.. (pri
108b0 6e 74 2d 63 61 6c 6c 2d 63 68 61 69 6e 20 28 63 nt-call-chain (c
108c0 75 72 72 65 6e 74 2d 65 72 72 6f 72 2d 70 6f 72 urrent-error-por
108d0 74 29 29 0a 09 20 20 20 28 64 65 62 75 67 3a 70 t)).. (debug:p
108e0 72 69 6e 74 2d 69 6e 66 6f 20 30 20 2a 64 65 66 rint-info 0 *def
108f0 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 ault-log-port* "
10900 57 41 52 4e 49 4e 47 3a 20 66 61 69 6c 65 64 20 WARNING: failed
10910 74 6f 20 73 65 74 20 6d 65 74 61 20 69 6e 66 6f to set meta info
10920 2e 20 57 69 6c 6c 20 74 72 79 20 22 20 72 65 6d . Will try " rem
10930 74 72 69 65 73 20 22 20 6d 6f 72 65 20 74 69 6d tries " more tim
10940 65 73 22 29 0a 09 20 20 20 28 73 65 74 21 20 72 es").. (set! r
10950 65 6d 74 72 69 65 73 20 28 2d 20 72 65 6d 74 72 emtries (- remtr
10960 69 65 73 20 31 29 29 0a 09 20 20 20 28 74 68 72 ies 1)).. (thr
10970 65 61 64 2d 73 6c 65 65 70 21 20 31 30 29 0a 09 ead-sleep! 10)..
10980 20 20 20 28 74 65 73 74 73 3a 73 65 74 2d 66 75 (tests:set-fu
10990 6c 6c 2d 6d 65 74 61 2d 69 6e 66 6f 20 64 62 20 ll-meta-info db
109a0 74 65 73 74 2d 69 64 20 72 75 6e 2d 69 64 20 6d test-id run-id m
109b0 69 6e 75 74 65 73 20 77 6f 72 6b 2d 61 72 65 61 inutes work-area
109c0 20 28 2d 20 72 65 6d 74 72 69 65 73 20 31 29 29 (- remtries 1))
109d0 29 0a 09 20 28 6c 65 74 20 28 28 65 72 72 2d 73 ).. (let ((err-s
109e0 74 61 74 75 73 20 28 28 63 6f 6e 64 69 74 69 6f tatus ((conditio
109f0 6e 2d 70 72 6f 70 65 72 74 79 2d 61 63 63 65 73 n-property-acces
10a00 73 6f 72 20 27 73 71 6c 69 74 65 33 20 27 73 74 sor 'sqlite3 'st
10a10 61 74 75 73 20 23 66 29 20 65 78 6e 29 29 29 0a atus #f) exn))).
10a20 09 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 . (debug:print
10a30 2d 65 72 72 6f 72 20 30 20 2a 64 65 66 61 75 6c -error 0 *defaul
10a40 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 74 72 69 t-log-port* "tri
10a50 65 64 20 66 6f 72 20 6f 76 65 72 20 61 20 6d 69 ed for over a mi
10a60 6e 75 74 65 20 74 6f 20 75 70 64 61 74 65 20 6d nute to update m
10a70 65 74 61 20 69 6e 66 6f 20 61 6e 64 20 66 61 69 eta info and fai
10a80 6c 65 64 2e 20 47 69 76 69 6e 67 20 75 70 22 29 led. Giving up")
10a90 0a 09 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e .. (debug:prin
10aa0 74 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 t 0 *default-log
10ab0 2d 70 6f 72 74 2a 20 22 45 58 43 45 50 54 49 4f -port* "EXCEPTIO
10ac0 4e 3a 20 64 61 74 61 62 61 73 65 20 70 72 6f 62 N: database prob
10ad0 61 62 6c 79 20 6f 76 65 72 6c 6f 61 64 65 64 20 ably overloaded
10ae0 6f 72 20 75 6e 72 65 61 64 61 62 6c 65 2e 22 29 or unreadable.")
10af0 0a 09 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e .. (debug:prin
10b00 74 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 t 0 *default-log
10b10 2d 70 6f 72 74 2a 20 22 20 6d 65 73 73 61 67 65 -port* " message
10b20 3a 20 22 20 28 28 63 6f 6e 64 69 74 69 6f 6e 2d : " ((condition-
10b30 70 72 6f 70 65 72 74 79 2d 61 63 63 65 73 73 6f property-accesso
10b40 72 20 27 65 78 6e 20 27 6d 65 73 73 61 67 65 29 r 'exn 'message)
10b50 20 65 78 6e 29 29 0a 09 20 20 20 28 70 72 69 6e exn)).. (prin
10b60 74 20 22 65 78 6e 3d 22 20 28 63 6f 6e 64 69 74 t "exn=" (condit
10b70 69 6f 6e 2d 3e 6c 69 73 74 20 65 78 6e 29 29 0a ion->list exn)).
10b80 09 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 . (debug:print
10b90 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 0 *default-log-
10ba0 70 6f 72 74 2a 20 22 20 73 74 61 74 75 73 3a 20 port* " status:
10bb0 20 22 20 28 28 63 6f 6e 64 69 74 69 6f 6e 2d 70 " ((condition-p
10bc0 72 6f 70 65 72 74 79 2d 61 63 63 65 73 73 6f 72 roperty-accessor
10bd0 20 27 73 71 6c 69 74 65 33 20 27 73 74 61 74 75 'sqlite3 'statu
10be0 73 29 20 65 78 6e 29 29 0a 09 20 20 20 28 70 72 s) exn)).. (pr
10bf0 69 6e 74 2d 63 61 6c 6c 2d 63 68 61 69 6e 20 28 int-call-chain (
10c00 63 75 72 72 65 6e 74 2d 65 72 72 6f 72 2d 70 6f current-error-po
10c10 72 74 29 29 29 29 0a 20 20 20 20 20 28 74 65 73 rt)))). (tes
10c20 74 73 3a 75 70 64 61 74 65 2d 74 65 73 74 64 61 ts:update-testda
10c30 74 2d 6d 65 74 61 2d 69 6e 66 6f 20 64 62 20 74 t-meta-info db t
10c40 65 73 74 2d 69 64 20 77 6f 72 6b 2d 61 72 65 61 est-id work-area
10c50 20 63 70 75 6c 6f 61 64 20 64 69 73 6b 66 72 65 cpuload diskfre
10c60 65 20 6d 69 6e 75 74 65 73 29 0a 20 20 29 29 29 e minutes). )))
10c70 0a 09 20 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d .. .;;==========
10c80 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
10c90 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
10ca0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
10cb0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 ============.;;
10cc0 41 20 52 20 43 20 48 20 49 20 56 20 49 20 4e 20 A R C H I V I N
10cd0 47 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d G.;;============
10ce0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
10cf0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
10d00 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
10d10 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 28 64 65 66 ==========..(def
10d20 69 6e 65 20 28 74 65 73 74 3a 61 72 63 68 69 76 ine (test:archiv
10d30 65 20 64 62 20 74 65 73 74 2d 69 64 29 0a 20 20 e db test-id).
10d40 23 66 29 0a 0a 28 64 65 66 69 6e 65 20 28 74 65 #f)..(define (te
10d50 73 74 3a 61 72 63 68 69 76 65 2d 74 65 73 74 73 st:archive-tests
10d60 20 64 62 20 6b 65 79 6e 61 6d 65 73 20 74 61 72 db keynames tar
10d70 67 65 74 29 0a 20 20 23 66 29 0a 0a get). #f)..