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 22 57 41 52 4e 49 4e 47 3a 20 70 72 6f 62 6c "WARNING: probl
0720: 65 6d 20 77 69 74 68 20 64 69 72 65 63 74 6f 72 em with director
0730: 79 20 22 20 64 20 22 2c 20 64 72 6f 70 70 69 6e y " d ", droppin
0740: 67 20 69 74 20 66 72 6f 6d 20 74 65 73 74 73 20 g it from tests
0750: 70 61 74 68 22 29 29 0a 09 09 20 20 20 20 23 66 path"))... #f
0760: 29 29 29 0a 09 20 20 20 20 28 61 70 70 65 6e 64 ))).. (append
0770: 20 70 61 74 68 73 20 28 6c 69 73 74 20 28 63 6f paths (list (co
0780: 6e 63 20 2a 74 6f 70 70 61 74 68 2a 20 22 2f 74 nc *toppath* "/t
0790: 65 73 74 73 22 29 29 29 29 29 29 0a 0a 28 64 65 ests"))))))..(de
07a0: 66 69 6e 65 20 28 74 65 73 74 73 3a 67 65 74 2d fine (tests:get-
07b0: 76 61 6c 69 64 2d 74 65 73 74 73 20 74 65 73 74 valid-tests test
07c0: 2d 72 65 67 69 73 74 72 79 20 74 65 73 74 73 2d -registry tests-
07d0: 70 61 74 68 73 29 0a 20 20 28 69 66 20 28 6e 75 paths). (if (nu
07e0: 6c 6c 3f 20 74 65 73 74 73 2d 70 61 74 68 73 29 ll? tests-paths)
07f0: 20 0a 20 20 20 20 20 20 74 65 73 74 2d 72 65 67 . test-reg
0800: 69 73 74 72 79 0a 20 20 20 20 20 20 28 6c 65 74 istry. (let
0810: 20 6c 6f 6f 70 20 28 28 68 65 64 20 28 63 61 72 loop ((hed (car
0820: 20 74 65 73 74 73 2d 70 61 74 68 73 29 29 0a 09 tests-paths))..
0830: 09 20 28 74 61 6c 20 28 63 64 72 20 74 65 73 74 . (tal (cdr test
0840: 73 2d 70 61 74 68 73 29 29 29 0a 09 28 69 66 20 s-paths)))..(if
0850: 28 66 69 6c 65 2d 65 78 69 73 74 73 3f 20 68 65 (file-exists? he
0860: 64 29 0a 09 20 20 20 20 28 66 6f 72 2d 65 61 63 d).. (for-eac
0870: 68 20 28 6c 61 6d 62 64 61 20 28 74 65 73 74 2d h (lambda (test-
0880: 70 61 74 68 29 0a 09 09 09 28 6c 65 74 2a 20 28 path)....(let* (
0890: 28 74 6e 61 6d 65 20 20 20 28 6c 61 73 74 20 28 (tname (last (
08a0: 73 74 72 69 6e 67 2d 73 70 6c 69 74 20 74 65 73 string-split tes
08b0: 74 2d 70 61 74 68 20 22 2f 22 29 29 29 0a 09 09 t-path "/")))...
08c0: 09 20 20 20 20 20 20 20 28 74 63 6f 6e 66 69 67 . (tconfig
08d0: 20 28 63 6f 6e 63 20 74 65 73 74 2d 70 61 74 68 (conc test-path
08e0: 20 22 2f 74 65 73 74 63 6f 6e 66 69 67 22 29 29 "/testconfig"))
08f0: 29 0a 09 09 09 20 20 28 69 66 20 28 61 6e 64 20 ).... (if (and
0900: 28 6e 6f 74 20 28 68 61 73 68 2d 74 61 62 6c 65 (not (hash-table
0910: 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 74 65 73 -ref/default tes
0920: 74 2d 72 65 67 69 73 74 72 79 20 74 6e 61 6d 65 t-registry tname
0930: 20 23 66 29 29 0a 09 09 09 09 20 20 20 28 66 69 #f))..... (fi
0940: 6c 65 2d 65 78 69 73 74 73 3f 20 74 63 6f 6e 66 le-exists? tconf
0950: 69 67 29 29 0a 09 09 09 20 20 20 20 20 20 28 68 ig)).... (h
0960: 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 74 ash-table-set! t
0970: 65 73 74 2d 72 65 67 69 73 74 72 79 20 74 6e 61 est-registry tna
0980: 6d 65 20 74 65 73 74 2d 70 61 74 68 29 29 29 29 me test-path))))
0990: 0a 09 09 20 20 20 20 20 20 28 67 6c 6f 62 20 28 ... (glob (
09a0: 63 6f 6e 63 20 68 65 64 20 22 2f 2a 22 29 29 29 conc hed "/*")))
09b0: 29 0a 09 28 69 66 20 28 6e 75 6c 6c 3f 20 74 61 )..(if (null? ta
09c0: 6c 29 0a 09 20 20 20 20 74 65 73 74 2d 72 65 67 l).. test-reg
09d0: 69 73 74 72 79 0a 09 20 20 20 20 28 6c 6f 6f 70 istry.. (loop
09e0: 20 28 63 61 72 20 74 61 6c 29 28 63 64 72 20 74 (car tal)(cdr t
09f0: 61 6c 29 29 29 29 29 29 0a 0a 28 64 65 66 69 6e al))))))..(defin
0a00: 65 20 28 74 65 73 74 73 3a 66 69 6c 74 65 72 2d e (tests:filter-
0a10: 74 65 73 74 2d 6e 61 6d 65 73 20 74 65 73 74 2d test-names test-
0a20: 6e 61 6d 65 73 20 74 65 73 74 2d 70 61 74 74 73 names test-patts
0a30: 29 0a 20 20 28 64 65 6c 65 74 65 2d 64 75 70 6c ). (delete-dupl
0a40: 69 63 61 74 65 73 0a 20 20 20 28 66 69 6c 74 65 icates. (filte
0a50: 72 20 28 6c 61 6d 62 64 61 20 28 74 65 73 74 6e r (lambda (testn
0a60: 61 6d 65 29 0a 09 20 20 20 20 20 28 74 65 73 74 ame).. (test
0a70: 73 3a 6d 61 74 63 68 20 74 65 73 74 2d 70 61 74 s:match test-pat
0a80: 74 73 20 74 65 73 74 6e 61 6d 65 20 23 66 29 29 ts testname #f))
0a90: 0a 09 20 20 20 74 65 73 74 2d 6e 61 6d 65 73 29 .. test-names)
0aa0: 29 29 0a 0a 3b 3b 20 69 74 65 6d 6d 61 70 20 69 ))..;; itemmap i
0ab0: 73 20 61 20 6c 69 73 74 20 6f 66 20 74 65 73 74 s a list of test
0ac0: 6e 61 6d 65 20 70 61 74 74 65 72 6e 73 20 74 6f name patterns to
0ad0: 20 6d 61 70 73 0a 3b 3b 20 20 20 20 20 74 65 73 maps.;; tes
0ae0: 74 31 20 2e 2a 2f 62 61 72 2f 28 5c 64 2b 29 20 t1 .*/bar/(\d+)
0af0: 66 6f 6f 2f 5c 31 0a 3b 3b 20 20 20 20 20 25 20 foo/\1.;; %
0b00: 20 20 20 20 66 6f 6f 2f 28 5b 5e 2f 5d 2b 29 20 foo/([^/]+)
0b10: 20 5c 31 2f 62 61 72 0a 3b 3b 0a 3b 3b 20 23 20 \1/bar.;;.;; #
0b20: 4e 4f 54 45 3a 20 74 68 65 20 6c 69 6e 65 20 77 NOTE: the line w
0b30: 69 74 68 20 74 68 65 20 73 69 6e 67 6c 65 20 25 ith the single %
0b40: 20 63 6f 75 6c 64 20 62 65 20 74 68 65 20 72 65 could be the re
0b50: 73 75 6c 74 20 6f 66 0a 3b 3b 20 23 20 20 20 20 sult of.;; #
0b60: 20 20 20 69 74 65 6d 6d 61 70 20 65 6e 74 72 79 itemmap entry
0b70: 20 69 6e 20 72 65 71 75 69 72 65 6d 65 6e 74 73 in requirements
0b80: 20 28 6c 65 67 61 63 79 29 2e 20 54 68 65 20 69 (legacy). The i
0b90: 74 65 6d 6d 61 70 0a 3b 3b 20 23 20 20 20 20 20 temmap.;; #
0ba0: 20 20 72 65 71 75 69 72 65 6d 65 6e 74 73 20 65 requirements e
0bb0: 6e 74 72 79 20 69 73 20 64 65 70 72 65 63 61 74 ntry is deprecat
0bc0: 65 64 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 74 ed.;;.(define (t
0bd0: 65 73 74 73 3a 67 65 74 2d 69 74 65 6d 6d 61 70 ests:get-itemmap
0be0: 73 20 74 63 6f 6e 66 69 67 29 0a 20 20 28 6c 65 s tconfig). (le
0bf0: 74 20 28 28 62 61 73 65 2d 69 74 65 6d 6d 61 70 t ((base-itemmap
0c00: 20 20 28 63 6f 6e 66 69 67 66 3a 6c 6f 6f 6b 75 (configf:looku
0c10: 70 20 74 63 6f 6e 66 69 67 20 22 72 65 71 75 69 p tconfig "requi
0c20: 72 65 6d 65 6e 74 73 22 20 22 69 74 65 6d 6d 61 rements" "itemma
0c30: 70 22 29 29 0a 09 28 69 74 65 6d 6d 61 70 2d 74 p"))..(itemmap-t
0c40: 61 62 6c 65 20 28 63 6f 6e 66 69 67 66 3a 67 65 able (configf:ge
0c50: 74 2d 73 65 63 74 69 6f 6e 20 74 63 6f 6e 66 69 t-section tconfi
0c60: 67 20 22 69 74 65 6d 6d 61 70 22 29 29 29 0a 20 g "itemmap"))).
0c70: 20 20 20 28 61 70 70 65 6e 64 20 28 69 66 20 62 (append (if b
0c80: 61 73 65 2d 69 74 65 6d 6d 61 70 0a 09 09 28 6c ase-itemmap...(l
0c90: 69 73 74 20 28 6c 69 73 74 20 22 25 22 20 62 61 ist (list "%" ba
0ca0: 73 65 2d 69 74 65 6d 6d 61 70 29 29 0a 09 09 27 se-itemmap))...'
0cb0: 28 29 29 0a 09 20 20 20 20 28 69 66 20 69 74 65 ()).. (if ite
0cc0: 6d 6d 61 70 2d 74 61 62 6c 65 0a 09 09 69 74 65 mmap-table...ite
0cd0: 6d 6d 61 70 2d 74 61 62 6c 65 0a 09 09 27 28 29 mmap-table...'()
0ce0: 29 29 29 29 0a 0a 3b 3b 20 67 69 76 65 6e 20 61 ))))..;; given a
0cf0: 20 6c 69 73 74 20 6f 66 20 69 74 65 6d 6d 61 70 list of itemmap
0d00: 73 20 28 74 65 73 74 6e 61 6d 65 20 2e 20 6d 61 s (testname . ma
0d10: 70 29 2c 20 72 65 74 75 72 6e 20 74 68 65 20 66 p), return the f
0d20: 69 72 73 74 20 6d 61 74 63 68 0a 3b 3b 0a 28 64 irst match.;;.(d
0d30: 65 66 69 6e 65 20 28 74 65 73 74 73 3a 6c 6f 6f efine (tests:loo
0d40: 6b 75 70 2d 69 74 65 6d 6d 61 70 20 69 74 65 6d kup-itemmap item
0d50: 6d 61 70 73 20 74 65 73 74 6e 61 6d 65 29 0a 20 maps testname).
0d60: 20 28 6c 65 74 20 28 28 62 65 73 74 2d 6d 61 74 (let ((best-mat
0d70: 63 68 65 73 20 28 66 69 6c 74 65 72 20 28 6c 61 ches (filter (la
0d80: 6d 62 64 61 20 28 69 74 65 6d 6d 61 70 29 0a 09 mbda (itemmap)..
0d90: 09 09 09 28 74 65 73 74 73 3a 6d 61 74 63 68 20 ...(tests:match
0da0: 28 63 61 72 20 69 74 65 6d 6d 61 70 29 20 74 65 (car itemmap) te
0db0: 73 74 6e 61 6d 65 20 23 66 29 29 0a 09 09 09 20 stname #f))....
0dc0: 20 20 20 20 20 69 74 65 6d 6d 61 70 73 29 29 29 itemmaps)))
0dd0: 0a 20 20 20 20 28 69 66 20 28 6e 75 6c 6c 3f 20 . (if (null?
0de0: 62 65 73 74 2d 6d 61 74 63 68 65 73 29 0a 09 23 best-matches)..#
0df0: 66 0a 09 28 6c 65 74 20 28 28 72 65 73 20 28 63 f..(let ((res (c
0e00: 61 72 20 62 65 73 74 2d 6d 61 74 63 68 65 73 29 ar best-matches)
0e10: 29 29 0a 09 20 20 3b 3b 20 28 64 65 62 75 67 3a )).. ;; (debug:
0e20: 70 72 69 6e 74 20 30 20 22 72 65 73 3d 22 20 72 print 0 "res=" r
0e30: 65 73 29 0a 09 20 20 28 63 6f 6e 64 0a 09 20 20 es).. (cond..
0e40: 20 28 28 73 74 72 69 6e 67 3f 20 72 65 73 29 20 ((string? res)
0e50: 72 65 73 29 20 3b 3b 3b 20 46 49 58 20 54 48 45 res) ;;; FIX THE
0e60: 20 52 4f 4f 54 20 43 41 55 53 45 20 48 45 52 45 ROOT CAUSE HERE
0e70: 20 2e 2e 2e 2e 0a 09 20 20 20 28 28 6e 75 6c 6c ...... ((null
0e80: 3f 20 72 65 73 29 20 20 20 23 66 29 0a 09 20 20 ? res) #f)..
0e90: 20 28 28 73 74 72 69 6e 67 3f 20 28 63 64 72 20 ((string? (cdr
0ea0: 72 65 73 29 29 20 28 63 64 72 20 72 65 73 29 29 res)) (cdr res))
0eb0: 20 20 3b 3b 20 69 74 20 69 73 20 61 20 70 61 69 ;; it is a pai
0ec0: 72 0a 09 20 20 20 28 28 73 74 72 69 6e 67 3f 20 r.. ((string?
0ed0: 28 63 61 64 72 20 72 65 73 29 29 28 63 61 64 72 (cadr res))(cadr
0ee0: 20 72 65 73 29 29 20 3b 3b 20 69 74 20 69 73 20 res)) ;; it is
0ef0: 61 20 6c 69 73 74 0a 09 20 20 20 28 65 6c 73 65 a list.. (else
0f00: 20 63 61 64 72 20 72 65 73 29 29 29 29 29 29 0a cadr res)))))).
0f10: 0a 3b 3b 20 72 65 74 75 72 6e 20 69 74 65 6d 73 .;; return items
0f20: 20 67 69 76 65 6e 20 63 6f 6e 66 69 67 0a 3b 3b given config.;;
0f30: 0a 28 64 65 66 69 6e 65 20 28 74 65 73 74 73 3a .(define (tests:
0f40: 67 65 74 2d 69 74 65 6d 73 20 74 63 6f 6e 66 69 get-items tconfi
0f50: 67 29 0a 20 20 28 6c 65 74 20 28 28 69 74 65 6d g). (let ((item
0f60: 73 20 20 20 20 20 20 28 68 61 73 68 2d 74 61 62 s (hash-tab
0f70: 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 74 le-ref/default t
0f80: 63 6f 6e 66 69 67 20 22 69 74 65 6d 73 22 20 23 config "items" #
0f90: 66 29 29 20 3b 3b 20 69 74 65 6d 73 20 34 0a 09 f)) ;; items 4..
0fa0: 28 69 74 65 6d 73 74 61 62 6c 65 20 28 68 61 73 (itemstable (has
0fb0: 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 h-table-ref/defa
0fc0: 75 6c 74 20 74 63 6f 6e 66 69 67 20 22 69 74 65 ult tconfig "ite
0fd0: 6d 73 74 61 62 6c 65 22 20 23 66 29 29 29 20 0a mstable" #f))) .
0fe0: 20 20 20 20 3b 3b 20 69 66 20 65 69 74 68 65 72 ;; if either
0ff0: 20 69 74 65 6d 73 20 6f 72 20 69 74 65 6d 73 20 items or items
1000: 74 61 62 6c 65 20 69 73 20 61 20 70 72 6f 63 20 table is a proc
1010: 72 65 74 75 72 6e 20 69 74 20 73 6f 20 74 65 73 return it so tes
1020: 74 20 72 75 6e 6e 69 6e 67 0a 20 20 20 20 3b 3b t running. ;;
1030: 20 70 72 6f 63 65 73 73 20 63 61 6e 20 6b 6e 6f process can kno
1040: 77 20 74 6f 20 63 61 6c 6c 20 69 74 65 6d 73 3a w to call items:
1050: 67 65 74 2d 69 74 65 6d 73 2d 66 72 6f 6d 2d 63 get-items-from-c
1060: 6f 6e 66 69 67 0a 20 20 20 20 3b 3b 20 69 66 20 onfig. ;; if
1070: 65 69 74 68 65 72 20 69 73 20 61 20 6c 69 73 74 either is a list
1080: 20 61 6e 64 20 6e 6f 6e 65 20 69 73 20 61 20 70 and none is a p
1090: 72 6f 63 20 67 6f 20 61 68 65 61 64 20 61 6e 64 roc go ahead and
10a0: 20 63 61 6c 6c 20 67 65 74 2d 69 74 65 6d 73 0a call get-items.
10b0: 20 20 20 20 3b 3b 20 6f 74 68 65 72 77 69 73 65 ;; otherwise
10c0: 20 72 65 74 75 72 6e 20 23 66 20 2d 20 74 68 69 return #f - thi
10d0: 73 20 69 73 20 6e 6f 74 20 61 6e 20 69 74 65 72 s is not an iter
10e0: 61 74 65 64 20 74 65 73 74 0a 20 20 20 20 28 63 ated test. (c
10f0: 6f 6e 64 0a 20 20 20 20 20 28 28 70 72 6f 63 65 ond. ((proce
1100: 64 75 72 65 3f 20 69 74 65 6d 73 29 20 20 20 20 dure? items)
1110: 20 20 0a 20 20 20 20 20 20 28 64 65 62 75 67 3a . (debug:
1120: 70 72 69 6e 74 2d 69 6e 66 6f 20 34 20 22 69 74 print-info 4 "it
1130: 65 6d 73 20 69 73 20 61 20 70 72 6f 63 65 64 75 ems is a procedu
1140: 72 65 2c 20 77 69 6c 6c 20 63 61 6c 63 20 6c 61 re, will calc la
1150: 74 65 72 22 29 0a 20 20 20 20 20 20 69 74 65 6d ter"). item
1160: 73 29 20 20 20 20 20 20 20 20 20 20 20 20 3b 3b s) ;;
1170: 20 63 61 6c 63 20 6c 61 74 65 72 0a 20 20 20 20 calc later.
1180: 20 28 28 70 72 6f 63 65 64 75 72 65 3f 20 69 74 ((procedure? it
1190: 65 6d 73 74 61 62 6c 65 29 0a 20 20 20 20 20 20 emstable).
11a0: 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 (debug:print-inf
11b0: 6f 20 34 20 22 69 74 65 6d 73 74 61 62 6c 65 20 o 4 "itemstable
11c0: 69 73 20 61 20 70 72 6f 63 65 64 75 72 65 2c 20 is a procedure,
11d0: 77 69 6c 6c 20 63 61 6c 63 20 6c 61 74 65 72 22 will calc later"
11e0: 29 0a 20 20 20 20 20 20 69 74 65 6d 73 74 61 62 ). itemstab
11f0: 6c 65 29 20 20 20 20 20 20 20 3b 3b 20 63 61 6c le) ;; cal
1200: 63 20 6c 61 74 65 72 0a 20 20 20 20 20 28 28 66 c later. ((f
1210: 69 6c 74 65 72 20 28 6c 61 6d 62 64 61 20 28 78 ilter (lambda (x
1220: 29 0a 09 09 28 6c 65 74 20 28 28 76 61 6c 20 28 )...(let ((val (
1230: 63 61 72 20 78 29 29 29 0a 09 09 20 20 28 69 66 car x)))... (if
1240: 20 28 70 72 6f 63 65 64 75 72 65 3f 20 76 61 6c (procedure? val
1250: 29 20 76 61 6c 20 23 66 29 29 29 0a 09 20 20 20 ) val #f)))..
1260: 20 20 20 28 61 70 70 65 6e 64 20 28 69 66 20 28 (append (if (
1270: 6c 69 73 74 3f 20 69 74 65 6d 73 29 20 69 74 65 list? items) ite
1280: 6d 73 20 27 28 29 29 0a 09 09 20 20 20 20 20 20 ms '())...
1290: 28 69 66 20 28 6c 69 73 74 3f 20 69 74 65 6d 73 (if (list? items
12a0: 74 61 62 6c 65 29 20 69 74 65 6d 73 74 61 62 6c table) itemstabl
12b0: 65 20 27 28 29 29 29 29 0a 20 20 20 20 20 20 27 e '()))). '
12c0: 68 61 76 65 2d 70 72 6f 63 65 64 75 72 65 29 0a have-procedure).
12d0: 20 20 20 20 20 28 28 6f 72 20 28 6c 69 73 74 3f ((or (list?
12e0: 20 69 74 65 6d 73 29 28 6c 69 73 74 3f 20 69 74 items)(list? it
12f0: 65 6d 73 74 61 62 6c 65 29 29 20 3b 3b 20 63 61 emstable)) ;; ca
1300: 6c 63 20 6e 6f 77 0a 20 20 20 20 20 20 28 64 65 lc now. (de
1310: 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 34 bug:print-info 4
1320: 20 22 69 74 65 6d 73 20 61 6e 64 20 69 74 65 6d "items and item
1330: 73 74 61 62 6c 65 20 61 72 65 20 6c 69 73 74 73 stable are lists
1340: 2c 20 63 61 6c 63 20 6e 6f 77 5c 6e 22 0a 09 09 , calc now\n"...
1350: 09 22 20 20 20 20 69 74 65 6d 73 3a 20 22 20 69 ." items: " i
1360: 74 65 6d 73 20 22 20 69 74 65 6d 73 74 61 62 6c tems " itemstabl
1370: 65 3a 20 22 20 69 74 65 6d 73 74 61 62 6c 65 29 e: " itemstable)
1380: 0a 20 20 20 20 20 20 28 69 74 65 6d 73 3a 67 65 . (items:ge
1390: 74 2d 69 74 65 6d 73 2d 66 72 6f 6d 2d 63 6f 6e t-items-from-con
13a0: 66 69 67 20 74 63 6f 6e 66 69 67 29 29 0a 20 20 fig tconfig)).
13b0: 20 20 20 28 65 6c 73 65 20 23 66 29 29 29 29 20 (else #f))))
13c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
13d0: 20 20 20 20 20 20 20 20 20 20 3b 3b 20 6e 6f 74 ;; not
13e0: 20 69 74 65 72 61 74 65 64 0a 0a 0a 3b 3b 20 72 iterated...;; r
13f0: 65 74 75 72 6e 73 20 77 61 69 74 6f 6e 73 20 77 eturns waitons w
1400: 61 69 74 6f 72 73 20 74 63 6f 6e 66 69 67 64 61 aitors tconfigda
1410: 74 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 74 65 t.;;.(define (te
1420: 73 74 73 3a 67 65 74 2d 77 61 69 74 6f 6e 73 20 sts:get-waitons
1430: 74 65 73 74 2d 6e 61 6d 65 20 61 6c 6c 2d 74 65 test-name all-te
1440: 73 74 73 2d 72 65 67 69 73 74 72 79 29 0a 20 20 sts-registry).
1450: 20 28 6c 65 74 2a 20 28 28 63 6f 6e 66 69 67 20 (let* ((config
1460: 20 28 74 65 73 74 73 3a 67 65 74 2d 74 65 73 74 (tests:get-test
1470: 63 6f 6e 66 69 67 20 74 65 73 74 2d 6e 61 6d 65 config test-name
1480: 20 61 6c 6c 2d 74 65 73 74 73 2d 72 65 67 69 73 all-tests-regis
1490: 74 72 79 20 27 72 65 74 75 72 6e 2d 70 72 6f 63 try 'return-proc
14a0: 73 29 29 29 0a 20 20 20 20 20 28 6c 65 74 20 28 s))). (let (
14b0: 28 69 6e 73 74 72 20 28 69 66 20 63 6f 6e 66 69 (instr (if confi
14c0: 67 20 0a 09 09 20 20 20 20 20 20 28 63 6f 6e 66 g ... (conf
14d0: 69 67 2d 6c 6f 6f 6b 75 70 20 63 6f 6e 66 69 67 ig-lookup config
14e0: 20 22 72 65 71 75 69 72 65 6d 65 6e 74 73 22 20 "requirements"
14f0: 22 77 61 69 74 6f 6e 22 29 0a 09 09 20 20 20 20 "waiton")...
1500: 20 20 28 62 65 67 69 6e 20 3b 3b 20 4e 6f 20 63 (begin ;; No c
1510: 6f 6e 66 69 67 20 6d 65 61 6e 73 20 74 68 69 73 onfig means this
1520: 20 69 73 20 61 20 6e 6f 6e 2d 65 78 69 73 74 61 is a non-exista
1530: 6e 74 20 74 65 73 74 0a 09 09 09 28 64 65 62 75 nt test....(debu
1540: 67 3a 70 72 69 6e 74 20 30 20 22 45 52 52 4f 52 g:print 0 "ERROR
1550: 3a 20 6e 6f 6e 2d 65 78 69 73 74 65 6e 74 20 72 : non-existent r
1560: 65 71 75 69 72 65 64 20 74 65 73 74 20 5c 22 22 equired test \""
1570: 20 74 65 73 74 2d 6e 61 6d 65 20 22 5c 22 22 29 test-name "\"")
1580: 0a 09 09 09 28 65 78 69 74 20 31 29 29 29 29 0a ....(exit 1)))).
1590: 09 20 20 20 28 69 6e 73 74 72 32 20 28 69 66 20 . (instr2 (if
15a0: 63 6f 6e 66 69 67 0a 09 09 20 20 20 20 20 20 20 config...
15b0: 28 63 6f 6e 66 69 67 2d 6c 6f 6f 6b 75 70 20 63 (config-lookup c
15c0: 6f 6e 66 69 67 20 22 72 65 71 75 69 72 65 6d 65 onfig "requireme
15d0: 6e 74 73 22 20 22 77 61 69 74 6f 72 22 29 0a 09 nts" "waitor")..
15e0: 09 20 20 20 20 20 20 20 22 22 29 29 29 0a 20 20 . ""))).
15f0: 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e (debug:prin
1600: 74 2d 69 6e 66 6f 20 38 20 22 77 61 69 74 6f 6e t-info 8 "waiton
1610: 73 20 73 74 72 69 6e 67 20 69 73 20 22 20 69 6e s string is " in
1620: 73 74 72 20 22 2c 20 77 61 69 74 6f 72 73 20 73 str ", waitors s
1630: 74 72 69 6e 67 20 69 73 20 22 20 69 6e 73 74 72 tring is " instr
1640: 32 29 0a 20 20 20 20 20 20 20 28 6c 65 74 20 28 2). (let (
1650: 28 6e 65 77 77 61 69 74 6f 6e 73 0a 09 20 20 20 (newwaitons..
1660: 20 20 20 28 73 74 72 69 6e 67 2d 73 70 6c 69 74 (string-split
1670: 20 28 63 6f 6e 64 0a 09 09 09 20 20 20 20 20 28 (cond.... (
1680: 28 70 72 6f 63 65 64 75 72 65 3f 20 69 6e 73 74 (procedure? inst
1690: 72 29 20 3b 3b 20 68 65 72 65 20 0a 09 09 09 20 r) ;; here ....
16a0: 20 20 20 20 20 28 6c 65 74 20 28 28 72 65 73 20 (let ((res
16b0: 28 69 6e 73 74 72 29 29 29 0a 09 09 09 09 28 64 (instr))).....(d
16c0: 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 ebug:print-info
16d0: 38 20 22 77 61 69 74 6f 6e 20 70 72 6f 63 65 64 8 "waiton proced
16e0: 75 72 65 20 72 65 73 75 6c 74 73 20 69 6e 20 73 ure results in s
16f0: 74 72 69 6e 67 20 22 20 72 65 73 20 22 20 66 6f tring " res " fo
1700: 72 20 74 65 73 74 20 22 20 74 65 73 74 2d 6e 61 r test " test-na
1710: 6d 65 29 0a 09 09 09 09 72 65 73 29 29 0a 09 09 me).....res))...
1720: 09 20 20 20 20 20 28 28 73 74 72 69 6e 67 3f 20 . ((string?
1730: 69 6e 73 74 72 29 20 20 20 20 20 69 6e 73 74 72 instr) instr
1740: 29 0a 09 09 09 20 20 20 20 20 28 65 6c 73 65 20 ).... (else
1750: 0a 09 09 09 20 20 20 20 20 20 3b 3b 20 4e 4f 54 .... ;; NOT
1760: 45 3a 20 54 68 69 73 20 69 73 20 61 63 74 75 61 E: This is actua
1770: 6c 6c 79 20 74 68 65 20 63 61 73 65 20 6f 66 20 lly the case of
1780: 2a 6e 6f 2a 20 77 61 69 74 6f 6e 73 21 20 3b 3b *no* waitons! ;;
1790: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 (debug:print 0
17a0: 22 45 52 52 4f 52 3a 20 73 6f 6d 65 74 68 69 6e "ERROR: somethin
17b0: 67 20 77 65 6e 74 20 77 72 6f 6e 67 20 69 6e 20 g went wrong in
17c0: 70 72 6f 63 65 73 73 69 6e 67 20 77 61 69 74 6f processing waito
17d0: 6e 73 20 66 6f 72 20 74 65 73 74 20 22 20 74 65 ns for test " te
17e0: 73 74 2d 6e 61 6d 65 29 0a 09 09 09 20 20 20 20 st-name)....
17f0: 20 20 22 22 29 29 29 29 0a 09 20 20 20 20 20 28 "")))).. (
1800: 6e 65 77 77 61 69 74 6f 72 73 0a 09 20 20 20 20 newwaitors..
1810: 20 20 28 73 74 72 69 6e 67 2d 73 70 6c 69 74 20 (string-split
1820: 28 63 6f 6e 64 0a 09 09 09 20 20 20 20 20 28 28 (cond.... ((
1830: 70 72 6f 63 65 64 75 72 65 3f 20 69 6e 73 74 72 procedure? instr
1840: 32 29 0a 09 09 09 20 20 20 20 20 20 28 6c 65 74 2).... (let
1850: 20 28 28 72 65 73 20 28 69 6e 73 74 72 32 29 29 ((res (instr2))
1860: 29 0a 09 09 09 09 28 64 65 62 75 67 3a 70 72 69 ).....(debug:pri
1870: 6e 74 2d 69 6e 66 6f 20 38 20 22 77 61 69 74 6f nt-info 8 "waito
1880: 72 20 70 72 6f 63 65 64 75 72 65 20 72 65 73 75 r procedure resu
1890: 6c 74 73 20 69 6e 20 73 74 72 69 6e 67 20 22 20 lts in string "
18a0: 72 65 73 20 22 20 66 6f 72 20 74 65 73 74 20 22 res " for test "
18b0: 20 74 65 73 74 2d 6e 61 6d 65 29 0a 09 09 09 09 test-name).....
18c0: 72 65 73 29 29 0a 09 09 09 20 20 20 20 20 28 28 res)).... ((
18d0: 73 74 72 69 6e 67 3f 20 69 6e 73 74 72 32 29 20 string? instr2)
18e0: 20 20 20 20 69 6e 73 74 72 32 29 0a 09 09 09 20 instr2)....
18f0: 20 20 20 20 28 65 6c 73 65 20 0a 09 09 09 20 20 (else ....
1900: 20 20 20 20 3b 3b 20 4e 4f 54 45 3a 20 54 68 69 ;; NOTE: Thi
1910: 73 20 69 73 20 61 63 74 75 61 6c 6c 79 20 74 68 s is actually th
1920: 65 20 63 61 73 65 20 6f 66 20 2a 6e 6f 2a 20 77 e case of *no* w
1930: 61 69 74 6f 6e 73 21 20 3b 3b 20 28 64 65 62 75 aitons! ;; (debu
1940: 67 3a 70 72 69 6e 74 20 30 20 22 45 52 52 4f 52 g:print 0 "ERROR
1950: 3a 20 73 6f 6d 65 74 68 69 6e 67 20 77 65 6e 74 : something went
1960: 20 77 72 6f 6e 67 20 69 6e 20 70 72 6f 63 65 73 wrong in proces
1970: 73 69 6e 67 20 77 61 69 74 6f 6e 73 20 66 6f 72 sing waitons for
1980: 20 74 65 73 74 20 22 20 74 65 73 74 2d 6e 61 6d test " test-nam
1990: 65 29 0a 09 09 09 20 20 20 20 20 20 22 22 29 29 e).... ""))
19a0: 29 29 29 0a 09 20 28 76 61 6c 75 65 73 0a 09 20 ))).. (values..
19b0: 20 3b 3b 20 74 68 65 20 77 61 69 74 6f 6e 73 0a ;; the waitons.
19c0: 09 20 20 28 66 69 6c 74 65 72 20 28 6c 61 6d 62 . (filter (lamb
19d0: 64 61 20 28 78 29 0a 09 09 20 20 20 20 28 69 66 da (x)... (if
19e0: 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 (hash-table-ref
19f0: 2f 64 65 66 61 75 6c 74 20 61 6c 6c 2d 74 65 73 /default all-tes
1a00: 74 73 2d 72 65 67 69 73 74 72 79 20 78 20 23 66 ts-registry x #f
1a10: 29 0a 09 09 09 23 74 0a 09 09 09 28 62 65 67 69 )....#t....(begi
1a20: 6e 0a 09 09 09 20 20 28 64 65 62 75 67 3a 70 72 n.... (debug:pr
1a30: 69 6e 74 20 30 20 22 45 52 52 4f 52 3a 20 74 65 int 0 "ERROR: te
1a40: 73 74 20 22 20 74 65 73 74 2d 6e 61 6d 65 20 22 st " test-name "
1a50: 20 68 61 73 20 75 6e 72 65 63 6f 67 6e 69 73 65 has unrecognise
1a60: 64 20 77 61 69 74 6f 6e 20 74 65 73 74 6e 61 6d d waiton testnam
1a70: 65 20 22 20 78 29 0a 09 09 09 20 20 23 66 29 29 e " x).... #f))
1a80: 29 0a 09 09 20 20 6e 65 77 77 61 69 74 6f 6e 73 )... newwaitons
1a90: 29 0a 09 20 20 28 66 69 6c 74 65 72 20 28 6c 61 ).. (filter (la
1aa0: 6d 62 64 61 20 28 78 29 0a 09 09 20 20 20 20 28 mbda (x)... (
1ab0: 69 66 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 if (hash-table-r
1ac0: 65 66 2f 64 65 66 61 75 6c 74 20 61 6c 6c 2d 74 ef/default all-t
1ad0: 65 73 74 73 2d 72 65 67 69 73 74 72 79 20 78 20 ests-registry x
1ae0: 23 66 29 0a 09 09 09 23 74 0a 09 09 09 28 62 65 #f)....#t....(be
1af0: 67 69 6e 0a 09 09 09 20 20 28 64 65 62 75 67 3a gin.... (debug:
1b00: 70 72 69 6e 74 20 30 20 22 45 52 52 4f 52 3a 20 print 0 "ERROR:
1b10: 74 65 73 74 20 22 20 74 65 73 74 2d 6e 61 6d 65 test " test-name
1b20: 20 22 20 68 61 73 20 75 6e 72 65 63 6f 67 6e 69 " has unrecogni
1b30: 73 65 64 20 77 61 69 74 6f 6e 20 74 65 73 74 6e sed waiton testn
1b40: 61 6d 65 20 22 20 78 29 0a 09 09 09 20 20 23 66 ame " x).... #f
1b50: 29 29 29 0a 09 09 20 20 6e 65 77 77 61 69 74 6f )))... newwaito
1b60: 72 73 29 0a 09 20 20 63 6f 6e 66 69 67 29 29 29 rs).. config)))
1b70: 29 29 0a 09 09 09 09 09 20 20 20 20 20 0a 3b 3b ))...... .;;
1b80: 20 67 69 76 65 6e 20 77 61 69 74 69 6e 67 2d 74 given waiting-t
1b90: 65 73 74 20 74 68 61 74 20 69 73 20 77 61 69 74 est that is wait
1ba0: 69 6e 67 20 6f 6e 20 77 61 69 74 6f 6e 2d 74 65 ing on waiton-te
1bb0: 73 74 20 65 78 74 65 6e 64 20 74 65 73 74 2d 70 st extend test-p
1bc0: 61 74 74 20 61 70 70 72 6f 70 72 69 61 74 65 6c att appropriatel
1bd0: 79 0a 3b 3b 0a 3b 3b 20 20 67 65 6e 6c 69 62 2f y.;;.;; genlib/
1be0: 74 65 73 74 63 6f 6e 66 69 67 20 20 20 20 20 20 testconfig
1bf0: 20 20 20 20 20 20 20 20 20 73 69 6d 2f 74 65 73 sim/tes
1c00: 74 63 6f 6e 66 69 67 0a 3b 3b 20 20 67 65 6e 6c tconfig.;; genl
1c10: 69 62 2f 73 63 68 20 20 20 20 20 20 20 20 20 20 ib/sch
1c20: 20 20 20 20 20 20 20 20 20 20 20 20 73 69 6d 2f sim/
1c30: 73 63 68 2f 63 65 6c 6c 31 0a 3b 3b 0a 3b 3b 20 sch/cell1.;;.;;
1c40: 20 5b 72 65 71 75 69 72 65 6d 65 6e 74 73 5d 20 [requirements]
1c50: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1c60: 20 5b 72 65 71 75 69 72 65 6d 65 6e 74 73 5d 0a [requirements].
1c70: 3b 3b 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ;;
1c80: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1c90: 20 20 20 20 6d 6f 64 65 20 69 74 65 6d 77 61 69 mode itemwai
1ca0: 74 0a 3b 3b 20 20 20 20 20 20 20 20 20 20 20 20 t.;;
1cb0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1cc0: 20 20 20 20 20 20 23 20 74 72 69 6d 20 6f 66 66 # trim off
1cd0: 20 74 68 65 20 63 65 6c 6c 20 74 6f 20 64 65 74 the cell to det
1ce0: 65 72 6d 69 6e 65 20 77 68 61 74 20 74 6f 20 72 ermine what to r
1cf0: 75 6e 20 66 6f 72 20 67 65 6e 6c 69 62 0a 3b 3b un for genlib.;;
1d00: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1d10: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1d20: 20 20 69 74 65 6d 6d 61 70 20 2f 2e 2a 0a 3b 3b itemmap /.*.;;
1d30: 0a 3b 3b 20 20 20 20 20 20 20 20 20 20 20 20 20 .;;
1d40: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1d50: 20 20 20 20 20 77 61 69 74 69 6e 67 2d 74 65 73 waiting-tes
1d60: 74 20 69 73 20 77 61 69 74 69 6e 67 20 6f 6e 20 t is waiting on
1d70: 77 61 69 74 6f 6e 2d 74 65 73 74 20 73 6f 20 77 waiton-test so w
1d80: 65 20 6e 65 65 64 20 74 6f 20 63 72 65 61 74 65 e need to create
1d90: 20 61 20 70 61 74 74 65 72 6e 20 66 6f 72 20 77 a pattern for w
1da0: 61 69 74 6f 6e 2d 74 65 73 74 20 67 69 76 65 6e aiton-test given
1db0: 20 77 61 69 74 69 6e 67 2d 74 65 73 74 20 61 6e waiting-test an
1dc0: 64 20 69 74 65 6d 6d 61 70 0a 28 64 65 66 69 6e d itemmap.(defin
1dd0: 65 20 28 74 65 73 74 73 3a 65 78 74 65 6e 64 2d e (tests:extend-
1de0: 74 65 73 74 2d 70 61 74 74 73 20 74 65 73 74 2d test-patts test-
1df0: 70 61 74 74 20 77 61 69 74 69 6e 67 2d 74 65 73 patt waiting-tes
1e00: 74 20 77 61 69 74 6f 6e 2d 74 65 73 74 20 69 74 t waiton-test it
1e10: 65 6d 6d 61 70 73 29 0a 20 20 28 6c 65 74 2a 20 emmaps). (let*
1e20: 28 28 69 74 65 6d 6d 61 70 20 20 20 20 20 20 20 ((itemmap
1e30: 20 20 20 28 74 65 73 74 73 3a 6c 6f 6f 6b 75 70 (tests:lookup
1e40: 2d 69 74 65 6d 6d 61 70 20 69 74 65 6d 6d 61 70 -itemmap itemmap
1e50: 73 20 77 61 69 74 6f 6e 2d 74 65 73 74 29 29 0a s waiton-test)).
1e60: 09 20 28 70 61 74 74 73 20 20 20 20 20 20 20 20 . (patts
1e70: 20 20 20 20 28 73 74 72 69 6e 67 2d 73 70 6c 69 (string-spli
1e80: 74 20 74 65 73 74 2d 70 61 74 74 20 22 2c 22 29 t test-patt ",")
1e90: 29 0a 09 20 28 77 61 69 74 69 6e 67 2d 74 65 73 ).. (waiting-tes
1ea0: 74 2d 6c 65 6e 20 28 2b 20 28 73 74 72 69 6e 67 t-len (+ (string
1eb0: 2d 6c 65 6e 67 74 68 20 77 61 69 74 69 6e 67 2d -length waiting-
1ec0: 74 65 73 74 29 20 31 29 29 0a 09 20 28 70 61 74 test) 1)).. (pat
1ed0: 74 73 2d 77 61 69 74 6f 6e 20 20 20 20 20 28 6d ts-waiton (m
1ee0: 61 70 20 28 6c 61 6d 62 64 61 20 28 78 29 20 20 ap (lambda (x)
1ef0: 3b 3b 20 66 6f 72 20 65 61 63 68 20 69 6e 63 6f ;; for each inco
1f00: 6d 69 6e 67 20 70 61 74 74 20 74 68 61 74 20 6d ming patt that m
1f10: 61 74 63 68 65 73 20 74 68 65 20 77 61 69 74 69 atches the waiti
1f20: 6e 67 20 74 65 73 74 0a 09 09 09 09 20 20 28 6c ng test..... (l
1f30: 65 74 2a 20 28 28 6d 6f 64 70 61 74 74 20 28 69 et* ((modpatt (i
1f40: 66 20 69 74 65 6d 6d 61 70 20 28 64 62 3a 63 6f f itemmap (db:co
1f50: 6e 76 65 72 74 2d 74 65 73 74 2d 69 74 65 6d 70 nvert-test-itemp
1f60: 61 74 68 20 78 20 69 74 65 6d 6d 61 70 29 20 78 ath x itemmap) x
1f70: 29 29 20 0a 09 09 09 09 09 20 28 6e 65 77 70 61 )) ...... (newpa
1f80: 74 74 20 28 63 6f 6e 63 20 77 61 69 74 6f 6e 2d tt (conc waiton-
1f90: 74 65 73 74 20 22 2f 22 20 28 73 75 62 73 74 72 test "/" (substr
1fa0: 69 6e 67 20 6d 6f 64 70 61 74 74 20 77 61 69 74 ing modpatt wait
1fb0: 69 6e 67 2d 74 65 73 74 2d 6c 65 6e 20 28 73 74 ing-test-len (st
1fc0: 72 69 6e 67 2d 6c 65 6e 67 74 68 20 6d 6f 64 70 ring-length modp
1fd0: 61 74 74 29 29 29 29 29 0a 09 09 09 09 20 20 20 att))))).....
1fe0: 20 3b 3b 20 28 63 6f 6e 63 20 77 61 69 74 69 6e ;; (conc waitin
1ff0: 67 2d 74 65 73 74 20 22 2f 2c 22 20 77 61 69 74 g-test "/," wait
2000: 69 6e 67 2d 74 65 73 74 20 22 2f 22 20 28 73 75 ing-test "/" (su
2010: 62 73 74 72 69 6e 67 20 6d 6f 64 70 61 74 74 20 bstring modpatt
2020: 77 61 69 74 6f 6e 2d 74 65 73 74 2d 6c 65 6e 20 waiton-test-len
2030: 28 73 74 72 69 6e 67 2d 6c 65 6e 67 74 68 20 6d (string-length m
2040: 6f 64 70 61 74 74 29 29 29 29 29 0a 09 09 09 09 odpatt))))).....
2050: 20 20 20 20 3b 3b 20 28 70 72 69 6e 74 20 22 69 ;; (print "i
2060: 6e 20 6d 61 70 2c 20 78 3d 22 20 78 20 22 2c 20 n map, x=" x ",
2070: 6e 65 77 70 61 74 74 3d 22 20 6e 65 77 70 61 74 newpatt=" newpat
2080: 74 29 0a 09 09 09 09 20 20 20 20 6e 65 77 70 61 t)..... newpa
2090: 74 74 29 29 0a 09 09 09 09 28 66 69 6c 74 65 72 tt)).....(filter
20a0: 20 28 6c 61 6d 62 64 61 20 28 78 29 0a 09 09 09 (lambda (x)....
20b0: 09 09 20 20 28 65 71 3f 20 28 73 75 62 73 74 72 .. (eq? (substr
20c0: 69 6e 67 2d 69 6e 64 65 78 20 28 63 6f 6e 63 20 ing-index (conc
20d0: 77 61 69 74 69 6e 67 2d 74 65 73 74 20 22 2f 22 waiting-test "/"
20e0: 29 20 78 29 20 30 29 29 20 3b 3b 20 69 73 20 74 ) x) 0)) ;; is t
20f0: 68 69 73 20 70 61 74 74 20 70 65 72 74 69 6e 65 his patt pertine
2100: 6e 74 20 74 6f 20 74 68 65 20 77 61 69 74 69 6e nt to the waitin
2110: 67 20 74 65 73 74 0a 09 09 09 09 09 70 61 74 74 g test......patt
2120: 73 29 29 29 29 0a 20 20 20 20 28 73 74 72 69 6e s)))). (strin
2130: 67 2d 69 6e 74 65 72 73 70 65 72 73 65 20 28 64 g-intersperse (d
2140: 65 6c 65 74 65 2d 64 75 70 6c 69 63 61 74 65 73 elete-duplicates
2150: 20 28 61 70 70 65 6e 64 20 70 61 74 74 73 20 28 (append patts (
2160: 69 66 20 28 6e 75 6c 6c 3f 20 70 61 74 74 73 2d if (null? patts-
2170: 77 61 69 74 6f 6e 29 0a 09 09 09 09 09 09 09 20 waiton)........
2180: 20 20 20 20 28 6c 69 73 74 20 28 63 6f 6e 63 20 (list (conc
2190: 77 61 69 74 6f 6e 2d 74 65 73 74 20 22 2f 25 22 waiton-test "/%"
21a0: 29 29 20 3b 3b 20 72 65 61 6c 6c 79 20 73 68 6f )) ;; really sho
21b0: 75 6c 64 6e 27 74 20 61 64 64 20 74 68 65 20 77 uldn't add the w
21c0: 61 69 74 6f 6e 20 66 6f 72 63 65 66 75 6c 6c 79 aiton forcefully
21d0: 20 6c 69 6b 65 20 74 68 69 73 0a 09 09 09 09 09 like this......
21e0: 09 09 20 20 20 20 20 70 61 74 74 73 2d 77 61 69 .. patts-wai
21f0: 74 6f 6e 29 29 29 0a 09 09 09 22 2c 22 29 29 29 ton)))....",")))
2200: 0a 0a 0a 20 20 0a 3b 3b 20 74 65 73 74 73 3a 67 ... .;; tests:g
2210: 6c 6f 62 2d 6c 69 6b 65 2d 6d 61 74 63 68 20 0a lob-like-match .
2220: 28 64 65 66 69 6e 65 20 28 74 65 73 74 73 3a 67 (define (tests:g
2230: 6c 6f 62 2d 6c 69 6b 65 2d 6d 61 74 63 68 20 70 lob-like-match p
2240: 61 74 74 20 73 74 72 29 20 0a 20 20 28 6c 65 74 att str) . (let
2250: 20 28 28 6c 69 6b 65 20 28 73 75 62 73 74 72 69 ((like (substri
2260: 6e 67 2d 69 6e 64 65 78 20 22 25 22 20 70 61 74 ng-index "%" pat
2270: 74 29 29 29 0a 20 20 20 20 28 6c 65 74 2a 20 28 t))). (let* (
2280: 28 6e 6f 74 70 61 74 74 20 20 28 65 71 75 61 6c (notpatt (equal
2290: 3f 20 28 73 75 62 73 74 72 69 6e 67 2d 69 6e 64 ? (substring-ind
22a0: 65 78 20 22 7e 22 20 70 61 74 74 29 20 30 29 29 ex "~" patt) 0))
22b0: 0a 09 20 20 20 28 6e 65 77 70 61 74 74 20 20 28 .. (newpatt (
22c0: 69 66 20 6e 6f 74 70 61 74 74 20 28 73 75 62 73 if notpatt (subs
22d0: 74 72 69 6e 67 20 70 61 74 74 20 31 29 20 70 61 tring patt 1) pa
22e0: 74 74 29 29 0a 09 20 20 20 28 66 69 6e 70 61 74 tt)).. (finpat
22f0: 74 20 20 28 69 66 20 6c 69 6b 65 0a 09 09 09 28 t (if like....(
2300: 73 74 72 69 6e 67 2d 73 75 62 73 74 69 74 75 74 string-substitut
2310: 65 20 28 72 65 67 65 78 70 20 22 25 22 29 20 22 e (regexp "%") "
2320: 2e 2a 22 20 6e 65 77 70 61 74 74 20 23 66 29 0a .*" newpatt #f).
2330: 09 09 09 28 73 74 72 69 6e 67 2d 73 75 62 73 74 ...(string-subst
2340: 69 74 75 74 65 20 28 72 65 67 65 78 70 20 22 5c itute (regexp "\
2350: 5c 2a 22 29 20 22 2e 2a 22 20 6e 65 77 70 61 74 \*") ".*" newpat
2360: 74 20 23 66 29 29 29 0a 09 20 20 20 28 72 65 73 t #f))).. (res
2370: 20 20 20 20 20 20 23 66 29 29 0a 20 20 20 20 20 #f)).
2380: 20 3b 3b 20 28 70 72 69 6e 74 20 22 74 65 73 74 ;; (print "test
2390: 73 3a 67 6c 6f 62 2d 6c 69 6b 65 2d 6d 61 74 63 s:glob-like-matc
23a0: 68 20 3d 3e 20 6e 6f 74 70 61 74 74 3a 20 22 20 h => notpatt: "
23b0: 6e 6f 74 70 61 74 74 20 22 2c 20 6e 65 77 70 61 notpatt ", newpa
23c0: 74 74 3a 20 22 20 6e 65 77 70 61 74 74 20 22 2c tt: " newpatt ",
23d0: 20 66 69 6e 70 61 74 74 3a 20 22 20 66 69 6e 70 finpatt: " finp
23e0: 61 74 74 29 0a 20 20 20 20 20 20 28 73 65 74 21 att). (set!
23f0: 20 72 65 73 20 28 73 74 72 69 6e 67 2d 6d 61 74 res (string-mat
2400: 63 68 20 28 72 65 67 65 78 70 20 66 69 6e 70 61 ch (regexp finpa
2410: 74 74 20 28 69 66 20 6c 69 6b 65 20 23 74 20 23 tt (if like #t #
2420: 66 29 29 20 73 74 72 29 29 0a 20 20 20 20 20 20 f)) str)).
2430: 28 69 66 20 6e 6f 74 70 61 74 74 20 28 6e 6f 74 (if notpatt (not
2440: 20 72 65 73 29 20 72 65 73 29 29 29 29 0a 0a 3b res) res))))..;
2450: 3b 20 69 66 20 69 74 65 6d 70 61 74 68 20 69 73 ; if itempath is
2460: 20 23 66 20 74 68 65 6e 20 6c 6f 6f 6b 20 6f 6e #f then look on
2470: 6c 79 20 61 74 20 74 68 65 20 74 65 73 74 6e 61 ly at the testna
2480: 6d 65 20 70 61 72 74 0a 3b 3b 0a 28 64 65 66 69 me part.;;.(defi
2490: 6e 65 20 28 74 65 73 74 73 3a 6d 61 74 63 68 20 ne (tests:match
24a0: 70 61 74 74 65 72 6e 73 20 74 65 73 74 6e 61 6d patterns testnam
24b0: 65 20 69 74 65 6d 70 61 74 68 20 23 21 6b 65 79 e itempath #!key
24c0: 20 28 72 65 71 75 69 72 65 64 20 27 28 29 29 29 (required '()))
24d0: 0a 20 20 28 69 66 20 28 73 74 72 69 6e 67 3f 20 . (if (string?
24e0: 70 61 74 74 65 72 6e 73 29 0a 20 20 20 20 20 20 patterns).
24f0: 28 6c 65 74 20 28 28 70 61 74 74 73 20 28 61 70 (let ((patts (ap
2500: 70 65 6e 64 20 28 73 74 72 69 6e 67 2d 73 70 6c pend (string-spl
2510: 69 74 20 70 61 74 74 65 72 6e 73 20 22 2c 22 29 it patterns ",")
2520: 20 72 65 71 75 69 72 65 64 29 29 29 0a 09 28 69 required)))..(i
2530: 66 20 28 6e 75 6c 6c 3f 20 70 61 74 74 73 29 20 f (null? patts)
2540: 3b 3b 3b 20 6e 6f 20 70 61 74 74 65 72 6e 28 73 ;;; no pattern(s
2550: 29 20 6d 65 61 6e 73 20 6e 6f 20 6d 61 74 63 68 ) means no match
2560: 0a 09 20 20 20 20 23 66 0a 09 20 20 20 20 28 6c .. #f.. (l
2570: 65 74 20 6c 6f 6f 70 20 28 28 70 61 74 74 20 28 et loop ((patt (
2580: 63 61 72 20 70 61 74 74 73 29 29 0a 09 09 20 20 car patts))...
2590: 20 20 20 20 20 28 74 61 6c 20 20 28 63 64 72 20 (tal (cdr
25a0: 70 61 74 74 73 29 29 29 0a 09 20 20 20 20 20 20 patts)))..
25b0: 3b 3b 20 28 70 72 69 6e 74 20 22 6c 6f 6f 70 3a ;; (print "loop:
25c0: 20 70 61 74 74 3a 20 22 20 70 61 74 74 20 22 2c patt: " patt ",
25d0: 20 74 61 6c 20 22 20 74 61 6c 29 0a 09 20 20 20 tal " tal)..
25e0: 20 20 20 28 69 66 20 28 73 74 72 69 6e 67 3d 3f (if (string=?
25f0: 20 70 61 74 74 20 22 22 29 0a 09 09 20 20 23 66 patt "")... #f
2600: 20 3b 3b 20 6e 6f 74 68 69 6e 67 20 65 76 65 72 ;; nothing ever
2610: 20 6d 61 74 63 68 65 73 20 65 6d 70 74 79 20 73 matches empty s
2620: 74 72 69 6e 67 20 2d 20 70 6f 6c 69 63 79 0a 09 tring - policy..
2630: 09 20 20 28 6c 65 74 2a 20 28 28 70 61 74 74 2d . (let* ((patt-
2640: 70 61 72 74 73 20 28 73 74 72 69 6e 67 2d 6d 61 parts (string-ma
2650: 74 63 68 20 28 72 65 67 65 78 70 20 22 5e 28 5b tch (regexp "^([
2660: 5e 5c 5c 2f 5d 2a 29 28 5c 5c 2f 28 2e 2a 29 7c ^\\/]*)(\\/(.*)|
2670: 29 24 22 29 20 70 61 74 74 29 29 0a 09 09 09 20 )$") patt))....
2680: 28 74 65 73 74 2d 70 61 74 74 20 20 28 63 61 64 (test-patt (cad
2690: 72 20 70 61 74 74 2d 70 61 72 74 73 29 29 0a 09 r patt-parts))..
26a0: 09 09 20 28 69 74 65 6d 2d 70 61 74 74 20 20 28 .. (item-patt (
26b0: 63 61 64 64 64 72 20 70 61 74 74 2d 70 61 72 74 cadddr patt-part
26c0: 73 29 29 29 0a 09 09 20 20 20 20 3b 3b 20 73 70 s)))... ;; sp
26d0: 65 63 69 61 6c 20 63 61 73 65 3a 20 74 65 73 74 ecial case: test
26e0: 20 76 73 2e 20 74 65 73 74 2f 0a 09 09 20 20 20 vs. test/...
26f0: 20 3b 3b 20 20 20 74 65 73 74 20 20 3d 3e 20 22 ;; test => "
2700: 74 65 73 74 22 20 22 25 22 0a 09 09 20 20 20 20 test" "%"...
2710: 3b 3b 20 20 20 74 65 73 74 2f 20 3d 3e 20 22 74 ;; test/ => "t
2720: 65 73 74 22 20 22 22 0a 09 09 20 20 20 20 28 69 est" ""... (i
2730: 66 20 28 61 6e 64 20 28 6e 6f 74 20 28 73 75 62 f (and (not (sub
2740: 73 74 72 69 6e 67 2d 69 6e 64 65 78 20 22 2f 22 string-index "/"
2750: 20 70 61 74 74 29 29 20 3b 3b 20 6e 6f 20 73 6c patt)) ;; no sl
2760: 61 73 68 20 69 6e 20 74 68 65 20 6f 72 69 67 69 ash in the origi
2770: 6e 61 6c 0a 09 09 09 20 20 20 20 20 28 6f 72 20 nal.... (or
2780: 28 6e 6f 74 20 69 74 65 6d 2d 70 61 74 74 29 0a (not item-patt).
2790: 09 09 09 09 20 28 65 71 75 61 6c 3f 20 69 74 65 .... (equal? ite
27a0: 6d 2d 70 61 74 74 20 22 22 29 29 29 20 20 20 20 m-patt "")))
27b0: 20 20 3b 3b 20 73 68 6f 75 6c 64 20 61 6c 77 61 ;; should alwa
27c0: 79 73 20 62 65 20 74 72 75 65 20 74 68 61 74 20 ys be true that
27d0: 69 74 65 6d 2d 70 61 74 74 20 69 73 20 22 22 0a item-patt is "".
27e0: 09 09 09 28 73 65 74 21 20 69 74 65 6d 2d 70 61 ...(set! item-pa
27f0: 74 74 20 22 25 22 29 29 0a 09 09 20 20 20 20 3b tt "%"))... ;
2800: 3b 20 28 70 72 69 6e 74 20 22 74 65 73 74 73 3a ; (print "tests:
2810: 6d 61 74 63 68 20 3d 3e 20 70 61 74 74 2d 70 61 match => patt-pa
2820: 72 74 73 3a 20 22 20 70 61 74 74 2d 70 61 72 74 rts: " patt-part
2830: 73 20 22 2c 20 74 65 73 74 2d 70 61 74 74 3a 20 s ", test-patt:
2840: 22 20 74 65 73 74 2d 70 61 74 74 20 22 2c 20 69 " test-patt ", i
2850: 74 65 6d 2d 70 61 74 74 3a 20 22 20 69 74 65 6d tem-patt: " item
2860: 2d 70 61 74 74 29 0a 09 09 20 20 20 20 28 69 66 -patt)... (if
2870: 20 28 61 6e 64 20 28 74 65 73 74 73 3a 67 6c 6f (and (tests:glo
2880: 62 2d 6c 69 6b 65 2d 6d 61 74 63 68 20 74 65 73 b-like-match tes
2890: 74 2d 70 61 74 74 20 74 65 73 74 6e 61 6d 65 29 t-patt testname)
28a0: 0a 09 09 09 20 20 20 20 20 28 6f 72 20 28 6e 6f .... (or (no
28b0: 74 20 69 74 65 6d 70 61 74 68 29 0a 09 09 09 09 t itempath).....
28c0: 20 28 74 65 73 74 73 3a 67 6c 6f 62 2d 6c 69 6b (tests:glob-lik
28d0: 65 2d 6d 61 74 63 68 20 28 69 66 20 69 74 65 6d e-match (if item
28e0: 2d 70 61 74 74 20 69 74 65 6d 2d 70 61 74 74 20 -patt item-patt
28f0: 22 22 29 20 69 74 65 6d 70 61 74 68 29 29 29 0a "") itempath))).
2900: 09 09 09 23 74 0a 09 09 09 28 69 66 20 28 6e 75 ...#t....(if (nu
2910: 6c 6c 3f 20 74 61 6c 29 0a 09 09 09 20 20 20 20 ll? tal)....
2920: 23 66 0a 09 09 09 20 20 20 20 28 6c 6f 6f 70 20 #f.... (loop
2930: 28 63 61 72 20 74 61 6c 29 28 63 64 72 20 74 61 (car tal)(cdr ta
2940: 6c 29 29 29 29 29 29 29 29 29 29 29 0a 0a 3b 3b l)))))))))))..;;
2950: 20 69 66 20 69 74 65 6d 70 61 74 68 20 69 73 20 if itempath is
2960: 23 66 20 74 68 65 6e 20 6c 6f 6f 6b 20 6f 6e 6c #f then look onl
2970: 79 20 61 74 20 74 68 65 20 74 65 73 74 6e 61 6d y at the testnam
2980: 65 20 70 61 72 74 0a 3b 3b 0a 28 64 65 66 69 6e e part.;;.(defin
2990: 65 20 28 74 65 73 74 73 3a 6d 61 74 63 68 2d 3e e (tests:match->
29a0: 73 71 6c 71 72 79 20 70 61 74 74 65 72 6e 73 29 sqlqry patterns)
29b0: 0a 20 20 28 69 66 20 28 73 74 72 69 6e 67 3f 20 . (if (string?
29c0: 70 61 74 74 65 72 6e 73 29 0a 20 20 20 20 20 20 patterns).
29d0: 28 6c 65 74 20 28 28 70 61 74 74 73 20 28 73 74 (let ((patts (st
29e0: 72 69 6e 67 2d 73 70 6c 69 74 20 70 61 74 74 65 ring-split patte
29f0: 72 6e 73 20 22 2c 22 29 29 29 0a 09 28 69 66 20 rns ",")))..(if
2a00: 28 6e 75 6c 6c 3f 20 70 61 74 74 73 29 20 3b 3b (null? patts) ;;
2a10: 3b 20 6e 6f 20 70 61 74 74 65 72 6e 28 73 29 20 ; no pattern(s)
2a20: 6d 65 61 6e 73 20 6e 6f 20 6d 61 74 63 68 2c 20 means no match,
2a30: 77 65 20 77 69 6c 6c 20 64 6f 20 6e 6f 20 71 75 we will do no qu
2a40: 65 72 79 0a 09 20 20 20 20 23 66 0a 09 20 20 20 ery.. #f..
2a50: 20 28 6c 65 74 20 6c 6f 6f 70 20 28 28 70 61 74 (let loop ((pat
2a60: 74 20 28 63 61 72 20 70 61 74 74 73 29 29 0a 09 t (car patts))..
2a70: 09 20 20 20 20 20 20 20 28 74 61 6c 20 20 28 63 . (tal (c
2a80: 64 72 20 70 61 74 74 73 29 29 0a 09 09 20 20 20 dr patts))...
2a90: 20 20 20 20 28 72 65 73 20 20 27 28 29 29 29 0a (res '())).
2aa0: 09 20 20 20 20 20 20 3b 3b 20 28 70 72 69 6e 74 . ;; (print
2ab0: 20 22 6c 6f 6f 70 3a 20 70 61 74 74 3a 20 22 20 "loop: patt: "
2ac0: 70 61 74 74 20 22 2c 20 74 61 6c 20 22 20 74 61 patt ", tal " ta
2ad0: 6c 29 0a 09 20 20 20 20 20 20 28 6c 65 74 2a 20 l).. (let*
2ae0: 28 28 70 61 74 74 2d 70 61 72 74 73 20 28 73 74 ((patt-parts (st
2af0: 72 69 6e 67 2d 6d 61 74 63 68 20 28 72 65 67 65 ring-match (rege
2b00: 78 70 20 22 5e 28 5b 5e 5c 5c 2f 5d 2a 29 28 5c xp "^([^\\/]*)(\
2b10: 5c 2f 28 2e 2a 29 7c 29 24 22 29 20 70 61 74 74 \/(.*)|)$") patt
2b20: 29 29 0a 09 09 20 20 20 20 20 28 74 65 73 74 2d ))... (test-
2b30: 70 61 74 74 20 20 28 63 61 64 72 20 70 61 74 74 patt (cadr patt
2b40: 2d 70 61 72 74 73 29 29 0a 09 09 20 20 20 20 20 -parts))...
2b50: 28 69 74 65 6d 2d 70 61 74 74 20 20 28 63 61 64 (item-patt (cad
2b60: 64 64 72 20 70 61 74 74 2d 70 61 72 74 73 29 29 ddr patt-parts))
2b70: 0a 09 09 20 20 20 20 20 28 74 65 73 74 2d 71 72 ... (test-qr
2b80: 79 20 20 20 28 64 62 3a 70 61 74 74 2d 3e 6c 69 y (db:patt->li
2b90: 6b 65 20 22 74 65 73 74 6e 61 6d 65 22 20 74 65 ke "testname" te
2ba0: 73 74 2d 70 61 74 74 29 29 0a 09 09 20 20 20 20 st-patt))...
2bb0: 20 28 69 74 65 6d 2d 71 72 79 20 20 20 28 64 62 (item-qry (db
2bc0: 3a 70 61 74 74 2d 3e 6c 69 6b 65 20 22 69 74 65 :patt->like "ite
2bd0: 6d 5f 70 61 74 68 22 20 69 74 65 6d 2d 70 61 74 m_path" item-pat
2be0: 74 29 29 0a 09 09 20 20 20 20 20 28 71 72 79 20 t))... (qry
2bf0: 20 20 20 20 20 20 20 28 63 6f 6e 63 20 22 28 22 (conc "("
2c00: 20 74 65 73 74 2d 71 72 79 20 22 20 41 4e 44 20 test-qry " AND
2c10: 22 20 69 74 65 6d 2d 71 72 79 20 22 29 22 29 29 " item-qry ")"))
2c20: 29 0a 09 09 3b 3b 20 28 70 72 69 6e 74 20 22 74 )...;; (print "t
2c30: 65 73 74 73 3a 6d 61 74 63 68 20 3d 3e 20 70 61 ests:match => pa
2c40: 74 74 2d 70 61 72 74 73 3a 20 22 20 70 61 74 74 tt-parts: " patt
2c50: 2d 70 61 72 74 73 20 22 2c 20 74 65 73 74 2d 70 -parts ", test-p
2c60: 61 74 74 3a 20 22 20 74 65 73 74 2d 70 61 74 74 att: " test-patt
2c70: 20 22 2c 20 69 74 65 6d 2d 70 61 74 74 3a 20 22 ", item-patt: "
2c80: 20 69 74 65 6d 2d 70 61 74 74 29 0a 09 09 28 69 item-patt)...(i
2c90: 66 20 28 6e 75 6c 6c 3f 20 74 61 6c 29 0a 09 09 f (null? tal)...
2ca0: 20 20 20 20 28 73 74 72 69 6e 67 2d 69 6e 74 65 (string-inte
2cb0: 72 73 70 65 72 73 65 20 28 61 70 70 65 6e 64 20 rsperse (append
2cc0: 28 72 65 76 65 72 73 65 20 72 65 73 29 28 6c 69 (reverse res)(li
2cd0: 73 74 20 71 72 79 29 29 20 22 20 4f 52 20 22 29 st qry)) " OR ")
2ce0: 0a 09 09 20 20 20 20 28 6c 6f 6f 70 20 28 63 61 ... (loop (ca
2cf0: 72 20 74 61 6c 29 28 63 64 72 20 74 61 6c 29 28 r tal)(cdr tal)(
2d00: 63 6f 6e 73 20 71 72 79 20 72 65 73 29 29 29 29 cons qry res))))
2d10: 29 29 29 0a 20 20 20 20 20 20 23 66 29 29 0a 0a ))). #f))..
2d20: 3b 3b 20 43 68 65 63 6b 20 66 6f 72 20 77 61 69 ;; Check for wai
2d30: 76 65 72 20 65 6c 69 67 69 62 69 6c 69 74 79 0a ver eligibility.
2d40: 3b 3b 0a 28 64 65 66 69 6e 65 20 28 74 65 73 74 ;;.(define (test
2d50: 73 3a 63 68 65 63 6b 2d 77 61 69 76 65 72 2d 65 s:check-waiver-e
2d60: 6c 69 67 69 62 69 6c 69 74 79 20 74 65 73 74 64 ligibility testd
2d70: 61 74 20 70 72 65 76 2d 74 65 73 74 64 61 74 29 at prev-testdat)
2d80: 0a 20 20 28 6c 65 74 2a 20 28 28 74 65 73 74 2d . (let* ((test-
2d90: 72 65 67 69 73 74 72 79 20 28 6d 61 6b 65 2d 68 registry (make-h
2da0: 61 73 68 2d 74 61 62 6c 65 29 29 0a 09 20 28 74 ash-table)).. (t
2db0: 65 73 74 63 6f 6e 66 69 67 20 20 28 74 65 73 74 estconfig (test
2dc0: 73 3a 67 65 74 2d 74 65 73 74 63 6f 6e 66 69 67 s:get-testconfig
2dd0: 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 74 65 (db:test-get-te
2de0: 73 74 6e 61 6d 65 20 74 65 73 74 64 61 74 29 20 stname testdat)
2df0: 74 65 73 74 2d 72 65 67 69 73 74 72 79 20 23 66 test-registry #f
2e00: 29 29 0a 09 20 28 74 65 73 74 2d 72 75 6e 64 69 )).. (test-rundi
2e10: 72 20 3b 3b 20 28 73 64 62 3a 71 72 79 20 27 70 r ;; (sdb:qry 'p
2e20: 61 73 73 73 74 72 20 0a 09 20 20 28 64 62 3a 74 assstr .. (db:t
2e30: 65 73 74 2d 67 65 74 2d 72 75 6e 64 69 72 20 74 est-get-rundir t
2e40: 65 73 74 64 61 74 29 29 20 3b 3b 20 29 0a 09 20 estdat)) ;; )..
2e50: 28 70 72 65 76 2d 72 75 6e 64 69 72 20 3b 3b 20 (prev-rundir ;;
2e60: 28 73 64 62 3a 71 72 79 20 27 70 61 73 73 73 74 (sdb:qry 'passst
2e70: 72 20 0a 09 20 20 28 64 62 3a 74 65 73 74 2d 67 r .. (db:test-g
2e80: 65 74 2d 72 75 6e 64 69 72 20 70 72 65 76 2d 74 et-rundir prev-t
2e90: 65 73 74 64 61 74 29 29 20 3b 3b 20 29 0a 09 20 estdat)) ;; )..
2ea0: 28 77 61 69 76 65 72 73 20 20 20 20 20 28 69 66 (waivers (if
2eb0: 20 74 65 73 74 63 6f 6e 66 69 67 20 28 63 6f 6e testconfig (con
2ec0: 66 69 67 66 3a 73 65 63 74 69 6f 6e 2d 76 61 72 figf:section-var
2ed0: 73 20 74 65 73 74 63 6f 6e 66 69 67 20 22 77 61 s testconfig "wa
2ee0: 69 76 65 72 73 22 29 20 27 28 29 29 29 0a 09 20 ivers") '()))..
2ef0: 28 77 61 69 76 65 72 2d 72 78 20 20 20 28 72 65 (waiver-rx (re
2f00: 67 65 78 70 20 22 5e 28 5c 5c 53 2b 29 5c 5c 73 gexp "^(\\S+)\\s
2f10: 2b 28 2e 2a 29 24 22 29 29 0a 09 20 28 64 69 66 +(.*)$")).. (dif
2f20: 66 2d 72 75 6c 65 20 20 20 22 64 69 66 66 20 25 f-rule "diff %
2f30: 66 69 6c 65 31 25 20 25 66 69 6c 65 32 25 22 29 file1% %file2%")
2f40: 0a 09 20 28 6c 6f 67 70 72 6f 2d 72 75 6c 65 20 .. (logpro-rule
2f50: 22 64 69 66 66 20 25 66 69 6c 65 31 25 20 25 66 "diff %file1% %f
2f60: 69 6c 65 32 25 20 7c 20 6c 6f 67 70 72 6f 20 25 ile2% | logpro %
2f70: 77 61 69 76 65 72 6e 61 6d 65 25 2e 6c 6f 67 70 waivername%.logp
2f80: 72 6f 20 25 77 61 69 76 65 72 6e 61 6d 65 25 2e ro %waivername%.
2f90: 68 74 6d 6c 22 29 29 0a 20 20 20 20 28 69 66 20 html")). (if
2fa0: 28 6e 6f 74 20 28 66 69 6c 65 2d 65 78 69 73 74 (not (file-exist
2fb0: 73 3f 20 74 65 73 74 2d 72 75 6e 64 69 72 29 29 s? test-rundir))
2fc0: 0a 09 28 62 65 67 69 6e 0a 09 20 20 28 64 65 62 ..(begin.. (deb
2fd0: 75 67 3a 70 72 69 6e 74 20 30 20 22 45 52 52 4f ug:print 0 "ERRO
2fe0: 52 3a 20 74 65 73 74 20 72 75 6e 20 64 69 72 65 R: test run dire
2ff0: 63 74 6f 72 79 20 69 73 20 67 6f 6e 65 2c 20 63 ctory is gone, c
3000: 61 6e 6e 6f 74 20 70 72 6f 70 61 67 61 74 65 20 annot propagate
3010: 77 61 69 76 65 72 22 29 0a 09 20 20 23 66 29 0a waiver").. #f).
3020: 09 28 62 65 67 69 6e 0a 09 20 20 28 70 75 73 68 .(begin.. (push
3030: 2d 64 69 72 65 63 74 6f 72 79 20 74 65 73 74 2d -directory test-
3040: 72 75 6e 64 69 72 29 0a 09 20 20 28 6c 65 74 20 rundir).. (let
3050: 28 28 72 65 73 75 6c 74 20 28 69 66 20 28 6e 75 ((result (if (nu
3060: 6c 6c 3f 20 77 61 69 76 65 72 73 29 0a 09 09 09 ll? waivers)....
3070: 20 20 20 20 23 66 0a 09 09 09 20 20 20 20 28 6c #f.... (l
3080: 65 74 20 6c 6f 6f 70 20 28 28 68 65 64 20 28 63 et loop ((hed (c
3090: 61 72 20 77 61 69 76 65 72 73 29 29 0a 09 09 09 ar waivers))....
30a0: 09 20 20 20 20 20 20 20 28 74 61 6c 20 28 63 64 . (tal (cd
30b0: 72 20 77 61 69 76 65 72 73 29 29 29 0a 09 09 09 r waivers)))....
30c0: 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 (debug:pri
30d0: 6e 74 20 30 20 22 49 4e 46 4f 3a 20 41 70 70 6c nt 0 "INFO: Appl
30e0: 79 69 6e 67 20 77 61 69 76 65 72 20 72 75 6c 65 ying waiver rule
30f0: 20 5c 22 22 20 68 65 64 20 22 5c 22 22 29 0a 09 \"" hed "\"")..
3100: 09 09 20 20 20 20 20 20 28 6c 65 74 2a 20 28 28 .. (let* ((
3110: 77 61 69 76 65 72 20 20 20 20 20 20 28 63 6f 6e waiver (con
3120: 66 69 67 66 3a 6c 6f 6f 6b 75 70 20 74 65 73 74 figf:lookup test
3130: 63 6f 6e 66 69 67 20 22 77 61 69 76 65 72 73 22 config "waivers"
3140: 20 68 65 64 29 29 0a 09 09 09 09 20 20 20 20 20 hed)).....
3150: 28 77 70 61 72 74 73 20 20 20 20 20 20 28 69 66 (wparts (if
3160: 20 77 61 69 76 65 72 20 28 73 74 72 69 6e 67 2d waiver (string-
3170: 6d 61 74 63 68 20 77 61 69 76 65 72 2d 72 78 20 match waiver-rx
3180: 77 61 69 76 65 72 29 20 23 66 29 29 0a 09 09 09 waiver) #f))....
3190: 09 20 20 20 20 20 28 77 61 69 76 65 72 2d 72 75 . (waiver-ru
31a0: 6c 65 20 28 69 66 20 77 70 61 72 74 73 20 28 63 le (if wparts (c
31b0: 61 64 72 20 77 70 61 72 74 73 29 20 20 23 66 29 adr wparts) #f)
31c0: 29 0a 09 09 09 09 20 20 20 20 20 28 77 61 69 76 )..... (waiv
31d0: 65 72 2d 67 6c 6f 62 20 28 69 66 20 77 70 61 72 er-glob (if wpar
31e0: 74 73 20 28 63 61 64 64 72 20 77 70 61 72 74 73 ts (caddr wparts
31f0: 29 20 23 66 29 29 0a 09 09 09 09 20 20 20 20 20 ) #f)).....
3200: 28 6c 6f 67 70 72 6f 2d 66 69 6c 65 20 28 69 66 (logpro-file (if
3210: 20 77 61 69 76 65 72 0a 09 09 09 09 09 09 20 20 waiver.......
3220: 20 20 20 20 28 6c 65 74 20 28 28 66 6e 61 6d 65 (let ((fname
3230: 20 28 63 6f 6e 63 20 68 65 64 20 22 2e 6c 6f 67 (conc hed ".log
3240: 70 72 6f 22 29 29 29 0a 09 09 09 09 09 09 09 28 pro")))........(
3250: 69 66 20 28 66 69 6c 65 2d 65 78 69 73 74 73 3f if (file-exists?
3260: 20 66 6e 61 6d 65 29 0a 09 09 09 09 09 09 09 20 fname)........
3270: 20 20 20 66 6e 61 6d 65 20 0a 09 09 09 09 09 09 fname .......
3280: 09 20 20 20 20 28 62 65 67 69 6e 0a 09 09 09 09 . (begin.....
3290: 09 09 09 20 20 20 20 20 20 28 64 65 62 75 67 3a ... (debug:
32a0: 70 72 69 6e 74 20 30 20 22 49 4e 46 4f 3a 20 4e print 0 "INFO: N
32b0: 6f 20 6c 6f 67 70 72 6f 20 66 69 6c 65 20 22 20 o logpro file "
32c0: 66 6e 61 6d 65 20 22 20 66 61 6c 6c 69 6e 67 20 fname " falling
32d0: 62 61 63 6b 20 74 6f 20 64 69 66 66 22 29 0a 09 back to diff")..
32e0: 09 09 09 09 09 09 20 20 20 20 20 20 23 66 29 29 ...... #f))
32f0: 29 0a 09 09 09 09 09 09 20 20 20 20 20 20 23 66 )....... #f
3300: 29 29 0a 09 09 09 09 20 20 20 20 20 3b 3b 20 69 ))..... ;; i
3310: 66 20 72 75 6c 65 20 62 79 20 6e 61 6d 65 20 6f f rule by name o
3320: 66 20 77 61 69 76 65 72 2d 72 75 6c 65 20 69 73 f waiver-rule is
3330: 20 66 6f 75 6e 64 20 69 6e 20 74 65 73 74 63 6f found in testco
3340: 6e 66 69 67 20 2d 20 75 73 65 20 69 74 0a 09 09 nfig - use it...
3350: 09 09 20 20 20 20 20 3b 3b 20 65 6c 73 65 20 69 .. ;; else i
3360: 66 20 77 61 69 76 65 72 6e 61 6d 65 2e 6c 6f 67 f waivername.log
3370: 70 72 6f 20 65 78 69 73 74 73 20 75 73 65 20 6c pro exists use l
3380: 6f 67 70 72 6f 2d 72 75 6c 65 0a 09 09 09 09 20 ogpro-rule.....
3390: 20 20 20 20 3b 3b 20 65 6c 73 65 20 64 65 66 61 ;; else defa
33a0: 75 6c 74 20 74 6f 20 64 69 66 66 2d 72 75 6c 65 ult to diff-rule
33b0: 0a 09 09 09 09 20 20 20 20 20 28 72 75 6c 65 2d ..... (rule-
33c0: 73 74 72 69 6e 67 20 28 6c 65 74 20 28 28 72 75 string (let ((ru
33d0: 6c 65 20 28 63 6f 6e 66 69 67 66 3a 6c 6f 6f 6b le (configf:look
33e0: 75 70 20 74 65 73 74 63 6f 6e 66 69 67 20 22 77 up testconfig "w
33f0: 61 69 76 65 72 5f 72 75 6c 65 73 22 20 77 61 69 aiver_rules" wai
3400: 76 65 72 2d 72 75 6c 65 29 29 29 0a 09 09 09 09 ver-rule))).....
3410: 09 09 20 20 20 20 28 69 66 20 72 75 6c 65 0a 09 .. (if rule..
3420: 09 09 09 09 09 09 72 75 6c 65 0a 09 09 09 09 09 ......rule......
3430: 09 09 28 69 66 20 6c 6f 67 70 72 6f 2d 66 69 6c ..(if logpro-fil
3440: 65 0a 09 09 09 09 09 09 09 20 20 20 20 6c 6f 67 e........ log
3450: 70 72 6f 2d 72 75 6c 65 0a 09 09 09 09 09 09 09 pro-rule........
3460: 20 20 20 20 28 62 65 67 69 6e 0a 09 09 09 09 09 (begin......
3470: 09 09 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 .. (debug:p
3480: 72 69 6e 74 20 30 20 22 49 4e 46 4f 3a 20 4e 6f rint 0 "INFO: No
3490: 20 6c 6f 67 70 72 6f 20 66 69 6c 65 20 22 20 6c logpro file " l
34a0: 6f 67 70 72 6f 2d 66 69 6c 65 20 22 20 66 6f 75 ogpro-file " fou
34b0: 6e 64 2c 20 75 73 69 6e 67 20 64 69 66 66 20 72 nd, using diff r
34c0: 75 6c 65 22 29 0a 09 09 09 09 09 09 09 20 20 20 ule")........
34d0: 20 20 20 64 69 66 66 2d 72 75 6c 65 29 29 29 29 diff-rule))))
34e0: 29 0a 09 09 09 09 20 20 20 20 20 3b 3b 20 28 73 )..... ;; (s
34f0: 74 72 69 6e 67 2d 73 75 62 73 74 69 74 75 74 65 tring-substitute
3500: 20 22 25 66 69 6c 65 31 25 22 20 22 66 6f 6f 66 "%file1%" "foof
3510: 6f 6f 2e 74 78 74 22 20 22 54 68 69 73 20 69 73 oo.txt" "This is
3520: 20 25 66 69 6c 65 31 25 20 61 6e 64 20 73 6f 20 %file1% and so
3530: 69 73 20 74 68 69 73 20 25 66 69 6c 65 31 25 2e is this %file1%.
3540: 22 20 23 74 29 0a 09 09 09 09 20 20 20 20 20 28 " #t)..... (
3550: 70 72 6f 63 65 73 73 65 64 2d 63 6d 64 20 28 73 processed-cmd (s
3560: 74 72 69 6e 67 2d 73 75 62 73 74 69 74 75 74 65 tring-substitute
3570: 20 0a 09 09 09 09 09 09 20 20 20 20 20 22 25 66 ....... "%f
3580: 69 6c 65 31 25 22 20 28 63 6f 6e 63 20 74 65 73 ile1%" (conc tes
3590: 74 2d 72 75 6e 64 69 72 20 22 2f 22 20 77 61 69 t-rundir "/" wai
35a0: 76 65 72 2d 67 6c 6f 62 29 0a 09 09 09 09 09 09 ver-glob).......
35b0: 20 20 20 20 20 28 73 74 72 69 6e 67 2d 73 75 62 (string-sub
35c0: 73 74 69 74 75 74 65 0a 09 09 09 09 09 09 20 20 stitute.......
35d0: 20 20 20 20 22 25 66 69 6c 65 32 25 22 20 28 63 "%file2%" (c
35e0: 6f 6e 63 20 70 72 65 76 2d 72 75 6e 64 69 72 20 onc prev-rundir
35f0: 22 2f 22 20 77 61 69 76 65 72 2d 67 6c 6f 62 29 "/" waiver-glob)
3600: 0a 09 09 09 09 09 09 20 20 20 20 20 20 28 73 74 ....... (st
3610: 72 69 6e 67 2d 73 75 62 73 74 69 74 75 74 65 0a ring-substitute.
3620: 09 09 09 09 09 09 20 20 20 20 20 20 20 22 25 77 ...... "%w
3630: 61 69 76 65 72 6e 61 6d 65 25 22 20 68 65 64 20 aivername%" hed
3640: 72 75 6c 65 2d 73 74 72 69 6e 67 20 23 74 29 20 rule-string #t)
3650: 23 74 29 20 23 74 29 29 0a 09 09 09 09 20 20 20 #t) #t)).....
3660: 20 20 28 72 65 73 20 20 20 20 20 20 20 20 20 20 (res
3670: 20 20 23 66 29 29 0a 09 09 09 09 28 64 65 62 75 #f)).....(debu
3680: 67 3a 70 72 69 6e 74 20 30 20 22 49 4e 46 4f 3a g:print 0 "INFO:
3690: 20 77 61 69 76 65 72 20 63 6f 6d 6d 61 6e 64 20 waiver command
36a0: 69 73 20 5c 22 22 20 70 72 6f 63 65 73 73 65 64 is \"" processed
36b0: 2d 63 6d 64 20 22 5c 22 22 29 0a 09 09 09 09 28 -cmd "\"").....(
36c0: 69 66 20 28 65 71 3f 20 28 73 79 73 74 65 6d 20 if (eq? (system
36d0: 70 72 6f 63 65 73 73 65 64 2d 63 6d 64 29 20 30 processed-cmd) 0
36e0: 29 0a 09 09 09 09 20 20 20 20 28 69 66 20 28 6e )..... (if (n
36f0: 75 6c 6c 3f 20 74 61 6c 29 0a 09 09 09 09 09 23 ull? tal)......#
3700: 74 0a 09 09 09 09 09 28 6c 6f 6f 70 20 28 63 61 t......(loop (ca
3710: 72 20 74 61 6c 29 28 63 64 72 20 74 61 6c 29 29 r tal)(cdr tal))
3720: 29 0a 09 09 09 09 20 20 20 20 23 66 29 29 29 29 )..... #f))))
3730: 29 29 0a 09 20 20 20 20 28 70 6f 70 2d 64 69 72 )).. (pop-dir
3740: 65 63 74 6f 72 79 29 0a 09 20 20 20 20 72 65 73 ectory).. res
3750: 75 6c 74 29 29 29 29 29 0a 0a 28 64 65 66 69 6e ult)))))..(defin
3760: 65 20 28 74 65 73 74 73 3a 74 65 73 74 2d 66 6f e (tests:test-fo
3770: 72 63 65 2d 73 74 61 74 65 2d 73 74 61 74 75 73 rce-state-status
3780: 21 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 69 64 ! run-id test-id
3790: 20 73 74 61 74 65 20 73 74 61 74 75 73 29 0a 20 state status).
37a0: 20 28 72 6d 74 3a 74 65 73 74 2d 73 65 74 2d 73 (rmt:test-set-s
37b0: 74 61 74 75 73 2d 73 74 61 74 65 20 72 75 6e 2d tatus-state run-
37c0: 69 64 20 74 65 73 74 2d 69 64 20 73 74 61 74 75 id test-id statu
37d0: 73 20 73 74 61 74 65 20 23 66 29 0a 20 20 28 6d s state #f). (m
37e0: 74 3a 70 72 6f 63 65 73 73 2d 74 72 69 67 67 65 t:process-trigge
37f0: 72 73 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 69 rs run-id test-i
3800: 64 20 73 74 61 74 65 20 73 74 61 74 75 73 29 29 d state status))
3810: 0a 0a 3b 3b 20 44 6f 20 6e 6f 74 20 72 70 63 20 ..;; Do not rpc
3820: 74 68 69 73 20 6f 6e 65 2c 20 64 6f 20 74 68 65 this one, do the
3830: 20 75 6e 64 65 72 6c 79 69 6e 67 20 63 61 6c 6c underlying call
3840: 73 21 21 21 0a 28 64 65 66 69 6e 65 20 28 74 65 s!!!.(define (te
3850: 73 74 73 3a 74 65 73 74 2d 73 65 74 2d 73 74 61 sts:test-set-sta
3860: 74 75 73 21 20 72 75 6e 2d 69 64 20 74 65 73 74 tus! run-id test
3870: 2d 69 64 20 73 74 61 74 65 20 73 74 61 74 75 73 -id state status
3880: 20 63 6f 6d 6d 65 6e 74 20 64 61 74 20 23 21 6b comment dat #!k
3890: 65 79 20 28 77 6f 72 6b 2d 61 72 65 61 20 23 66 ey (work-area #f
38a0: 29 29 0a 20 20 28 6c 65 74 2a 20 28 28 72 65 61 )). (let* ((rea
38b0: 6c 2d 73 74 61 74 75 73 20 73 74 61 74 75 73 29 l-status status)
38c0: 0a 09 20 28 6f 74 68 65 72 64 61 74 20 20 20 20 .. (otherdat
38d0: 28 69 66 20 64 61 74 20 64 61 74 20 28 6d 61 6b (if dat dat (mak
38e0: 65 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 29 0a e-hash-table))).
38f0: 09 20 28 74 65 73 74 64 61 74 20 20 20 20 20 28 . (testdat (
3900: 72 6d 74 3a 67 65 74 2d 74 65 73 74 2d 69 6e 66 rmt:get-test-inf
3910: 6f 2d 62 79 2d 69 64 20 72 75 6e 2d 69 64 20 74 o-by-id run-id t
3920: 65 73 74 2d 69 64 29 29 0a 09 20 28 74 65 73 74 est-id)).. (test
3930: 2d 6e 61 6d 65 20 20 20 28 64 62 3a 74 65 73 74 -name (db:test
3940: 2d 67 65 74 2d 74 65 73 74 6e 61 6d 65 20 20 74 -get-testname t
3950: 65 73 74 64 61 74 29 29 0a 09 20 28 69 74 65 6d estdat)).. (item
3960: 2d 70 61 74 68 20 20 20 28 64 62 3a 74 65 73 74 -path (db:test
3970: 2d 67 65 74 2d 69 74 65 6d 2d 70 61 74 68 20 74 -get-item-path t
3980: 65 73 74 64 61 74 29 29 0a 09 20 3b 3b 20 62 65 estdat)).. ;; be
3990: 66 6f 72 65 20 70 72 6f 63 65 65 64 69 6e 67 20 fore proceeding
39a0: 77 65 20 6d 75 73 74 20 66 69 6e 64 20 6f 75 74 we must find out
39b0: 20 69 66 20 74 68 65 20 70 72 65 76 69 6f 75 73 if the previous
39c0: 20 74 65 73 74 20 28 77 68 65 72 65 20 61 6c 6c test (where all
39d0: 20 6b 65 79 73 20 6d 61 74 63 68 65 64 20 65 78 keys matched ex
39e0: 63 65 70 74 20 72 75 6e 6e 61 6d 65 29 0a 09 20 cept runname)..
39f0: 3b 3b 20 77 61 73 20 57 41 49 56 45 44 20 69 66 ;; was WAIVED if
3a00: 20 74 68 69 73 20 74 65 73 74 20 69 73 20 46 41 this test is FA
3a10: 49 4c 0a 0a 09 20 3b 3b 20 4e 4f 54 45 53 3a 0a IL... ;; NOTES:.
3a20: 09 20 3b 3b 20 20 31 2e 20 49 73 20 74 68 65 20 . ;; 1. Is the
3a30: 63 61 6c 6c 20 74 6f 20 74 65 73 74 3a 67 65 74 call to test:get
3a40: 2d 70 72 65 76 69 6f 75 73 2d 72 75 6e 2d 72 65 -previous-run-re
3a50: 63 6f 72 64 20 72 65 6d 6f 74 69 66 69 65 64 3f cord remotified?
3a60: 0a 09 20 3b 3b 20 20 32 2e 20 41 64 64 20 74 65 .. ;; 2. Add te
3a70: 73 74 20 66 6f 72 20 74 65 73 74 63 6f 6e 66 69 st for testconfi
3a80: 67 20 77 61 69 76 65 72 20 70 72 6f 70 61 67 61 g waiver propaga
3a90: 74 69 6f 6e 20 63 6f 6e 74 72 6f 6c 20 68 65 72 tion control her
3aa0: 65 0a 09 20 3b 3b 0a 09 20 28 70 72 65 76 2d 74 e.. ;;.. (prev-t
3ab0: 65 73 74 20 20 20 28 69 66 20 28 65 71 75 61 6c est (if (equal
3ac0: 3f 20 73 74 61 74 75 73 20 22 46 41 49 4c 22 29 ? status "FAIL")
3ad0: 0a 09 09 09 20 20 28 72 6d 74 3a 67 65 74 2d 70 .... (rmt:get-p
3ae0: 72 65 76 69 6f 75 73 2d 74 65 73 74 2d 72 75 6e revious-test-run
3af0: 2d 72 65 63 6f 72 64 20 72 75 6e 2d 69 64 20 74 -record run-id t
3b00: 65 73 74 2d 6e 61 6d 65 20 69 74 65 6d 2d 70 61 est-name item-pa
3b10: 74 68 29 0a 09 09 09 20 20 23 66 29 29 0a 09 20 th).... #f))..
3b20: 28 77 61 69 76 65 64 20 20 20 28 69 66 20 70 72 (waived (if pr
3b30: 65 76 2d 74 65 73 74 0a 09 09 20 20 20 20 20 20 ev-test...
3b40: 20 28 69 66 20 70 72 65 76 2d 74 65 73 74 20 3b (if prev-test ;
3b50: 3b 20 74 72 75 65 20 69 66 20 77 65 20 66 6f 75 ; true if we fou
3b60: 6e 64 20 61 20 70 72 65 76 69 6f 75 73 20 74 65 nd a previous te
3b70: 73 74 20 69 6e 20 74 68 69 73 20 72 75 6e 20 73 st in this run s
3b80: 65 72 69 65 73 0a 09 09 09 20 20 20 28 6c 65 74 eries.... (let
3b90: 20 28 28 70 72 65 76 2d 73 74 61 74 75 73 20 20 ((prev-status
3ba0: 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 73 74 61 (db:test-get-sta
3bb0: 74 75 73 20 20 70 72 65 76 2d 74 65 73 74 29 29 tus prev-test))
3bc0: 0a 09 09 09 09 20 28 70 72 65 76 2d 73 74 61 74 ..... (prev-stat
3bd0: 65 20 20 20 28 64 62 3a 74 65 73 74 2d 67 65 74 e (db:test-get
3be0: 2d 73 74 61 74 65 20 20 20 70 72 65 76 2d 74 65 -state prev-te
3bf0: 73 74 29 29 0a 09 09 09 09 20 28 70 72 65 76 2d st))..... (prev-
3c00: 63 6f 6d 6d 65 6e 74 20 28 64 62 3a 74 65 73 74 comment (db:test
3c10: 2d 67 65 74 2d 63 6f 6d 6d 65 6e 74 20 70 72 65 -get-comment pre
3c20: 76 2d 74 65 73 74 29 29 29 0a 09 09 09 20 20 20 v-test)))....
3c30: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 34 (debug:print 4
3c40: 20 22 70 72 65 76 2d 73 74 61 74 75 73 20 22 20 "prev-status "
3c50: 70 72 65 76 2d 73 74 61 74 75 73 20 22 2c 20 70 prev-status ", p
3c60: 72 65 76 2d 73 74 61 74 65 20 22 20 70 72 65 76 rev-state " prev
3c70: 2d 73 74 61 74 65 20 22 2c 20 70 72 65 76 2d 63 -state ", prev-c
3c80: 6f 6d 6d 65 6e 74 20 22 20 70 72 65 76 2d 63 6f omment " prev-co
3c90: 6d 6d 65 6e 74 29 0a 09 09 09 20 20 20 20 20 28 mment).... (
3ca0: 69 66 20 28 61 6e 64 20 28 65 71 75 61 6c 3f 20 if (and (equal?
3cb0: 70 72 65 76 2d 73 74 61 74 65 20 20 22 43 4f 4d prev-state "COM
3cc0: 50 4c 45 54 45 44 22 29 0a 09 09 09 09 20 20 20 PLETED").....
3cd0: 20 20 20 28 65 71 75 61 6c 3f 20 70 72 65 76 2d (equal? prev-
3ce0: 73 74 61 74 75 73 20 22 57 41 49 56 45 44 22 29 status "WAIVED")
3cf0: 29 0a 09 09 09 09 20 28 69 66 20 63 6f 6d 6d 65 )..... (if comme
3d00: 6e 74 0a 09 09 09 09 20 20 20 20 20 63 6f 6d 6d nt..... comm
3d10: 65 6e 74 0a 09 09 09 09 20 20 20 20 20 70 72 65 ent..... pre
3d20: 76 2d 63 6f 6d 6d 65 6e 74 29 20 3b 3b 20 77 61 v-comment) ;; wa
3d30: 69 76 65 64 20 69 73 20 65 69 74 68 65 72 20 74 ived is either t
3d40: 68 65 20 63 6f 6d 6d 65 6e 74 20 6f 72 20 23 66 he comment or #f
3d50: 0a 09 09 09 09 20 23 66 29 29 0a 09 09 09 20 20 ..... #f))....
3d60: 20 23 66 29 0a 09 09 20 20 20 20 20 20 20 23 66 #f)... #f
3d70: 29 29 29 0a 20 20 20 20 28 69 66 20 28 61 6e 64 ))). (if (and
3d80: 20 77 61 69 76 65 64 20 0a 09 20 20 20 20 20 28 waived .. (
3d90: 74 65 73 74 73 3a 63 68 65 63 6b 2d 77 61 69 76 tests:check-waiv
3da0: 65 72 2d 65 6c 69 67 69 62 69 6c 69 74 79 20 74 er-eligibility t
3db0: 65 73 74 64 61 74 20 70 72 65 76 2d 74 65 73 74 estdat prev-test
3dc0: 29 29 0a 09 28 73 65 74 21 20 72 65 61 6c 2d 73 ))..(set! real-s
3dd0: 74 61 74 75 73 20 22 57 41 49 56 45 44 22 29 29 tatus "WAIVED"))
3de0: 0a 0a 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 .. (debug:pri
3df0: 6e 74 20 34 20 22 72 65 61 6c 2d 73 74 61 74 75 nt 4 "real-statu
3e00: 73 20 22 20 72 65 61 6c 2d 73 74 61 74 75 73 20 s " real-status
3e10: 22 2c 20 77 61 69 76 65 64 20 22 20 77 61 69 76 ", waived " waiv
3e20: 65 64 20 22 2c 20 73 74 61 74 75 73 20 22 20 73 ed ", status " s
3e30: 74 61 74 75 73 29 0a 0a 20 20 20 20 3b 3b 20 75 tatus).. ;; u
3e40: 70 64 61 74 65 20 74 68 65 20 70 72 69 6d 61 72 pdate the primar
3e50: 79 20 72 65 63 6f 72 64 20 49 46 20 73 74 61 74 y record IF stat
3e60: 65 20 41 4e 44 20 73 74 61 74 75 73 20 61 72 65 e AND status are
3e70: 20 64 65 66 69 6e 65 64 0a 20 20 20 20 28 69 66 defined. (if
3e80: 20 28 61 6e 64 20 73 74 61 74 65 20 73 74 61 74 (and state stat
3e90: 75 73 29 0a 09 28 62 65 67 69 6e 0a 09 20 20 28 us)..(begin.. (
3ea0: 72 6d 74 3a 74 65 73 74 2d 73 65 74 2d 73 74 61 rmt:test-set-sta
3eb0: 74 75 73 2d 73 74 61 74 65 20 72 75 6e 2d 69 64 tus-state run-id
3ec0: 20 74 65 73 74 2d 69 64 20 72 65 61 6c 2d 73 74 test-id real-st
3ed0: 61 74 75 73 20 73 74 61 74 65 20 28 69 66 20 77 atus state (if w
3ee0: 61 69 76 65 64 20 77 61 69 76 65 64 20 63 6f 6d aived waived com
3ef0: 6d 65 6e 74 29 29 0a 09 20 20 28 6d 74 3a 70 72 ment)).. (mt:pr
3f00: 6f 63 65 73 73 2d 74 72 69 67 67 65 72 73 20 72 ocess-triggers r
3f10: 75 6e 2d 69 64 20 74 65 73 74 2d 69 64 20 73 74 un-id test-id st
3f20: 61 74 65 20 72 65 61 6c 2d 73 74 61 74 75 73 29 ate real-status)
3f30: 29 29 0a 20 20 20 20 0a 20 20 20 20 3b 3b 20 69 )). . ;; i
3f40: 66 20 73 74 61 74 75 73 20 69 73 20 22 41 55 54 f status is "AUT
3f50: 4f 22 20 74 68 65 6e 20 63 61 6c 6c 20 72 6f 6c O" then call rol
3f60: 6c 75 70 20 28 6e 6f 74 65 2c 20 74 68 69 73 20 lup (note, this
3f70: 6f 6e 65 20 6d 6f 64 69 66 69 65 73 20 64 61 74 one modifies dat
3f80: 61 20 69 6e 20 74 65 73 74 0a 20 20 20 20 3b 3b a in test. ;;
3f90: 20 72 75 6e 20 61 72 65 61 2c 20 69 74 20 64 6f run area, it do
3fa0: 65 73 20 72 65 6d 6f 74 65 20 63 61 6c 6c 73 20 es remote calls
3fb0: 75 6e 64 65 72 20 74 68 65 20 68 6f 6f 64 2e 0a under the hood..
3fc0: 20 20 20 20 28 69 66 20 28 61 6e 64 20 74 65 73 (if (and tes
3fd0: 74 2d 69 64 20 73 74 61 74 65 20 73 74 61 74 75 t-id state statu
3fe0: 73 20 28 65 71 75 61 6c 3f 20 73 74 61 74 75 73 s (equal? status
3ff0: 20 22 41 55 54 4f 22 29 29 20 0a 09 28 72 6d 74 "AUTO")) ..(rmt
4000: 3a 74 65 73 74 2d 64 61 74 61 2d 72 6f 6c 6c 75 :test-data-rollu
4010: 70 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 69 64 p run-id test-id
4020: 20 73 74 61 74 75 73 29 29 0a 0a 20 20 20 20 3b status)).. ;
4030: 3b 20 61 64 64 20 6d 65 74 61 64 61 74 61 20 28 ; add metadata (
4040: 6e 65 65 64 20 74 6f 20 64 6f 20 74 68 69 73 20 need to do this
4050: 77 61 79 20 74 6f 20 61 76 6f 69 64 20 53 51 4c way to avoid SQL
4060: 20 69 6e 6a 65 63 74 69 6f 6e 20 69 73 73 75 65 injection issue
4070: 73 29 0a 0a 20 20 20 20 3b 3b 20 3a 66 69 72 73 s).. ;; :firs
4080: 74 5f 65 72 72 0a 20 20 20 20 3b 3b 20 28 6c 65 t_err. ;; (le
4090: 74 20 28 28 76 61 6c 20 28 68 61 73 68 2d 74 61 t ((val (hash-ta
40a0: 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 ble-ref/default
40b0: 6f 74 68 65 72 64 61 74 20 22 3a 66 69 72 73 74 otherdat ":first
40c0: 5f 65 72 72 22 20 23 66 29 29 29 0a 20 20 20 20 _err" #f))).
40d0: 3b 3b 20 20 20 28 69 66 20 76 61 6c 0a 20 20 20 ;; (if val.
40e0: 20 3b 3b 20 20 20 20 20 20 20 28 73 71 6c 69 74 ;; (sqlit
40f0: 65 33 3a 65 78 65 63 75 74 65 20 64 62 20 22 55 e3:execute db "U
4100: 50 44 41 54 45 20 74 65 73 74 73 20 53 45 54 20 PDATE tests SET
4110: 66 69 72 73 74 5f 65 72 72 3d 3f 20 57 48 45 52 first_err=? WHER
4120: 45 20 72 75 6e 5f 69 64 3d 3f 20 41 4e 44 20 74 E run_id=? AND t
4130: 65 73 74 6e 61 6d 65 3d 3f 20 41 4e 44 20 69 74 estname=? AND it
4140: 65 6d 5f 70 61 74 68 3d 3f 3b 22 20 76 61 6c 20 em_path=?;" val
4150: 72 75 6e 2d 69 64 20 74 65 73 74 2d 6e 61 6d 65 run-id test-name
4160: 20 69 74 65 6d 2d 70 61 74 68 29 29 29 0a 20 20 item-path))).
4170: 20 20 3b 3b 20 0a 20 20 20 20 3b 3b 20 3b 3b 20 ;; . ;; ;;
4180: 3a 66 69 72 73 74 5f 77 61 72 6e 0a 20 20 20 20 :first_warn.
4190: 3b 3b 20 28 6c 65 74 20 28 28 76 61 6c 20 28 68 ;; (let ((val (h
41a0: 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 ash-table-ref/de
41b0: 66 61 75 6c 74 20 6f 74 68 65 72 64 61 74 20 22 fault otherdat "
41c0: 3a 66 69 72 73 74 5f 77 61 72 6e 22 20 23 66 29 :first_warn" #f)
41d0: 29 29 0a 20 20 20 20 3b 3b 20 20 20 28 69 66 20 )). ;; (if
41e0: 76 61 6c 0a 20 20 20 20 3b 3b 20 20 20 20 20 20 val. ;;
41f0: 20 28 73 71 6c 69 74 65 33 3a 65 78 65 63 75 74 (sqlite3:execut
4200: 65 20 64 62 20 22 55 50 44 41 54 45 20 74 65 73 e db "UPDATE tes
4210: 74 73 20 53 45 54 20 66 69 72 73 74 5f 77 61 72 ts SET first_war
4220: 6e 3d 3f 20 57 48 45 52 45 20 72 75 6e 5f 69 64 n=? WHERE run_id
4230: 3d 3f 20 41 4e 44 20 74 65 73 74 6e 61 6d 65 3d =? AND testname=
4240: 3f 20 41 4e 44 20 69 74 65 6d 5f 70 61 74 68 3d ? AND item_path=
4250: 3f 3b 22 20 76 61 6c 20 72 75 6e 2d 69 64 20 74 ?;" val run-id t
4260: 65 73 74 2d 6e 61 6d 65 20 69 74 65 6d 2d 70 61 est-name item-pa
4270: 74 68 29 29 29 0a 0a 20 20 20 20 28 6c 65 74 20 th))).. (let
4280: 28 28 63 61 74 65 67 6f 72 79 20 28 68 61 73 68 ((category (hash
4290: 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 -table-ref/defau
42a0: 6c 74 20 6f 74 68 65 72 64 61 74 20 22 3a 63 61 lt otherdat ":ca
42b0: 74 65 67 6f 72 79 22 20 22 22 29 29 0a 09 20 20 tegory" ""))..
42c0: 28 76 61 72 69 61 62 6c 65 20 28 68 61 73 68 2d (variable (hash-
42d0: 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c table-ref/defaul
42e0: 74 20 6f 74 68 65 72 64 61 74 20 22 3a 76 61 72 t otherdat ":var
42f0: 69 61 62 6c 65 22 20 22 22 29 29 0a 09 20 20 28 iable" "")).. (
4300: 76 61 6c 75 65 20 20 20 20 28 68 61 73 68 2d 74 value (hash-t
4310: 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 able-ref/default
4320: 20 6f 74 68 65 72 64 61 74 20 22 3a 76 61 6c 75 otherdat ":valu
4330: 65 22 20 20 20 20 23 66 29 29 0a 09 20 20 28 65 e" #f)).. (e
4340: 78 70 65 63 74 65 64 20 28 68 61 73 68 2d 74 61 xpected (hash-ta
4350: 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 ble-ref/default
4360: 6f 74 68 65 72 64 61 74 20 22 3a 65 78 70 65 63 otherdat ":expec
4370: 74 65 64 22 20 23 66 29 29 0a 09 20 20 28 74 6f ted" #f)).. (to
4380: 6c 20 20 20 20 20 20 28 68 61 73 68 2d 74 61 62 l (hash-tab
4390: 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 6f le-ref/default o
43a0: 74 68 65 72 64 61 74 20 22 3a 74 6f 6c 22 20 20 therdat ":tol"
43b0: 20 20 20 20 23 66 29 29 0a 09 20 20 28 75 6e 69 #f)).. (uni
43c0: 74 73 20 20 20 20 28 68 61 73 68 2d 74 61 62 6c ts (hash-tabl
43d0: 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 6f 74 e-ref/default ot
43e0: 68 65 72 64 61 74 20 22 3a 75 6e 69 74 73 22 20 herdat ":units"
43f0: 20 20 20 22 22 29 29 0a 09 20 20 28 74 79 70 65 "")).. (type
4400: 20 20 20 20 20 28 68 61 73 68 2d 74 61 62 6c 65 (hash-table
4410: 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 6f 74 68 -ref/default oth
4420: 65 72 64 61 74 20 22 3a 74 79 70 65 22 20 20 20 erdat ":type"
4430: 20 20 22 22 29 29 0a 09 20 20 28 64 63 6f 6d 6d "")).. (dcomm
4440: 65 6e 74 20 28 68 61 73 68 2d 74 61 62 6c 65 2d ent (hash-table-
4450: 72 65 66 2f 64 65 66 61 75 6c 74 20 6f 74 68 65 ref/default othe
4460: 72 64 61 74 20 22 3a 63 6f 6d 6d 65 6e 74 22 20 rdat ":comment"
4470: 20 22 22 29 29 29 0a 20 20 20 20 20 20 28 64 65 ""))). (de
4480: 62 75 67 3a 70 72 69 6e 74 20 34 20 0a 09 09 20 bug:print 4 ...
4490: 20 20 22 63 61 74 65 67 6f 72 79 3a 20 22 20 63 "category: " c
44a0: 61 74 65 67 6f 72 79 20 22 2c 20 76 61 72 69 61 ategory ", varia
44b0: 62 6c 65 3a 20 22 20 76 61 72 69 61 62 6c 65 20 ble: " variable
44c0: 22 2c 20 76 61 6c 75 65 3a 20 22 20 76 61 6c 75 ", value: " valu
44d0: 65 0a 09 09 20 20 20 22 2c 20 65 78 70 65 63 74 e... ", expect
44e0: 65 64 3a 20 22 20 65 78 70 65 63 74 65 64 20 22 ed: " expected "
44f0: 2c 20 74 6f 6c 3a 20 22 20 74 6f 6c 20 22 2c 20 , tol: " tol ",
4500: 75 6e 69 74 73 3a 20 22 20 75 6e 69 74 73 29 0a units: " units).
4510: 20 20 20 20 20 20 28 69 66 20 28 61 6e 64 20 76 (if (and v
4520: 61 6c 75 65 20 65 78 70 65 63 74 65 64 20 74 6f alue expected to
4530: 6c 29 20 3b 3b 20 61 6c 6c 20 74 68 72 65 65 20 l) ;; all three
4540: 72 65 71 75 69 72 65 64 0a 09 20 20 28 6c 65 74 required.. (let
4550: 20 28 28 64 61 74 20 28 63 6f 6e 63 20 63 61 74 ((dat (conc cat
4560: 65 67 6f 72 79 20 22 2c 22 0a 09 09 09 20 20 20 egory ","....
4570: 76 61 72 69 61 62 6c 65 20 22 2c 22 0a 09 09 09 variable ","....
4580: 20 20 20 76 61 6c 75 65 20 20 20 20 22 2c 22 0a value ",".
4590: 09 09 09 20 20 20 65 78 70 65 63 74 65 64 20 22 ... expected "
45a0: 2c 22 0a 09 09 09 20 20 20 74 6f 6c 20 20 20 20 ,".... tol
45b0: 20 20 22 2c 22 0a 09 09 09 20 20 20 75 6e 69 74 ",".... unit
45c0: 73 20 20 20 20 22 2c 22 0a 09 09 09 20 20 20 64 s ",".... d
45d0: 63 6f 6d 6d 65 6e 74 20 22 2c 2c 22 20 3b 3b 20 comment ",," ;;
45e0: 65 78 74 72 61 20 63 6f 6d 6d 61 20 66 6f 72 20 extra comma for
45f0: 73 74 61 74 75 73 0a 09 09 09 20 20 20 74 79 70 status.... typ
4600: 65 20 20 20 20 20 29 29 29 0a 09 20 20 20 20 3b e ))).. ;
4610: 3b 20 54 68 69 73 20 77 61 73 20 72 75 6e 20 72 ; This was run r
4620: 65 6d 6f 74 65 2c 20 64 6f 6e 27 74 20 74 68 69 emote, don't thi
4630: 6e 6b 20 74 68 61 74 20 6d 61 6b 65 73 20 73 65 nk that makes se
4640: 6e 73 65 2e 20 50 65 72 68 61 70 73 20 6e 6f 74 nse. Perhaps not
4650: 2c 20 62 75 74 20 74 68 61 74 20 69 73 20 74 68 , but that is th
4660: 65 20 65 61 73 69 65 73 74 20 70 61 74 68 20 66 e easiest path f
4670: 6f 72 20 74 68 65 20 6d 6f 6d 65 6e 74 2e 0a 09 or the moment...
4680: 20 20 20 20 28 72 6d 74 3a 63 73 76 2d 3e 74 65 (rmt:csv->te
4690: 73 74 2d 64 61 74 61 20 72 75 6e 2d 69 64 20 74 st-data run-id t
46a0: 65 73 74 2d 69 64 0a 09 09 09 09 64 61 74 29 29 est-id.....dat))
46b0: 29 29 0a 20 20 20 20 20 20 0a 20 20 20 20 3b 3b )). . ;;
46c0: 20 6e 65 65 64 20 74 6f 20 75 70 64 61 74 65 20 need to update
46d0: 74 68 65 20 74 6f 70 20 74 65 73 74 20 72 65 63 the top test rec
46e0: 6f 72 64 20 69 66 20 50 41 53 53 20 6f 72 20 46 ord if PASS or F
46f0: 41 49 4c 20 61 6e 64 20 74 68 69 73 20 69 73 20 AIL and this is
4700: 61 20 73 75 62 74 65 73 74 0a 20 20 20 20 28 69 a subtest. (i
4710: 66 20 28 6e 6f 74 20 28 65 71 75 61 6c 3f 20 69 f (not (equal? i
4720: 74 65 6d 2d 70 61 74 68 20 22 22 29 29 0a 09 28 tem-path ""))..(
4730: 72 6d 74 3a 72 6f 6c 6c 2d 75 70 2d 70 61 73 73 rmt:roll-up-pass
4740: 2d 66 61 69 6c 2d 63 6f 75 6e 74 73 20 72 75 6e -fail-counts run
4750: 2d 69 64 20 74 65 73 74 2d 6e 61 6d 65 20 69 74 -id test-name it
4760: 65 6d 2d 70 61 74 68 20 73 74 61 74 65 20 73 74 em-path state st
4770: 61 74 75 73 29 29 0a 0a 20 20 20 20 28 69 66 20 atus)).. (if
4780: 28 6f 72 20 28 61 6e 64 20 28 73 74 72 69 6e 67 (or (and (string
4790: 3f 20 63 6f 6d 6d 65 6e 74 29 0a 09 09 20 28 73 ? comment)... (s
47a0: 74 72 69 6e 67 2d 6d 61 74 63 68 20 28 72 65 67 tring-match (reg
47b0: 65 78 70 20 22 5c 5c 53 2b 22 29 20 63 6f 6d 6d exp "\\S+") comm
47c0: 65 6e 74 29 29 0a 09 20 20 20 20 77 61 69 76 65 ent)).. waive
47d0: 64 29 0a 09 28 6c 65 74 20 28 28 63 6d 74 20 20 d)..(let ((cmt
47e0: 28 69 66 20 77 61 69 76 65 64 20 77 61 69 76 65 (if waived waive
47f0: 64 20 63 6f 6d 6d 65 6e 74 29 29 29 0a 09 20 20 d comment)))..
4800: 28 72 6d 74 3a 67 65 6e 65 72 61 6c 2d 63 61 6c (rmt:general-cal
4810: 6c 20 27 73 65 74 2d 74 65 73 74 2d 63 6f 6d 6d l 'set-test-comm
4820: 65 6e 74 20 72 75 6e 2d 69 64 20 63 6d 74 20 74 ent run-id cmt t
4830: 65 73 74 2d 69 64 29 29 29 29 29 0a 0a 28 64 65 est-id)))))..(de
4840: 66 69 6e 65 20 28 74 65 73 74 73 3a 74 65 73 74 fine (tests:test
4850: 2d 73 65 74 2d 74 6f 70 6c 6f 67 21 20 72 75 6e -set-toplog! run
4860: 2d 69 64 20 74 65 73 74 2d 6e 61 6d 65 20 6c 6f -id test-name lo
4870: 67 66 29 20 0a 20 20 28 72 6d 74 3a 67 65 6e 65 gf) . (rmt:gene
4880: 72 61 6c 2d 63 61 6c 6c 20 27 74 65 73 74 73 3a ral-call 'tests:
4890: 74 65 73 74 2d 73 65 74 2d 74 6f 70 6c 6f 67 20 test-set-toplog
48a0: 72 75 6e 2d 69 64 20 6c 6f 67 66 20 72 75 6e 2d run-id logf run-
48b0: 69 64 20 74 65 73 74 2d 6e 61 6d 65 29 29 0a 0a id test-name))..
48c0: 28 64 65 66 69 6e 65 20 28 74 65 73 74 73 3a 73 (define (tests:s
48d0: 75 6d 6d 61 72 69 7a 65 2d 69 74 65 6d 73 20 72 ummarize-items r
48e0: 75 6e 2d 69 64 20 74 65 73 74 2d 69 64 20 74 65 un-id test-id te
48f0: 73 74 2d 6e 61 6d 65 20 66 6f 72 63 65 29 0a 20 st-name force).
4900: 20 3b 3b 20 69 66 20 6e 6f 74 20 66 6f 72 63 65 ;; if not force
4910: 20 74 68 65 6e 20 6f 6e 6c 79 20 75 70 64 61 74 then only updat
4920: 65 20 74 68 65 20 72 65 63 6f 72 64 20 69 66 20 e the record if
4930: 6f 6e 65 20 6f 66 20 74 68 65 73 65 20 69 73 20 one of these is
4940: 74 72 75 65 3a 0a 20 20 3b 3b 20 20 20 31 2e 20 true:. ;; 1.
4950: 6c 6f 67 66 20 69 73 20 22 6c 6f 67 2f 66 69 6e logf is "log/fin
4960: 61 6c 2e 6c 6f 67 0a 20 20 3b 3b 20 20 20 32 2e al.log. ;; 2.
4970: 20 6c 6f 67 66 20 69 73 20 73 61 6d 65 20 61 73 logf is same as
4980: 20 6f 75 74 70 75 74 66 69 6c 65 6e 61 6d 65 0a outputfilename.
4990: 20 20 28 6c 65 74 2a 20 28 28 6f 75 74 70 75 74 (let* ((output
49a0: 66 69 6c 65 6e 61 6d 65 20 28 63 6f 6e 63 20 22 filename (conc "
49b0: 6d 65 67 61 74 65 73 74 2d 72 6f 6c 6c 75 70 2d megatest-rollup-
49c0: 22 20 74 65 73 74 2d 6e 61 6d 65 20 22 2e 68 74 " test-name ".ht
49d0: 6d 6c 22 29 29 0a 09 20 28 6f 72 69 67 2d 64 69 ml")).. (orig-di
49e0: 72 20 20 20 20 20 20 20 28 63 75 72 72 65 6e 74 r (current
49f0: 2d 64 69 72 65 63 74 6f 72 79 29 29 0a 09 20 28 -directory)).. (
4a00: 6c 6f 67 66 2d 69 6e 66 6f 20 20 20 20 20 20 28 logf-info (
4a10: 72 6d 74 3a 74 65 73 74 2d 67 65 74 2d 6c 6f 67 rmt:test-get-log
4a20: 66 69 6c 65 2d 69 6e 66 6f 20 72 75 6e 2d 69 64 file-info run-id
4a30: 20 74 65 73 74 2d 6e 61 6d 65 29 29 0a 09 20 28 test-name)).. (
4a40: 6c 6f 67 66 20 20 20 20 20 20 20 20 20 20 20 28 logf (
4a50: 69 66 20 6c 6f 67 66 2d 69 6e 66 6f 20 28 63 61 if logf-info (ca
4a60: 64 72 20 6c 6f 67 66 2d 69 6e 66 6f 29 20 23 66 dr logf-info) #f
4a70: 29 29 0a 09 20 28 70 61 74 68 20 20 20 20 20 20 )).. (path
4a80: 20 20 20 20 20 28 69 66 20 6c 6f 67 66 2d 69 6e (if logf-in
4a90: 66 6f 20 28 63 61 72 20 20 6c 6f 67 66 2d 69 6e fo (car logf-in
4aa0: 66 6f 29 20 23 66 29 29 29 0a 20 20 20 20 3b 3b fo) #f))). ;;
4ab0: 20 54 68 69 73 20 71 75 65 72 79 20 66 69 6e 64 This query find
4ac0: 73 20 74 68 65 20 70 61 74 68 20 61 6e 64 20 63 s the path and c
4ad0: 68 61 6e 67 65 73 20 74 68 65 20 64 69 72 65 63 hanges the direc
4ae0: 74 6f 72 79 20 74 6f 20 69 74 20 66 6f 72 20 74 tory to it for t
4af0: 68 65 20 74 65 73 74 0a 20 20 20 20 28 69 66 20 he test. (if
4b00: 28 61 6e 64 20 28 73 74 72 69 6e 67 3f 20 70 61 (and (string? pa
4b10: 74 68 29 0a 09 20 20 20 20 20 28 64 69 72 65 63 th).. (direc
4b20: 74 6f 72 79 3f 20 70 61 74 68 29 29 20 3b 3b 20 tory? path)) ;;
4b30: 63 61 6e 20 67 65 74 20 23 66 20 68 65 72 65 20 can get #f here
4b40: 75 6e 64 65 72 20 73 6f 6d 65 20 77 69 65 72 64 under some wierd
4b50: 20 63 6f 6e 64 69 74 69 6f 6e 73 2e 20 77 68 79 conditions. why
4b60: 2c 20 75 6e 6b 6e 6f 77 6e 20 2e 2e 2e 0a 09 28 , unknown .....(
4b70: 62 65 67 69 6e 0a 09 20 20 28 64 65 62 75 67 3a begin.. (debug:
4b80: 70 72 69 6e 74 20 34 20 22 46 6f 75 6e 64 20 70 print 4 "Found p
4b90: 61 74 68 3a 20 22 20 70 61 74 68 29 0a 09 20 20 ath: " path)..
4ba0: 28 63 68 61 6e 67 65 2d 64 69 72 65 63 74 6f 72 (change-director
4bb0: 79 20 70 61 74 68 29 29 0a 09 3b 3b 20 28 73 65 y path))..;; (se
4bc0: 74 21 20 6f 75 74 70 75 74 66 69 6c 65 6e 61 6d t! outputfilenam
4bd0: 65 20 28 63 6f 6e 63 20 70 61 74 68 20 22 2f 22 e (conc path "/"
4be0: 20 6f 75 74 70 75 74 66 69 6c 65 6e 61 6d 65 29 outputfilename)
4bf0: 29 29 0a 09 28 64 65 62 75 67 3a 70 72 69 6e 74 ))..(debug:print
4c00: 20 30 20 22 45 52 52 4f 52 3a 20 73 75 6d 6d 61 0 "ERROR: summa
4c10: 72 69 7a 65 2d 69 74 65 6d 73 20 66 6f 72 20 72 rize-items for r
4c20: 75 6e 2d 69 64 3d 22 20 72 75 6e 2d 69 64 20 22 un-id=" run-id "
4c30: 2c 20 74 65 73 74 2d 6e 61 6d 65 3d 22 20 74 65 , test-name=" te
4c40: 73 74 2d 6e 61 6d 65 20 22 2c 20 6e 6f 20 73 75 st-name ", no su
4c50: 63 68 20 70 61 74 68 3a 20 22 20 70 61 74 68 29 ch path: " path)
4c60: 29 0a 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 ). (debug:pri
4c70: 6e 74 20 34 20 22 73 75 6d 6d 61 72 69 7a 65 2d nt 4 "summarize-
4c80: 69 74 65 6d 73 20 77 69 74 68 20 6c 6f 67 66 20 items with logf
4c90: 22 20 6c 6f 67 66 20 22 2c 20 6f 75 74 70 75 74 " logf ", output
4ca0: 66 69 6c 65 6e 61 6d 65 20 22 20 6f 75 74 70 75 filename " outpu
4cb0: 74 66 69 6c 65 6e 61 6d 65 20 22 20 61 6e 64 20 tfilename " and
4cc0: 66 6f 72 63 65 20 22 20 66 6f 72 63 65 29 0a 20 force " force).
4cd0: 20 20 20 28 69 66 20 28 6f 72 20 28 65 71 75 61 (if (or (equa
4ce0: 6c 3f 20 6c 6f 67 66 20 22 6c 6f 67 73 2f 66 69 l? logf "logs/fi
4cf0: 6e 61 6c 2e 6c 6f 67 22 29 0a 09 20 20 20 20 28 nal.log").. (
4d00: 65 71 75 61 6c 3f 20 6c 6f 67 66 20 6f 75 74 70 equal? logf outp
4d10: 75 74 66 69 6c 65 6e 61 6d 65 29 0a 09 20 20 20 utfilename)..
4d20: 20 66 6f 72 63 65 29 0a 09 28 6c 65 74 20 28 28 force)..(let ((
4d30: 6d 79 2d 73 74 61 72 74 2d 74 69 6d 65 20 28 63 my-start-time (c
4d40: 75 72 72 65 6e 74 2d 73 65 63 6f 6e 64 73 29 29 urrent-seconds))
4d50: 0a 09 20 20 20 20 20 20 28 6c 6f 63 6b 66 20 20 .. (lockf
4d60: 20 20 20 20 20 20 20 28 63 6f 6e 63 20 6f 75 74 (conc out
4d70: 70 75 74 66 69 6c 65 6e 61 6d 65 20 22 2e 6c 6f putfilename ".lo
4d80: 63 6b 22 29 29 29 0a 09 20 20 28 6c 65 74 20 6c ck"))).. (let l
4d90: 6f 6f 70 20 28 28 68 61 76 65 2d 6c 6f 63 6b 20 oop ((have-lock
4da0: 20 28 63 6f 6d 6d 6f 6e 3a 73 69 6d 70 6c 65 2d (common:simple-
4db0: 66 69 6c 65 2d 6c 6f 63 6b 20 6c 6f 63 6b 66 29 file-lock lockf)
4dc0: 29 29 0a 09 20 20 20 20 28 69 66 20 68 61 76 65 )).. (if have
4dd0: 2d 6c 6f 63 6b 0a 09 09 28 6c 65 74 20 28 28 73 -lock...(let ((s
4de0: 63 72 69 70 74 20 28 63 6f 6e 66 69 67 66 3a 6c cript (configf:l
4df0: 6f 6f 6b 75 70 20 2a 63 6f 6e 66 69 67 64 61 74 ookup *configdat
4e00: 2a 20 22 74 65 73 74 72 6f 6c 6c 75 70 22 20 74 * "testrollup" t
4e10: 65 73 74 2d 6e 61 6d 65 29 29 29 0a 09 09 20 20 est-name)))...
4e20: 28 70 72 69 6e 74 20 22 4f 62 74 61 69 6e 65 64 (print "Obtained
4e30: 20 6c 6f 63 6b 20 66 6f 72 20 22 20 6f 75 74 70 lock for " outp
4e40: 75 74 66 69 6c 65 6e 61 6d 65 29 0a 09 09 20 20 utfilename)...
4e50: 3b 3b 20 28 72 6d 74 3a 74 6f 70 2d 74 65 73 74 ;; (rmt:top-test
4e60: 2d 73 65 74 2d 70 65 72 2d 70 66 2d 63 6f 75 6e -set-per-pf-coun
4e70: 74 73 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 6e ts run-id test-n
4e80: 61 6d 65 29 0a 09 09 20 20 28 72 6d 74 3a 72 6f ame)... (rmt:ro
4e90: 6c 6c 2d 75 70 2d 70 61 73 73 2d 66 61 69 6c 2d ll-up-pass-fail-
4ea0: 63 6f 75 6e 74 73 20 72 75 6e 2d 69 64 20 74 65 counts run-id te
4eb0: 73 74 2d 6e 61 6d 65 20 22 22 20 23 66 20 23 66 st-name "" #f #f
4ec0: 29 0a 09 09 20 20 28 72 6d 74 3a 74 6f 70 2d 74 )... (rmt:top-t
4ed0: 65 73 74 2d 73 65 74 2d 70 65 72 2d 70 66 2d 63 est-set-per-pf-c
4ee0: 6f 75 6e 74 73 20 72 75 6e 2d 69 64 20 74 65 73 ounts run-id tes
4ef0: 74 2d 6e 61 6d 65 29 0a 09 09 20 20 28 69 66 20 t-name)... (if
4f00: 73 63 72 69 70 74 0a 09 09 20 20 20 20 20 20 28 script... (
4f10: 73 79 73 74 65 6d 20 28 63 6f 6e 63 20 73 63 72 system (conc scr
4f20: 69 70 74 20 22 20 3e 20 22 20 6f 75 74 70 75 74 ipt " > " output
4f30: 66 69 6c 65 6e 61 6d 65 20 22 20 26 20 22 29 29 filename " & "))
4f40: 0a 09 09 20 20 20 20 20 20 28 74 65 73 74 73 3a ... (tests:
4f50: 67 65 6e 65 72 61 74 65 2d 68 74 6d 6c 2d 73 75 generate-html-su
4f60: 6d 6d 61 72 79 2d 66 6f 72 2d 69 74 65 72 61 74 mmary-for-iterat
4f70: 65 64 2d 74 65 73 74 20 72 75 6e 2d 69 64 20 74 ed-test run-id t
4f80: 65 73 74 2d 69 64 20 74 65 73 74 2d 6e 61 6d 65 est-id test-name
4f90: 20 6f 75 74 70 75 74 66 69 6c 65 6e 61 6d 65 29 outputfilename)
4fa0: 29 0a 09 09 20 20 28 63 6f 6d 6d 6f 6e 3a 73 69 )... (common:si
4fb0: 6d 70 6c 65 2d 66 69 6c 65 2d 72 65 6c 65 61 73 mple-file-releas
4fc0: 65 2d 6c 6f 63 6b 20 6c 6f 63 6b 66 29 0a 09 09 e-lock lockf)...
4fd0: 20 20 28 63 68 61 6e 67 65 2d 64 69 72 65 63 74 (change-direct
4fe0: 6f 72 79 20 6f 72 69 67 2d 64 69 72 29 0a 09 09 ory orig-dir)...
4ff0: 20 20 3b 3b 20 4e 42 2f 2f 20 74 65 73 74 73 3a ;; NB// tests:
5000: 74 65 73 74 2d 73 65 74 2d 74 6f 70 6c 6f 67 21 test-set-toplog!
5010: 20 69 73 20 72 65 6d 6f 74 65 20 69 6e 74 65 72 is remote inter
5020: 6e 61 6c 2e 2e 2e 0a 09 09 20 20 28 74 65 73 74 nal...... (test
5030: 73 3a 74 65 73 74 2d 73 65 74 2d 74 6f 70 6c 6f s:test-set-toplo
5040: 67 21 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 6e g! run-id test-n
5050: 61 6d 65 20 6f 75 74 70 75 74 66 69 6c 65 6e 61 ame outputfilena
5060: 6d 65 29 29 0a 09 09 3b 3b 20 64 69 64 6e 27 74 me))...;; didn't
5070: 20 67 65 74 20 74 68 65 20 6c 6f 63 6b 2c 20 63 get the lock, c
5080: 68 65 63 6b 20 74 6f 20 73 65 65 20 69 66 20 63 heck to see if c
5090: 75 72 72 65 6e 74 20 75 70 64 61 74 65 20 73 74 urrent update st
50a0: 61 72 74 65 64 20 6c 61 74 65 72 20 74 68 61 6e arted later than
50b0: 20 74 68 69 73 20 0a 09 09 3b 3b 20 75 70 64 61 this ...;; upda
50c0: 74 65 2c 20 69 66 20 73 6f 20 77 65 20 63 61 6e te, if so we can
50d0: 20 65 78 69 74 20 77 69 74 68 6f 75 74 20 64 6f exit without do
50e0: 69 6e 67 20 61 6e 79 20 77 6f 72 6b 0a 09 09 28 ing any work...(
50f0: 69 66 20 28 3e 20 6d 79 2d 73 74 61 72 74 2d 74 if (> my-start-t
5100: 69 6d 65 20 28 66 69 6c 65 2d 6d 6f 64 69 66 69 ime (file-modifi
5110: 63 61 74 69 6f 6e 2d 74 69 6d 65 20 6c 6f 63 6b cation-time lock
5120: 66 29 29 0a 09 09 20 20 20 20 3b 3b 20 77 65 20 f))... ;; we
5130: 73 74 61 72 74 65 64 20 73 69 6e 63 65 20 63 75 started since cu
5140: 72 72 65 6e 74 20 72 65 2d 67 65 6e 20 69 6e 20 rrent re-gen in
5150: 66 6c 69 67 68 74 2c 20 64 65 6c 61 79 20 61 20 flight, delay a
5160: 6c 69 74 74 6c 65 20 61 6e 64 20 74 72 79 20 61 little and try a
5170: 67 61 69 6e 0a 09 09 20 20 20 20 28 62 65 67 69 gain... (begi
5180: 6e 0a 09 09 20 20 20 20 20 20 28 64 65 62 75 67 n... (debug
5190: 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 31 20 22 57 :print-info 1 "W
51a0: 61 69 74 69 6e 67 20 74 6f 20 75 70 64 61 74 65 aiting to update
51b0: 20 22 20 6f 75 74 70 75 74 66 69 6c 65 6e 61 6d " outputfilenam
51c0: 65 20 22 2c 20 61 6e 6f 74 68 65 72 20 74 65 73 e ", another tes
51d0: 74 20 63 75 72 72 65 6e 74 6c 79 20 75 70 64 61 t currently upda
51e0: 74 69 6e 67 20 69 74 22 29 0a 09 09 20 20 20 20 ting it")...
51f0: 20 20 28 74 68 72 65 61 64 2d 73 6c 65 65 70 21 (thread-sleep!
5200: 20 28 2b 20 35 20 28 72 61 6e 64 6f 6d 20 35 29 (+ 5 (random 5)
5210: 29 29 20 3b 3b 20 64 65 6c 61 79 20 62 65 74 77 )) ;; delay betw
5220: 65 65 6e 20 35 20 61 6e 64 20 31 30 20 73 65 63 een 5 and 10 sec
5230: 6f 6e 64 73 0a 09 09 20 20 20 20 20 20 28 6c 6f onds... (lo
5240: 6f 70 20 28 63 6f 6d 6d 6f 6e 3a 73 69 6d 70 6c op (common:simpl
5250: 65 2d 66 69 6c 65 2d 6c 6f 63 6b 20 6c 6f 63 6b e-file-lock lock
5260: 66 29 29 29 29 29 29 29 29 29 29 0a 0a 28 64 65 f))))))))))..(de
5270: 66 69 6e 65 20 28 74 65 73 74 73 3a 67 65 6e 65 fine (tests:gene
5280: 72 61 74 65 2d 68 74 6d 6c 2d 73 75 6d 6d 61 72 rate-html-summar
5290: 79 2d 66 6f 72 2d 69 74 65 72 61 74 65 64 2d 74 y-for-iterated-t
52a0: 65 73 74 20 72 75 6e 2d 69 64 20 74 65 73 74 2d est run-id test-
52b0: 69 64 20 74 65 73 74 2d 6e 61 6d 65 20 6f 75 74 id test-name out
52c0: 70 75 74 66 69 6c 65 6e 61 6d 65 29 0a 20 20 28 putfilename). (
52d0: 6c 65 74 20 28 28 63 6f 75 6e 74 73 20 20 20 20 let ((counts
52e0: 20 20 20 20 20 20 20 20 20 20 28 6d 61 6b 65 2d (make-
52f0: 68 61 73 68 2d 74 61 62 6c 65 29 29 0a 09 28 73 hash-table))..(s
5300: 74 61 74 65 63 6f 75 6e 74 73 20 20 20 20 20 20 tatecounts
5310: 20 20 20 28 6d 61 6b 65 2d 68 61 73 68 2d 74 61 (make-hash-ta
5320: 62 6c 65 29 29 0a 09 28 6f 75 74 74 78 74 20 20 ble))..(outtxt
5330: 20 20 20 20 20 20 20 20 20 20 20 20 22 22 29 0a "").
5340: 09 28 74 6f 74 20 20 20 20 20 20 20 20 20 20 20 .(tot
5350: 20 20 20 20 20 20 30 29 0a 09 28 74 65 73 74 64 0)..(testd
5360: 61 74 20 20 20 20 20 20 20 20 20 20 20 20 20 28 at (
5370: 72 6d 74 3a 74 65 73 74 2d 67 65 74 2d 72 65 63 rmt:test-get-rec
5380: 6f 72 64 73 2d 66 6f 72 2d 69 6e 64 65 78 2d 66 ords-for-index-f
5390: 69 6c 65 20 72 75 6e 2d 69 64 20 74 65 73 74 2d ile run-id test-
53a0: 6e 61 6d 65 29 29 29 0a 20 20 20 20 28 77 69 74 name))). (wit
53b0: 68 2d 6f 75 74 70 75 74 2d 74 6f 2d 66 69 6c 65 h-output-to-file
53c0: 20 6f 75 74 70 75 74 66 69 6c 65 6e 61 6d 65 0a outputfilename.
53d0: 20 20 20 20 20 20 28 6c 61 6d 62 64 61 20 28 29 (lambda ()
53e0: 0a 09 28 73 65 74 21 20 6f 75 74 74 78 74 20 28 ..(set! outtxt (
53f0: 63 6f 6e 63 20 6f 75 74 74 78 74 20 22 3c 68 74 conc outtxt "<ht
5400: 6d 6c 3e 3c 74 69 74 6c 65 3e 53 75 6d 6d 61 72 ml><title>Summar
5410: 79 3a 20 22 20 74 65 73 74 2d 6e 61 6d 65 20 0a y: " test-name .
5420: 09 09 09 20 20 20 22 3c 2f 74 69 74 6c 65 3e 3c ... "</title><
5430: 62 6f 64 79 3e 3c 68 32 3e 53 75 6d 6d 61 72 79 body><h2>Summary
5440: 20 66 6f 72 20 22 20 74 65 73 74 2d 6e 61 6d 65 for " test-name
5450: 20 22 3c 2f 68 32 3e 22 29 29 0a 09 28 66 6f 72 "</h2>"))..(for
5460: 2d 65 61 63 68 0a 09 20 28 6c 61 6d 62 64 61 20 -each.. (lambda
5470: 28 74 65 73 74 72 65 63 6f 72 64 29 0a 09 20 20 (testrecord)..
5480: 20 28 6c 65 74 20 28 28 69 64 20 20 20 20 20 20 (let ((id
5490: 20 20 20 20 20 20 20 28 76 65 63 74 6f 72 2d 72 (vector-r
54a0: 65 66 20 74 65 73 74 72 65 63 6f 72 64 20 30 29 ef testrecord 0)
54b0: 29 0a 09 09 20 28 69 74 65 6d 70 61 74 68 20 20 )... (itempath
54c0: 20 20 20 20 20 28 76 65 63 74 6f 72 2d 72 65 66 (vector-ref
54d0: 20 74 65 73 74 72 65 63 6f 72 64 20 31 29 29 0a testrecord 1)).
54e0: 09 09 20 28 73 74 61 74 65 20 20 20 20 20 20 20 .. (state
54f0: 20 20 20 28 76 65 63 74 6f 72 2d 72 65 66 20 74 (vector-ref t
5500: 65 73 74 72 65 63 6f 72 64 20 32 29 29 0a 09 09 estrecord 2))...
5510: 20 28 73 74 61 74 75 73 20 20 20 20 20 20 20 20 (status
5520: 20 28 76 65 63 74 6f 72 2d 72 65 66 20 74 65 73 (vector-ref tes
5530: 74 72 65 63 6f 72 64 20 33 29 29 0a 09 09 20 28 trecord 3))... (
5540: 72 75 6e 5f 64 75 72 61 74 69 6f 6e 20 20 20 28 run_duration (
5550: 76 65 63 74 6f 72 2d 72 65 66 20 74 65 73 74 72 vector-ref testr
5560: 65 63 6f 72 64 20 34 29 29 0a 09 09 20 28 6c 6f ecord 4))... (lo
5570: 67 66 20 20 20 20 20 20 20 20 20 20 20 28 76 65 gf (ve
5580: 63 74 6f 72 2d 72 65 66 20 74 65 73 74 72 65 63 ctor-ref testrec
5590: 6f 72 64 20 35 29 29 0a 09 09 20 28 63 6f 6d 6d ord 5))... (comm
55a0: 65 6e 74 20 20 20 20 20 20 20 20 28 76 65 63 74 ent (vect
55b0: 6f 72 2d 72 65 66 20 74 65 73 74 72 65 63 6f 72 or-ref testrecor
55c0: 64 20 36 29 29 29 0a 09 20 20 20 20 20 28 68 61 d 6))).. (ha
55d0: 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 63 6f sh-table-set! co
55e0: 75 6e 74 73 20 73 74 61 74 75 73 20 28 2b 20 31 unts status (+ 1
55f0: 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 (hash-table-ref
5600: 2f 64 65 66 61 75 6c 74 20 63 6f 75 6e 74 73 20 /default counts
5610: 73 74 61 74 75 73 20 30 29 29 29 0a 09 20 20 20 status 0)))..
5620: 20 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 (hash-table-se
5630: 74 21 20 73 74 61 74 65 63 6f 75 6e 74 73 20 73 t! statecounts s
5640: 74 61 74 65 20 28 2b 20 31 20 28 68 61 73 68 2d tate (+ 1 (hash-
5650: 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c table-ref/defaul
5660: 74 20 73 74 61 74 65 63 6f 75 6e 74 73 20 73 74 t statecounts st
5670: 61 74 65 20 30 29 29 29 0a 09 20 20 20 20 20 28 ate 0))).. (
5680: 73 65 74 21 20 6f 75 74 74 78 74 20 28 63 6f 6e set! outtxt (con
5690: 63 20 6f 75 74 74 78 74 20 22 3c 74 72 3e 22 0a c outtxt "<tr>".
56a0: 09 09 09 09 3b 3b 20 22 3c 74 64 3e 3c 61 20 68 ....;; "<td><a h
56b0: 72 65 66 3d 5c 22 22 20 69 74 65 6d 70 61 74 68 ref=\"" itempath
56c0: 20 22 2f 22 20 6c 6f 67 66 20 22 5c 22 3e 20 22 "/" logf "\"> "
56d0: 20 69 74 65 6d 70 61 74 68 20 22 3c 2f 61 3e 3c itempath "</a><
56e0: 2f 74 64 3e 22 20 0a 09 09 09 09 22 3c 74 64 3e /td>" ....."<td>
56f0: 3c 61 20 68 72 65 66 3d 5c 22 22 20 69 74 65 6d <a href=\"" item
5700: 70 61 74 68 20 22 2f 74 65 73 74 2d 73 75 6d 6d path "/test-summ
5710: 61 72 79 2e 68 74 6d 6c 5c 22 3e 20 22 20 69 74 ary.html\"> " it
5720: 65 6d 70 61 74 68 20 22 3c 2f 61 3e 3c 2f 74 64 empath "</a></td
5730: 3e 22 20 0a 09 09 09 09 22 3c 74 64 3e 22 20 73 >" ....."<td>" s
5740: 74 61 74 65 20 20 20 20 22 3c 2f 74 64 3e 22 20 tate "</td>"
5750: 0a 09 09 09 09 22 3c 74 64 3e 3c 66 6f 6e 74 20 ....."<td><font
5760: 63 6f 6c 6f 72 3d 22 20 28 63 6f 6d 6d 6f 6e 3a color=" (common:
5770: 67 65 74 2d 63 6f 6c 6f 72 2d 66 72 6f 6d 2d 73 get-color-from-s
5780: 74 61 74 75 73 20 73 74 61 74 75 73 29 0a 09 09 tatus status)...
5790: 09 09 22 3e 22 20 20 20 73 74 61 74 75 73 20 20 ..">" status
57a0: 20 22 3c 2f 66 6f 6e 74 3e 3c 2f 74 64 3e 22 0a "</font></td>".
57b0: 09 09 09 09 22 3c 74 64 3e 22 20 28 69 66 20 28 ...."<td>" (if (
57c0: 65 71 75 61 6c 3f 20 63 6f 6d 6d 65 6e 74 20 22 equal? comment "
57d0: 22 29 0a 09 09 09 09 09 20 20 20 22 26 6e 62 73 ")...... "&nbs
57e0: 70 3b 22 0a 09 09 09 09 09 20 20 20 63 6f 6d 6d p;"...... comm
57f0: 65 6e 74 29 20 22 3c 2f 74 64 3e 22 0a 09 09 09 ent) "</td>"....
5800: 09 09 20 20 20 22 3c 2f 74 72 3e 22 29 29 29 29 .. "</tr>"))))
5810: 0a 09 20 28 69 66 20 28 6c 69 73 74 3f 20 74 65 .. (if (list? te
5820: 73 74 64 61 74 29 0a 09 20 20 20 20 20 74 65 73 stdat).. tes
5830: 74 64 61 74 0a 09 20 20 20 20 20 28 62 65 67 69 tdat.. (begi
5840: 6e 0a 09 20 20 20 20 20 20 20 28 70 72 69 6e 74 n.. (print
5850: 20 22 45 52 52 4f 52 3a 20 66 61 69 6c 65 64 20 "ERROR: failed
5860: 74 6f 20 67 65 74 20 72 65 63 6f 72 64 73 20 77 to get records w
5870: 69 74 68 20 72 6d 74 3a 74 65 73 74 2d 67 65 74 ith rmt:test-get
5880: 2d 72 65 63 6f 72 64 73 2d 66 6f 72 2d 69 6e 64 -records-for-ind
5890: 65 78 2d 66 69 6c 65 20 72 75 6e 2d 69 64 3d 22 ex-file run-id="
58a0: 20 72 75 6e 2d 69 64 20 22 74 65 73 74 2d 6e 61 run-id "test-na
58b0: 6d 65 3d 22 20 74 65 73 74 2d 6e 61 6d 65 29 0a me=" test-name).
58c0: 09 20 20 20 20 20 20 20 27 28 29 29 29 29 0a 09 . '())))..
58d0: 0a 09 28 70 72 69 6e 74 20 22 3c 74 61 62 6c 65 ..(print "<table
58e0: 3e 3c 74 72 3e 3c 74 64 20 76 61 6c 69 67 6e 3d ><tr><td valign=
58f0: 5c 22 74 6f 70 5c 22 3e 22 29 0a 09 3b 3b 20 50 \"top\">")..;; P
5900: 72 69 6e 74 20 6f 75 74 20 73 74 61 74 73 20 66 rint out stats f
5910: 6f 72 20 73 74 61 74 75 73 0a 09 28 73 65 74 21 or status..(set!
5920: 20 74 6f 74 20 30 29 0a 09 28 70 72 69 6e 74 20 tot 0)..(print
5930: 22 3c 74 61 62 6c 65 20 63 65 6c 6c 73 70 61 63 "<table cellspac
5940: 69 6e 67 3d 5c 22 30 5c 22 20 62 6f 72 64 65 72 ing=\"0\" border
5950: 3d 5c 22 31 5c 22 3e 3c 74 72 3e 3c 74 64 20 63 =\"1\"><tr><td c
5960: 6f 6c 73 70 61 6e 3d 5c 22 32 5c 22 3e 3c 68 32 olspan=\"2\"><h2
5970: 3e 53 74 61 74 65 20 73 74 61 74 73 3c 2f 68 32 >State stats</h2
5980: 3e 3c 2f 74 64 3e 3c 2f 74 72 3e 22 29 0a 09 28 ></td></tr>")..(
5990: 66 6f 72 2d 65 61 63 68 20 28 6c 61 6d 62 64 61 for-each (lambda
59a0: 20 28 73 74 61 74 65 29 0a 09 09 20 20 20 20 28 (state)... (
59b0: 73 65 74 21 20 74 6f 74 20 28 2b 20 74 6f 74 20 set! tot (+ tot
59c0: 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 20 (hash-table-ref
59d0: 73 74 61 74 65 63 6f 75 6e 74 73 20 73 74 61 74 statecounts stat
59e0: 65 29 29 29 0a 09 09 20 20 20 20 28 70 72 69 6e e)))... (prin
59f0: 74 20 22 3c 74 72 3e 3c 74 64 3e 22 20 73 74 61 t "<tr><td>" sta
5a00: 74 65 20 22 3c 2f 74 64 3e 3c 74 64 3e 22 20 28 te "</td><td>" (
5a10: 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 20 73 hash-table-ref s
5a20: 74 61 74 65 63 6f 75 6e 74 73 20 73 74 61 74 65 tatecounts state
5a30: 29 20 22 3c 2f 74 64 3e 3c 2f 74 72 3e 22 29 29 ) "</td></tr>"))
5a40: 0a 09 09 20 20 28 68 61 73 68 2d 74 61 62 6c 65 ... (hash-table
5a50: 2d 6b 65 79 73 20 73 74 61 74 65 63 6f 75 6e 74 -keys statecount
5a60: 73 29 29 0a 09 28 70 72 69 6e 74 20 22 3c 74 72 s))..(print "<tr
5a70: 3e 3c 74 64 3e 54 6f 74 61 6c 3c 2f 74 64 3e 3c ><td>Total</td><
5a80: 74 64 3e 22 20 74 6f 74 20 22 3c 2f 74 64 3e 3c td>" tot "</td><
5a90: 2f 74 72 3e 3c 2f 74 61 62 6c 65 3e 22 29 0a 09 /tr></table>")..
5aa0: 28 70 72 69 6e 74 20 22 3c 2f 74 64 3e 3c 74 64 (print "</td><td
5ab0: 20 76 61 6c 69 67 6e 3d 5c 22 74 6f 70 5c 22 3e valign=\"top\">
5ac0: 22 29 0a 09 3b 3b 20 50 72 69 6e 74 20 6f 75 74 ")..;; Print out
5ad0: 20 73 74 61 74 73 20 66 6f 72 20 73 74 61 74 65 stats for state
5ae0: 0a 09 28 73 65 74 21 20 74 6f 74 20 30 29 0a 09 ..(set! tot 0)..
5af0: 28 70 72 69 6e 74 20 22 3c 74 61 62 6c 65 20 63 (print "<table c
5b00: 65 6c 6c 73 70 61 63 69 6e 67 3d 5c 22 30 5c 22 ellspacing=\"0\"
5b10: 20 62 6f 72 64 65 72 3d 5c 22 31 5c 22 3e 3c 74 border=\"1\"><t
5b20: 72 3e 3c 74 64 20 63 6f 6c 73 70 61 6e 3d 5c 22 r><td colspan=\"
5b30: 32 5c 22 3e 3c 68 32 3e 53 74 61 74 75 73 20 73 2\"><h2>Status s
5b40: 74 61 74 73 3c 2f 68 32 3e 3c 2f 74 64 3e 3c 2f tats</h2></td></
5b50: 74 72 3e 22 29 0a 09 28 66 6f 72 2d 65 61 63 68 tr>")..(for-each
5b60: 20 28 6c 61 6d 62 64 61 20 28 73 74 61 74 75 73 (lambda (status
5b70: 29 0a 09 09 20 20 20 20 28 73 65 74 21 20 74 6f )... (set! to
5b80: 74 20 28 2b 20 74 6f 74 20 28 68 61 73 68 2d 74 t (+ tot (hash-t
5b90: 61 62 6c 65 2d 72 65 66 20 63 6f 75 6e 74 73 20 able-ref counts
5ba0: 73 74 61 74 75 73 29 29 29 0a 09 09 20 20 20 20 status)))...
5bb0: 28 70 72 69 6e 74 20 22 3c 74 72 3e 3c 74 64 3e (print "<tr><td>
5bc0: 3c 66 6f 6e 74 20 63 6f 6c 6f 72 3d 5c 22 22 20 <font color=\""
5bd0: 28 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 63 6f 6c 6f (common:get-colo
5be0: 72 2d 66 72 6f 6d 2d 73 74 61 74 75 73 20 73 74 r-from-status st
5bf0: 61 74 75 73 29 20 22 5c 22 3e 22 20 73 74 61 74 atus) "\">" stat
5c00: 75 73 0a 09 09 09 20 20 20 22 3c 2f 66 6f 6e 74 us.... "</font
5c10: 3e 3c 2f 74 64 3e 3c 74 64 3e 22 20 28 68 61 73 ></td><td>" (has
5c20: 68 2d 74 61 62 6c 65 2d 72 65 66 20 63 6f 75 6e h-table-ref coun
5c30: 74 73 20 73 74 61 74 75 73 29 20 22 3c 2f 74 64 ts status) "</td
5c40: 3e 3c 2f 74 72 3e 22 29 29 0a 09 09 20 20 28 68 ></tr>"))... (h
5c50: 61 73 68 2d 74 61 62 6c 65 2d 6b 65 79 73 20 63 ash-table-keys c
5c60: 6f 75 6e 74 73 29 29 0a 09 28 70 72 69 6e 74 20 ounts))..(print
5c70: 22 3c 74 72 3e 3c 74 64 3e 54 6f 74 61 6c 3c 2f "<tr><td>Total</
5c80: 74 64 3e 3c 74 64 3e 22 20 74 6f 74 20 22 3c 2f td><td>" tot "</
5c90: 74 64 3e 3c 2f 74 72 3e 3c 2f 74 61 62 6c 65 3e td></tr></table>
5ca0: 22 29 0a 09 28 70 72 69 6e 74 20 22 3c 2f 74 64 ")..(print "</td
5cb0: 3e 3c 2f 74 64 3e 3c 2f 74 72 3e 3c 2f 74 61 62 ></td></tr></tab
5cc0: 6c 65 3e 22 29 0a 09 0a 09 28 70 72 69 6e 74 20 le>")....(print
5cd0: 22 3c 74 61 62 6c 65 20 63 65 6c 6c 73 70 61 63 "<table cellspac
5ce0: 69 6e 67 3d 5c 22 30 5c 22 20 62 6f 72 64 65 72 ing=\"0\" border
5cf0: 3d 5c 22 31 5c 22 3e 22 20 0a 09 20 20 20 20 20 =\"1\">" ..
5d00: 20 20 22 3c 74 72 3e 3c 74 64 3e 49 74 65 6d 3c "<tr><td>Item<
5d10: 2f 74 64 3e 3c 74 64 3e 53 74 61 74 65 3c 2f 74 /td><td>State</t
5d20: 64 3e 3c 74 64 3e 53 74 61 74 75 73 3c 2f 74 64 d><td>Status</td
5d30: 3e 3c 74 64 3e 43 6f 6d 6d 65 6e 74 3c 2f 74 64 ><td>Comment</td
5d40: 3e 22 0a 09 20 20 20 20 20 20 20 6f 75 74 74 78 >".. outtx
5d50: 74 20 22 3c 2f 74 61 62 6c 65 3e 3c 2f 62 6f 64 t "</table></bod
5d60: 79 3e 3c 2f 68 74 6d 6c 3e 22 29 0a 09 3b 3b 20 y></html>")..;;
5d70: 28 72 65 6c 65 61 73 65 2d 64 6f 74 2d 6c 6f 63 (release-dot-loc
5d80: 6b 20 6f 75 74 70 75 74 66 69 6c 65 6e 61 6d 65 k outputfilename
5d90: 29 0a 09 3b 3b 28 72 6d 74 3a 75 70 64 61 74 65 )..;;(rmt:update
5da0: 2d 72 75 6e 2d 73 74 61 74 73 20 0a 09 3b 3b 20 -run-stats ..;;
5db0: 72 75 6e 2d 69 64 0a 09 3b 3b 20 28 68 61 73 68 run-id..;; (hash
5dc0: 2d 74 61 62 6c 65 2d 6d 61 70 0a 09 3b 3b 20 20 -table-map..;;
5dd0: 73 74 61 74 65 2d 73 74 61 74 75 73 2d 63 6f 75 state-status-cou
5de0: 6e 74 73 0a 09 3b 3b 20 20 28 6c 61 6d 62 64 61 nts..;; (lambda
5df0: 20 28 6b 65 79 20 76 61 6c 29 0a 09 3b 3b 09 28 (key val)..;;.(
5e00: 61 70 70 65 6e 64 20 6b 65 79 20 28 6c 69 73 74 append key (list
5e10: 20 76 61 6c 29 29 29 29 29 0a 09 29 29 29 29 0a val)))))..)))).
5e20: 0a 3b 3b 20 43 48 45 43 4b 20 2d 20 57 41 53 20 .;; CHECK - WAS
5e30: 54 48 49 53 20 41 44 44 45 44 20 4f 52 20 52 45 THIS ADDED OR RE
5e40: 4d 4f 56 45 44 3f 20 4d 41 4e 55 41 4c 20 4d 45 MOVED? MANUAL ME
5e50: 52 47 45 20 57 49 54 48 20 41 50 49 20 53 54 55 RGE WITH API STU
5e60: 46 46 21 21 21 0a 3b 3b 0a 3b 3b 20 67 65 74 20 FF!!!.;;.;; get
5e70: 61 20 70 72 65 74 74 79 20 74 61 62 6c 65 20 74 a pretty table t
5e80: 6f 20 73 75 6d 6d 61 72 69 7a 65 20 73 74 65 70 o summarize step
5e90: 73 0a 3b 3b 0a 3b 3b 20 28 64 65 66 69 6e 65 20 s.;;.;; (define
5ea0: 28 64 63 6f 6d 6d 6f 6e 3a 70 72 6f 63 65 73 73 (dcommon:process
5eb0: 2d 73 74 65 70 73 2d 74 61 62 6c 65 20 73 74 65 -steps-table ste
5ec0: 70 73 29 3b 3b 20 64 62 20 74 65 73 74 2d 69 64 ps);; db test-id
5ed0: 20 23 21 6b 65 79 20 28 77 6f 72 6b 2d 61 72 65 #!key (work-are
5ee0: 61 20 23 66 29 29 0a 28 64 65 66 69 6e 65 20 28 a #f)).(define (
5ef0: 74 65 73 74 73 3a 70 72 6f 63 65 73 73 2d 73 74 tests:process-st
5f00: 65 70 73 2d 74 61 62 6c 65 20 73 74 65 70 73 29 eps-table steps)
5f10: 3b 3b 20 64 62 20 74 65 73 74 2d 69 64 20 23 21 ;; db test-id #!
5f20: 6b 65 79 20 28 77 6f 72 6b 2d 61 72 65 61 20 23 key (work-area #
5f30: 66 29 29 0a 3b 3b 20 20 28 6c 65 74 20 28 28 73 f)).;; (let ((s
5f40: 74 65 70 73 20 20 20 28 64 62 3a 67 65 74 2d 73 teps (db:get-s
5f50: 74 65 70 73 2d 66 6f 72 2d 74 65 73 74 20 64 62 teps-for-test db
5f60: 20 74 65 73 74 2d 69 64 20 77 6f 72 6b 2d 61 72 test-id work-ar
5f70: 65 61 3a 20 77 6f 72 6b 2d 61 72 65 61 29 29 29 ea: work-area)))
5f80: 0a 20 20 20 20 3b 3b 20 6f 72 67 61 6e 69 73 65 . ;; organise
5f90: 20 74 68 65 20 73 74 65 70 73 20 66 6f 72 20 62 the steps for b
5fa0: 65 74 74 65 72 20 72 65 61 64 61 62 69 6c 69 74 etter readabilit
5fb0: 79 0a 20 20 20 20 28 6c 65 74 20 28 28 72 65 73 y. (let ((res
5fc0: 20 28 6d 61 6b 65 2d 68 61 73 68 2d 74 61 62 6c (make-hash-tabl
5fd0: 65 29 29 29 0a 20 20 20 20 20 20 28 66 6f 72 2d e))). (for-
5fe0: 65 61 63 68 20 0a 20 20 20 20 20 20 20 28 6c 61 each . (la
5ff0: 6d 62 64 61 20 28 73 74 65 70 29 0a 09 20 28 64 mbda (step).. (d
6000: 65 62 75 67 3a 70 72 69 6e 74 20 36 20 22 73 74 ebug:print 6 "st
6010: 65 70 3d 22 20 73 74 65 70 29 0a 09 20 28 6c 65 ep=" step).. (le
6020: 74 20 28 28 72 65 63 6f 72 64 20 28 68 61 73 68 t ((record (hash
6030: 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 -table-ref/defau
6040: 6c 74 20 0a 09 09 09 72 65 73 20 0a 09 09 09 28 lt ....res ....(
6050: 74 64 62 3a 73 74 65 70 2d 67 65 74 2d 73 74 65 tdb:step-get-ste
6060: 70 6e 61 6d 65 20 73 74 65 70 29 20 0a 09 09 09 pname step) ....
6070: 3b 3b 20 20 20 20 20 20 20 20 73 74 65 70 6e 61 ;; stepna
6080: 6d 65 20 20 20 20 20 20 20 20 20 20 20 20 20 20 me
6090: 20 20 73 74 61 72 74 20 65 6e 64 20 73 74 61 74 start end stat
60a0: 75 73 20 44 75 72 61 74 69 6f 6e 20 20 4c 6f 67 us Duration Log
60b0: 66 69 6c 65 20 43 6f 6d 6d 65 6e 74 0a 09 09 09 file Comment....
60c0: 28 76 65 63 74 6f 72 20 28 74 64 62 3a 73 74 65 (vector (tdb:ste
60d0: 70 2d 67 65 74 2d 73 74 65 70 6e 61 6d 65 20 73 p-get-stepname s
60e0: 74 65 70 29 20 22 22 20 20 20 22 22 20 22 22 20 tep) "" "" ""
60f0: 20 20 20 20 22 22 20 20 20 20 20 20 20 20 22 22 "" ""
6100: 20 20 20 20 20 22 22 29 29 29 29 0a 09 20 20 20 ""))))..
6110: 28 64 65 62 75 67 3a 70 72 69 6e 74 20 36 20 22 (debug:print 6 "
6120: 72 65 63 6f 72 64 28 62 65 66 6f 72 65 29 20 3d record(before) =
6130: 20 22 20 72 65 63 6f 72 64 20 0a 09 09 09 22 5c " record ...."\
6140: 6e 69 64 3a 20 20 20 20 20 20 20 22 20 28 74 64 nid: " (td
6150: 62 3a 73 74 65 70 2d 67 65 74 2d 69 64 20 73 74 b:step-get-id st
6160: 65 70 29 0a 09 09 09 22 5c 6e 73 74 65 70 6e 61 ep)...."\nstepna
6170: 6d 65 3a 20 22 20 28 74 64 62 3a 73 74 65 70 2d me: " (tdb:step-
6180: 67 65 74 2d 73 74 65 70 6e 61 6d 65 20 73 74 65 get-stepname ste
6190: 70 29 0a 09 09 09 22 5c 6e 73 74 61 74 65 3a 20 p)...."\nstate:
61a0: 20 20 20 22 20 28 74 64 62 3a 73 74 65 70 2d 67 " (tdb:step-g
61b0: 65 74 2d 73 74 61 74 65 20 73 74 65 70 29 0a 09 et-state step)..
61c0: 09 09 22 5c 6e 73 74 61 74 75 73 3a 20 20 20 22 .."\nstatus: "
61d0: 20 28 74 64 62 3a 73 74 65 70 2d 67 65 74 2d 73 (tdb:step-get-s
61e0: 74 61 74 75 73 20 73 74 65 70 29 0a 09 09 09 22 tatus step)...."
61f0: 5c 6e 74 69 6d 65 3a 20 20 20 20 20 22 20 28 74 \ntime: " (t
6200: 64 62 3a 73 74 65 70 2d 67 65 74 2d 65 76 65 6e db:step-get-even
6210: 74 5f 74 69 6d 65 20 73 74 65 70 29 29 0a 09 20 t_time step))..
6220: 20 20 28 63 61 73 65 20 28 73 74 72 69 6e 67 2d (case (string-
6230: 3e 73 79 6d 62 6f 6c 20 28 74 64 62 3a 73 74 65 >symbol (tdb:ste
6240: 70 2d 67 65 74 2d 73 74 61 74 65 20 73 74 65 70 p-get-state step
6250: 29 29 0a 09 20 20 20 20 20 28 28 73 74 61 72 74 )).. ((start
6260: 29 28 76 65 63 74 6f 72 2d 73 65 74 21 20 72 65 )(vector-set! re
6270: 63 6f 72 64 20 31 20 28 74 64 62 3a 73 74 65 70 cord 1 (tdb:step
6280: 2d 67 65 74 2d 65 76 65 6e 74 5f 74 69 6d 65 20 -get-event_time
6290: 73 74 65 70 29 29 0a 09 20 20 20 20 20 20 28 76 step)).. (v
62a0: 65 63 74 6f 72 2d 73 65 74 21 20 72 65 63 6f 72 ector-set! recor
62b0: 64 20 33 20 28 69 66 20 28 65 71 75 61 6c 3f 20 d 3 (if (equal?
62c0: 28 76 65 63 74 6f 72 2d 72 65 66 20 72 65 63 6f (vector-ref reco
62d0: 72 64 20 33 29 20 22 22 29 0a 09 09 09 09 09 28 rd 3) "")......(
62e0: 74 64 62 3a 73 74 65 70 2d 67 65 74 2d 73 74 61 tdb:step-get-sta
62f0: 74 75 73 20 73 74 65 70 29 29 29 0a 09 20 20 20 tus step)))..
6300: 20 20 20 28 69 66 20 28 3e 20 28 73 74 72 69 6e (if (> (strin
6310: 67 2d 6c 65 6e 67 74 68 20 28 74 64 62 3a 73 74 g-length (tdb:st
6320: 65 70 2d 67 65 74 2d 6c 6f 67 66 69 6c 65 20 73 ep-get-logfile s
6330: 74 65 70 29 29 0a 09 09 20 20 20 20 20 30 29 0a tep))... 0).
6340: 09 09 20 20 28 76 65 63 74 6f 72 2d 73 65 74 21 .. (vector-set!
6350: 20 72 65 63 6f 72 64 20 35 20 28 74 64 62 3a 73 record 5 (tdb:s
6360: 74 65 70 2d 67 65 74 2d 6c 6f 67 66 69 6c 65 20 tep-get-logfile
6370: 73 74 65 70 29 29 29 29 0a 09 20 20 20 20 20 28 step)))).. (
6380: 28 65 6e 64 29 20 20 0a 09 20 20 20 20 20 20 28 (end) .. (
6390: 76 65 63 74 6f 72 2d 73 65 74 21 20 72 65 63 6f vector-set! reco
63a0: 72 64 20 32 20 28 61 6e 79 2d 3e 6e 75 6d 62 65 rd 2 (any->numbe
63b0: 72 20 28 74 64 62 3a 73 74 65 70 2d 67 65 74 2d r (tdb:step-get-
63c0: 65 76 65 6e 74 5f 74 69 6d 65 20 73 74 65 70 29 event_time step)
63d0: 29 29 0a 09 20 20 20 20 20 20 28 76 65 63 74 6f )).. (vecto
63e0: 72 2d 73 65 74 21 20 72 65 63 6f 72 64 20 33 20 r-set! record 3
63f0: 28 74 64 62 3a 73 74 65 70 2d 67 65 74 2d 73 74 (tdb:step-get-st
6400: 61 74 75 73 20 73 74 65 70 29 29 0a 09 20 20 20 atus step))..
6410: 20 20 20 28 76 65 63 74 6f 72 2d 73 65 74 21 20 (vector-set!
6420: 72 65 63 6f 72 64 20 34 20 28 6c 65 74 20 28 28 record 4 (let ((
6430: 73 74 61 72 74 74 20 28 61 6e 79 2d 3e 6e 75 6d startt (any->num
6440: 62 65 72 20 28 76 65 63 74 6f 72 2d 72 65 66 20 ber (vector-ref
6450: 72 65 63 6f 72 64 20 31 29 29 29 0a 09 09 09 09 record 1))).....
6460: 09 20 20 28 65 6e 64 74 20 20 20 28 61 6e 79 2d . (endt (any-
6470: 3e 6e 75 6d 62 65 72 20 28 76 65 63 74 6f 72 2d >number (vector-
6480: 72 65 66 20 72 65 63 6f 72 64 20 32 29 29 29 29 ref record 2))))
6490: 0a 09 09 09 09 20 20 20 20 20 20 28 64 65 62 75 ..... (debu
64a0: 67 3a 70 72 69 6e 74 20 34 20 22 72 65 63 6f 72 g:print 4 "recor
64b0: 64 5b 31 5d 3d 22 20 28 76 65 63 74 6f 72 2d 72 d[1]=" (vector-r
64c0: 65 66 20 72 65 63 6f 72 64 20 31 29 20 0a 09 09 ef record 1) ...
64d0: 09 09 09 09 20 20 20 22 2c 20 73 74 61 72 74 74 .... ", startt
64e0: 3d 22 20 73 74 61 72 74 74 20 22 2c 20 65 6e 64 =" startt ", end
64f0: 74 3d 22 20 65 6e 64 74 0a 09 09 09 09 09 09 20 t=" endt.......
6500: 20 20 22 2c 20 67 65 74 2d 73 74 61 74 75 73 3a ", get-status:
6510: 20 22 20 28 74 64 62 3a 73 74 65 70 2d 67 65 74 " (tdb:step-get
6520: 2d 73 74 61 74 75 73 20 73 74 65 70 29 29 0a 09 -status step))..
6530: 09 09 09 20 20 20 20 20 20 28 69 66 20 28 61 6e ... (if (an
6540: 64 20 28 6e 75 6d 62 65 72 3f 20 73 74 61 72 74 d (number? start
6550: 74 29 28 6e 75 6d 62 65 72 3f 20 65 6e 64 74 29 t)(number? endt)
6560: 29 0a 09 09 09 09 09 20 20 28 73 65 63 6f 6e 64 )...... (second
6570: 73 2d 3e 68 72 2d 6d 69 6e 2d 73 65 63 20 28 2d s->hr-min-sec (-
6580: 20 65 6e 64 74 20 73 74 61 72 74 74 29 29 20 22 endt startt)) "
6590: 2d 31 22 29 29 29 0a 09 20 20 20 20 20 20 28 69 -1"))).. (i
65a0: 66 20 28 3e 20 28 73 74 72 69 6e 67 2d 6c 65 6e f (> (string-len
65b0: 67 74 68 20 28 74 64 62 3a 73 74 65 70 2d 67 65 gth (tdb:step-ge
65c0: 74 2d 6c 6f 67 66 69 6c 65 20 73 74 65 70 29 29 t-logfile step))
65d0: 0a 09 09 20 20 20 20 20 30 29 0a 09 09 20 20 28 ... 0)... (
65e0: 76 65 63 74 6f 72 2d 73 65 74 21 20 72 65 63 6f vector-set! reco
65f0: 72 64 20 35 20 28 74 64 62 3a 73 74 65 70 2d 67 rd 5 (tdb:step-g
6600: 65 74 2d 6c 6f 67 66 69 6c 65 20 73 74 65 70 29 et-logfile step)
6610: 29 29 0a 09 20 20 20 20 20 20 28 69 66 20 28 3e )).. (if (>
6620: 20 28 73 74 72 69 6e 67 2d 6c 65 6e 67 74 68 20 (string-length
6630: 28 74 64 62 3a 73 74 65 70 2d 67 65 74 2d 63 6f (tdb:step-get-co
6640: 6d 6d 65 6e 74 20 73 74 65 70 29 29 0a 09 09 20 mment step))...
6650: 20 20 20 20 30 29 0a 09 09 20 20 28 76 65 63 74 0)... (vect
6660: 6f 72 2d 73 65 74 21 20 72 65 63 6f 72 64 20 36 or-set! record 6
6670: 20 28 74 64 62 3a 73 74 65 70 2d 67 65 74 2d 63 (tdb:step-get-c
6680: 6f 6d 6d 65 6e 74 20 73 74 65 70 29 29 29 29 0a omment step)))).
6690: 09 20 20 20 20 20 28 65 6c 73 65 0a 09 20 20 20 . (else..
66a0: 20 20 20 28 76 65 63 74 6f 72 2d 73 65 74 21 20 (vector-set!
66b0: 72 65 63 6f 72 64 20 32 20 28 74 64 62 3a 73 74 record 2 (tdb:st
66c0: 65 70 2d 67 65 74 2d 73 74 61 74 65 20 73 74 65 ep-get-state ste
66d0: 70 29 29 0a 09 20 20 20 20 20 20 28 76 65 63 74 p)).. (vect
66e0: 6f 72 2d 73 65 74 21 20 72 65 63 6f 72 64 20 33 or-set! record 3
66f0: 20 28 74 64 62 3a 73 74 65 70 2d 67 65 74 2d 73 (tdb:step-get-s
6700: 74 61 74 75 73 20 73 74 65 70 29 29 0a 09 20 20 tatus step))..
6710: 20 20 20 20 28 76 65 63 74 6f 72 2d 73 65 74 21 (vector-set!
6720: 20 72 65 63 6f 72 64 20 34 20 28 74 64 62 3a 73 record 4 (tdb:s
6730: 74 65 70 2d 67 65 74 2d 65 76 65 6e 74 5f 74 69 tep-get-event_ti
6740: 6d 65 20 73 74 65 70 29 29 0a 09 20 20 20 20 20 me step))..
6750: 20 28 76 65 63 74 6f 72 2d 73 65 74 21 20 72 65 (vector-set! re
6760: 63 6f 72 64 20 36 20 28 74 64 62 3a 73 74 65 70 cord 6 (tdb:step
6770: 2d 67 65 74 2d 63 6f 6d 6d 65 6e 74 20 73 74 65 -get-comment ste
6780: 70 29 29 29 29 0a 09 20 20 20 28 68 61 73 68 2d p)))).. (hash-
6790: 74 61 62 6c 65 2d 73 65 74 21 20 72 65 73 20 28 table-set! res (
67a0: 74 64 62 3a 73 74 65 70 2d 67 65 74 2d 73 74 65 tdb:step-get-ste
67b0: 70 6e 61 6d 65 20 73 74 65 70 29 20 72 65 63 6f pname step) reco
67c0: 72 64 29 0a 09 20 20 20 28 64 65 62 75 67 3a 70 rd).. (debug:p
67d0: 72 69 6e 74 20 36 20 22 72 65 63 6f 72 64 28 61 rint 6 "record(a
67e0: 66 74 65 72 29 20 20 3d 20 22 20 72 65 63 6f 72 fter) = " recor
67f0: 64 20 0a 09 09 09 22 5c 6e 69 64 3a 20 20 20 20 d ...."\nid:
6800: 20 20 20 22 20 28 74 64 62 3a 73 74 65 70 2d 67 " (tdb:step-g
6810: 65 74 2d 69 64 20 73 74 65 70 29 0a 09 09 09 22 et-id step)...."
6820: 5c 6e 73 74 65 70 6e 61 6d 65 3a 20 22 20 28 74 \nstepname: " (t
6830: 64 62 3a 73 74 65 70 2d 67 65 74 2d 73 74 65 70 db:step-get-step
6840: 6e 61 6d 65 20 73 74 65 70 29 0a 09 09 09 22 5c name step)...."\
6850: 6e 73 74 61 74 65 3a 20 20 20 20 22 20 28 74 64 nstate: " (td
6860: 62 3a 73 74 65 70 2d 67 65 74 2d 73 74 61 74 65 b:step-get-state
6870: 20 73 74 65 70 29 0a 09 09 09 22 5c 6e 73 74 61 step)...."\nsta
6880: 74 75 73 3a 20 20 20 22 20 28 74 64 62 3a 73 74 tus: " (tdb:st
6890: 65 70 2d 67 65 74 2d 73 74 61 74 75 73 20 73 74 ep-get-status st
68a0: 65 70 29 0a 09 09 09 22 5c 6e 74 69 6d 65 3a 20 ep)...."\ntime:
68b0: 20 20 20 20 22 20 28 74 64 62 3a 73 74 65 70 2d " (tdb:step-
68c0: 67 65 74 2d 65 76 65 6e 74 5f 74 69 6d 65 20 73 get-event_time s
68d0: 74 65 70 29 29 29 29 0a 20 20 20 20 20 20 20 3b tep)))). ;
68e0: 3b 20 28 65 6c 73 65 20 20 20 28 76 65 63 74 6f ; (else (vecto
68f0: 72 2d 73 65 74 21 20 72 65 63 6f 72 64 20 31 20 r-set! record 1
6900: 28 74 64 62 3a 73 74 65 70 2d 67 65 74 2d 65 76 (tdb:step-get-ev
6910: 65 6e 74 5f 74 69 6d 65 20 73 74 65 70 29 29 29 ent_time step)))
6920: 0a 20 20 20 20 20 20 20 28 73 6f 72 74 20 73 74 . (sort st
6930: 65 70 73 20 28 6c 61 6d 62 64 61 20 28 61 20 62 eps (lambda (a b
6940: 29 0a 09 09 20 20 20 20 20 28 63 6f 6e 64 0a 09 )... (cond..
6950: 09 20 20 20 20 20 20 28 28 3c 20 20 20 28 74 64 . ((< (td
6960: 62 3a 73 74 65 70 2d 67 65 74 2d 65 76 65 6e 74 b:step-get-event
6970: 5f 74 69 6d 65 20 61 29 28 74 64 62 3a 73 74 65 _time a)(tdb:ste
6980: 70 2d 67 65 74 2d 65 76 65 6e 74 5f 74 69 6d 65 p-get-event_time
6990: 20 62 29 29 20 23 74 29 0a 09 09 20 20 20 20 20 b)) #t)...
69a0: 20 28 28 65 71 3f 20 28 74 64 62 3a 73 74 65 70 ((eq? (tdb:step
69b0: 2d 67 65 74 2d 65 76 65 6e 74 5f 74 69 6d 65 20 -get-event_time
69c0: 61 29 28 74 64 62 3a 73 74 65 70 2d 67 65 74 2d a)(tdb:step-get-
69d0: 65 76 65 6e 74 5f 74 69 6d 65 20 62 29 29 20 0a event_time b)) .
69e0: 09 09 20 20 20 20 20 20 20 28 3c 20 20 20 28 74 .. (< (t
69f0: 64 62 3a 73 74 65 70 2d 67 65 74 2d 69 64 20 61 db:step-get-id a
6a00: 29 20 20 20 20 20 20 20 20 28 74 64 62 3a 73 74 ) (tdb:st
6a10: 65 70 2d 67 65 74 2d 69 64 20 62 29 29 29 0a 09 ep-get-id b)))..
6a20: 09 20 20 20 20 20 20 28 65 6c 73 65 20 23 66 29 . (else #f)
6a30: 29 29 29 29 0a 20 20 20 20 20 20 72 65 73 29 29 )))). res))
6a40: 0a 0a 0a 3b 3b 20 0a 3b 3b 0a 28 64 65 66 69 6e ...;; .;;.(defin
6a50: 65 20 28 74 65 73 74 73 3a 67 65 74 2d 63 6f 6d e (tests:get-com
6a60: 70 72 65 73 73 65 64 2d 73 74 65 70 73 20 72 75 pressed-steps ru
6a70: 6e 2d 69 64 20 74 65 73 74 2d 69 64 29 0a 20 20 n-id test-id).
6a80: 28 6c 65 74 2a 20 28 28 73 74 65 70 73 2d 64 61 (let* ((steps-da
6a90: 74 61 20 20 28 72 6d 74 3a 67 65 74 2d 73 74 65 ta (rmt:get-ste
6aa0: 70 73 2d 66 6f 72 2d 74 65 73 74 20 72 75 6e 2d ps-for-test run-
6ab0: 69 64 20 74 65 73 74 2d 69 64 29 29 0a 09 20 28 id test-id)).. (
6ac0: 63 6f 6d 70 72 73 74 65 70 73 20 20 28 74 65 73 comprsteps (tes
6ad0: 74 73 3a 70 72 6f 63 65 73 73 2d 73 74 65 70 73 ts:process-steps
6ae0: 2d 74 61 62 6c 65 20 73 74 65 70 73 2d 64 61 74 -table steps-dat
6af0: 61 29 29 29 20 3b 3b 20 28 6f 70 65 6e 2d 72 75 a))) ;; (open-ru
6b00: 6e 2d 63 6c 6f 73 65 20 64 62 3a 67 65 74 2d 73 n-close db:get-s
6b10: 74 65 70 73 2d 74 61 62 6c 65 20 23 66 20 74 65 teps-table #f te
6b20: 73 74 2d 69 64 20 77 6f 72 6b 2d 61 72 65 61 3a st-id work-area:
6b30: 20 77 6f 72 6b 2d 61 72 65 61 29 29 29 0a 20 20 work-area))).
6b40: 20 20 28 6d 61 70 20 28 6c 61 6d 62 64 61 20 28 (map (lambda (
6b50: 78 29 0a 09 20 20 20 3b 3b 20 74 61 6b 65 20 61 x).. ;; take a
6b60: 64 76 61 6e 74 61 67 65 20 6f 66 20 74 68 65 20 dvantage of the
6b70: 5c 6e 20 6f 6e 20 74 69 6d 65 2d 3e 73 74 72 69 \n on time->stri
6b80: 6e 67 0a 09 20 20 20 28 76 65 63 74 6f 72 0a 09 ng.. (vector..
6b90: 20 20 20 20 28 76 65 63 74 6f 72 2d 72 65 66 20 (vector-ref
6ba0: 78 20 30 29 0a 09 20 20 20 20 28 6c 65 74 20 28 x 0).. (let (
6bb0: 28 73 20 28 76 65 63 74 6f 72 2d 72 65 66 20 78 (s (vector-ref x
6bc0: 20 31 29 29 29 0a 09 20 20 20 20 20 20 28 69 66 1))).. (if
6bd0: 20 28 6e 75 6d 62 65 72 3f 20 73 29 28 73 65 63 (number? s)(sec
6be0: 6f 6e 64 73 2d 3e 74 69 6d 65 2d 73 74 72 69 6e onds->time-strin
6bf0: 67 20 73 29 20 73 29 29 0a 09 20 20 20 20 28 6c g s) s)).. (l
6c00: 65 74 20 28 28 73 20 28 76 65 63 74 6f 72 2d 72 et ((s (vector-r
6c10: 65 66 20 78 20 32 29 29 29 0a 09 20 20 20 20 20 ef x 2)))..
6c20: 20 28 69 66 20 28 6e 75 6d 62 65 72 3f 20 73 29 (if (number? s)
6c30: 28 73 65 63 6f 6e 64 73 2d 3e 74 69 6d 65 2d 73 (seconds->time-s
6c40: 74 72 69 6e 67 20 73 29 20 73 29 29 0a 09 20 20 tring s) s))..
6c50: 20 20 28 76 65 63 74 6f 72 2d 72 65 66 20 78 20 (vector-ref x
6c60: 33 29 20 20 20 20 3b 3b 20 73 74 61 74 75 73 0a 3) ;; status.
6c70: 09 20 20 20 20 28 76 65 63 74 6f 72 2d 72 65 66 . (vector-ref
6c80: 20 78 20 34 29 0a 09 20 20 20 20 28 76 65 63 74 x 4).. (vect
6c90: 6f 72 2d 72 65 66 20 78 20 35 29 20 20 3b 3b 20 or-ref x 5) ;;
6ca0: 74 69 6d 65 20 64 65 6c 74 61 0a 09 20 20 20 20 time delta..
6cb0: 28 76 65 63 74 6f 72 2d 72 65 66 20 78 20 36 29 (vector-ref x 6)
6cc0: 29 29 0a 09 20 28 73 6f 72 74 20 28 68 61 73 68 )).. (sort (hash
6cd0: 2d 74 61 62 6c 65 2d 76 61 6c 75 65 73 20 63 6f -table-values co
6ce0: 6d 70 72 73 74 65 70 73 29 0a 09 20 20 20 20 20 mprsteps)..
6cf0: 20 20 28 6c 61 6d 62 64 61 20 28 61 20 62 29 0a (lambda (a b).
6d00: 09 09 20 28 6c 65 74 20 28 28 74 69 6d 65 2d 61 .. (let ((time-a
6d10: 20 28 76 65 63 74 6f 72 2d 72 65 66 20 61 20 31 (vector-ref a 1
6d20: 29 29 0a 09 09 20 20 20 20 20 20 20 28 74 69 6d ))... (tim
6d30: 65 2d 62 20 28 76 65 63 74 6f 72 2d 72 65 66 20 e-b (vector-ref
6d40: 62 20 31 29 29 29 0a 09 09 20 20 20 28 69 66 20 b 1)))... (if
6d50: 28 61 6e 64 20 28 6e 75 6d 62 65 72 3f 20 74 69 (and (number? ti
6d60: 6d 65 2d 61 29 28 6e 75 6d 62 65 72 3f 20 74 69 me-a)(number? ti
6d70: 6d 65 2d 62 29 29 0a 09 09 20 20 20 20 20 20 20 me-b))...
6d80: 28 69 66 20 28 3c 20 74 69 6d 65 2d 61 20 74 69 (if (< time-a ti
6d90: 6d 65 2d 62 29 0a 09 09 09 20 20 20 23 74 0a 09 me-b).... #t..
6da0: 09 09 20 20 20 28 69 66 20 28 65 71 3f 20 74 69 .. (if (eq? ti
6db0: 6d 65 2d 61 20 74 69 6d 65 2d 62 29 0a 09 09 09 me-a time-b)....
6dc0: 20 20 20 20 20 20 20 28 73 74 72 69 6e 67 3c 3f (string<?
6dd0: 20 28 63 6f 6e 63 20 28 76 65 63 74 6f 72 2d 72 (conc (vector-r
6de0: 65 66 20 61 20 32 29 29 0a 09 09 09 09 09 20 28 ef a 2))...... (
6df0: 63 6f 6e 63 20 28 76 65 63 74 6f 72 2d 72 65 66 conc (vector-ref
6e00: 20 62 20 32 29 29 29 0a 09 09 09 20 20 20 20 20 b 2)))....
6e10: 20 20 23 66 29 29 0a 09 09 20 20 20 20 20 20 20 #f))...
6e20: 28 73 74 72 69 6e 67 3c 3f 20 28 63 6f 6e 63 20 (string<? (conc
6e30: 74 69 6d 65 2d 61 29 28 63 6f 6e 63 20 74 69 6d time-a)(conc tim
6e40: 65 2d 62 29 29 29 29 29 29 29 29 29 0a 0a 0a 3b e-b)))))))))...;
6e50: 3b 20 73 75 6d 6d 61 72 69 7a 65 20 74 65 73 74 ; summarize test
6e60: 0a 28 64 65 66 69 6e 65 20 28 74 65 73 74 73 3a .(define (tests:
6e70: 73 75 6d 6d 61 72 69 7a 65 2d 74 65 73 74 20 72 summarize-test r
6e80: 75 6e 2d 69 64 20 74 65 73 74 2d 69 64 29 0a 20 un-id test-id).
6e90: 20 28 6c 65 74 2a 20 28 28 74 65 73 74 2d 64 61 (let* ((test-da
6ea0: 74 20 20 28 72 6d 74 3a 67 65 74 2d 74 65 73 74 t (rmt:get-test
6eb0: 2d 69 6e 66 6f 2d 62 79 2d 69 64 20 72 75 6e 2d -info-by-id run-
6ec0: 69 64 20 74 65 73 74 2d 69 64 29 29 0a 09 20 28 id test-id)).. (
6ed0: 73 74 65 70 73 2d 64 61 74 20 28 72 6d 74 3a 67 steps-dat (rmt:g
6ee0: 65 74 2d 73 74 65 70 73 2d 66 6f 72 2d 74 65 73 et-steps-for-tes
6ef0: 74 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 69 64 t run-id test-id
6f00: 29 29 0a 09 20 28 74 65 73 74 2d 6e 61 6d 65 20 )).. (test-name
6f10: 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 74 65 73 (db:test-get-tes
6f20: 74 6e 61 6d 65 20 74 65 73 74 2d 64 61 74 29 29 tname test-dat))
6f30: 0a 09 20 28 69 74 65 6d 2d 70 61 74 68 20 28 64 .. (item-path (d
6f40: 62 3a 74 65 73 74 2d 67 65 74 2d 69 74 65 6d 2d b:test-get-item-
6f50: 70 61 74 68 20 74 65 73 74 2d 64 61 74 29 29 0a path test-dat)).
6f60: 09 20 28 66 75 6c 6c 2d 6e 61 6d 65 20 28 64 62 . (full-name (db
6f70: 3a 74 65 73 74 2d 6d 61 6b 65 2d 66 75 6c 6c 2d :test-make-full-
6f80: 6e 61 6d 65 20 74 65 73 74 2d 6e 61 6d 65 20 69 name test-name i
6f90: 74 65 6d 2d 70 61 74 68 29 29 0a 09 20 28 6f 75 tem-path)).. (ou
6fa0: 70 20 20 20 20 20 20 20 28 6f 70 65 6e 2d 6f 75 p (open-ou
6fb0: 74 70 75 74 2d 66 69 6c 65 20 28 63 6f 6e 63 20 tput-file (conc
6fc0: 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 72 75 6e (db:test-get-run
6fd0: 64 69 72 20 74 65 73 74 2d 64 61 74 29 20 22 2f dir test-dat) "/
6fe0: 74 65 73 74 2d 73 75 6d 6d 61 72 79 2e 68 74 6d test-summary.htm
6ff0: 6c 22 29 29 29 0a 09 20 28 73 74 61 74 75 73 20 l"))).. (status
7000: 20 20 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d (db:test-get-
7010: 73 74 61 74 75 73 20 20 20 74 65 73 74 2d 64 61 status test-da
7020: 74 29 29 0a 09 20 28 63 6f 6c 6f 72 20 20 20 20 t)).. (color
7030: 20 28 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 63 6f 6c (common:get-col
7040: 6f 72 2d 66 72 6f 6d 2d 73 74 61 74 75 73 20 73 or-from-status s
7050: 74 61 74 75 73 29 29 0a 09 20 28 6c 6f 67 66 20 tatus)).. (logf
7060: 20 20 20 20 20 28 64 62 3a 74 65 73 74 2d 67 65 (db:test-ge
7070: 74 2d 66 69 6e 61 6c 5f 6c 6f 67 66 20 74 65 73 t-final_logf tes
7080: 74 2d 64 61 74 29 29 0a 09 20 28 73 74 65 70 73 t-dat)).. (steps
7090: 2d 64 61 74 20 28 74 65 73 74 73 3a 67 65 74 2d -dat (tests:get-
70a0: 63 6f 6d 70 72 65 73 73 65 64 2d 73 74 65 70 73 compressed-steps
70b0: 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 69 64 29 run-id test-id)
70c0: 29 29 0a 20 20 20 20 3b 3b 20 28 64 63 6f 6d 6d )). ;; (dcomm
70d0: 6f 6e 3a 67 65 74 2d 63 6f 6d 70 72 65 73 73 65 on:get-compresse
70e0: 64 2d 73 74 65 70 73 20 23 66 20 31 20 33 30 30 d-steps #f 1 300
70f0: 34 35 29 0a 20 20 20 20 3b 3b 20 28 23 28 22 77 45). ;; (#("w
7100: 61 73 74 69 6e 67 5f 74 69 6d 65 22 20 22 32 33 asting_time" "23
7110: 3a 33 36 3a 31 33 22 20 22 32 33 3a 33 36 3a 32 :36:13" "23:36:2
7120: 31 22 20 22 30 22 20 22 38 2e 30 73 22 20 22 77 1" "0" "8.0s" "w
7130: 61 73 74 69 6e 67 5f 74 69 6d 65 2e 6c 6f 67 22 asting_time.log"
7140: 29 29 0a 0a 20 20 20 20 28 73 3a 6f 75 74 70 75 )).. (s:outpu
7150: 74 2d 6e 65 77 0a 20 20 20 20 20 6f 75 70 0a 20 t-new. oup.
7160: 20 20 20 20 28 73 3a 68 74 6d 6c 0a 20 20 20 20 (s:html.
7170: 20 20 28 73 3a 74 69 74 6c 65 20 22 53 75 6d 6d (s:title "Summ
7180: 61 72 79 20 66 6f 72 20 22 20 66 75 6c 6c 2d 6e ary for " full-n
7190: 61 6d 65 29 0a 20 20 20 20 20 20 28 73 3a 62 6f ame). (s:bo
71a0: 64 79 20 0a 20 20 20 20 20 20 20 28 73 3a 68 32 dy . (s:h2
71b0: 20 22 53 75 6d 6d 61 72 79 20 66 6f 72 20 22 20 "Summary for "
71c0: 66 75 6c 6c 2d 6e 61 6d 65 29 0a 20 20 20 20 20 full-name).
71d0: 20 20 28 73 3a 74 61 62 6c 65 20 27 63 65 6c 6c (s:table 'cell
71e0: 73 70 61 63 69 6e 67 20 22 30 22 20 27 62 6f 72 spacing "0" 'bor
71f0: 64 65 72 20 22 31 22 0a 09 28 73 3a 74 72 20 28 der "1"..(s:tr (
7200: 73 3a 74 64 20 22 72 75 6e 20 69 64 22 29 20 20 s:td "run id")
7210: 20 28 73 3a 74 64 20 28 64 62 3a 74 65 73 74 2d (s:td (db:test-
7220: 67 65 74 2d 72 75 6e 5f 69 64 20 20 20 74 65 73 get-run_id tes
7230: 74 2d 64 61 74 29 29 0a 09 20 20 20 20 20 20 28 t-dat)).. (
7240: 73 3a 74 64 20 22 74 65 73 74 20 69 64 22 29 20 s:td "test id")
7250: 20 28 73 3a 74 64 20 28 64 62 3a 74 65 73 74 2d (s:td (db:test-
7260: 67 65 74 2d 69 64 20 20 20 20 20 20 20 74 65 73 get-id tes
7270: 74 2d 64 61 74 29 29 29 0a 09 28 73 3a 74 72 20 t-dat)))..(s:tr
7280: 28 73 3a 74 64 20 22 74 65 73 74 6e 61 6d 65 22 (s:td "testname"
7290: 29 20 28 73 3a 74 64 20 74 65 73 74 2d 6e 61 6d ) (s:td test-nam
72a0: 65 29 0a 09 20 20 20 20 20 20 28 73 3a 74 64 20 e).. (s:td
72b0: 22 69 74 65 6d 70 61 74 68 22 29 20 28 73 3a 74 "itempath") (s:t
72c0: 64 20 69 74 65 6d 2d 70 61 74 68 29 29 0a 09 28 d item-path))..(
72d0: 73 3a 74 72 20 28 73 3a 74 64 20 22 73 74 61 74 s:tr (s:td "stat
72e0: 65 22 29 20 20 20 20 28 73 3a 74 64 20 28 64 62 e") (s:td (db
72f0: 3a 74 65 73 74 2d 67 65 74 2d 73 74 61 74 65 20 :test-get-state
7300: 20 20 20 74 65 73 74 2d 64 61 74 29 29 0a 09 20 test-dat))..
7310: 20 20 20 20 20 28 73 3a 74 64 20 22 73 74 61 74 (s:td "stat
7320: 75 73 22 29 20 20 20 28 73 3a 74 64 20 28 73 3a us") (s:td (s:
7330: 61 20 27 68 72 65 66 20 6c 6f 67 66 20 28 73 3a a 'href logf (s:
7340: 66 6f 6e 74 20 27 63 6f 6c 6f 72 20 63 6f 6c 6f font 'color colo
7350: 72 20 73 74 61 74 75 73 29 29 29 29 0a 09 28 73 r status))))..(s
7360: 3a 74 72 20 28 73 3a 74 64 20 22 54 65 73 74 44 :tr (s:td "TestD
7370: 61 74 65 22 29 20 28 73 3a 74 64 20 28 73 65 63 ate") (s:td (sec
7380: 6f 6e 64 73 2d 3e 77 6f 72 6b 2d 77 65 65 6b 2f onds->work-week/
7390: 64 61 79 2d 74 69 6d 65 20 0a 09 09 09 09 20 20 day-time .....
73a0: 20 20 20 20 20 28 64 62 3a 74 65 73 74 2d 67 65 (db:test-ge
73b0: 74 2d 65 76 65 6e 74 5f 74 69 6d 65 20 74 65 73 t-event_time tes
73c0: 74 2d 64 61 74 29 29 29 0a 09 20 20 20 20 20 20 t-dat)))..
73d0: 28 73 3a 74 64 20 22 44 75 72 61 74 69 6f 6e 22 (s:td "Duration"
73e0: 29 20 28 73 3a 74 64 20 28 73 65 63 6f 6e 64 73 ) (s:td (seconds
73f0: 2d 3e 68 72 2d 6d 69 6e 2d 73 65 63 20 28 64 62 ->hr-min-sec (db
7400: 3a 74 65 73 74 2d 67 65 74 2d 72 75 6e 5f 64 75 :test-get-run_du
7410: 72 61 74 69 6f 6e 20 74 65 73 74 2d 64 61 74 29 ration test-dat)
7420: 29 29 29 29 0a 20 20 20 20 20 20 20 28 73 3a 68 )))). (s:h
7430: 33 20 22 4c 6f 67 20 66 69 6c 65 73 22 29 0a 20 3 "Log files").
7440: 20 20 20 20 20 20 28 73 3a 74 61 62 6c 65 0a 09 (s:table..
7450: 27 63 65 6c 6c 73 70 61 63 69 6e 67 20 22 30 22 'cellspacing "0"
7460: 20 27 62 6f 72 64 65 72 20 22 31 22 0a 09 28 73 'border "1"..(s
7470: 3a 74 72 20 28 73 3a 74 64 20 22 46 69 6e 61 6c :tr (s:td "Final
7480: 20 6c 6f 67 22 29 28 73 3a 74 64 20 28 73 3a 61 log")(s:td (s:a
7490: 20 27 68 72 65 66 20 6c 6f 67 66 20 6c 6f 67 66 'href logf logf
74a0: 29 29 29 29 0a 20 20 20 20 20 20 20 28 73 3a 74 )))). (s:t
74b0: 61 62 6c 65 0a 09 27 63 65 6c 6c 73 70 61 63 69 able..'cellspaci
74c0: 6e 67 20 22 30 22 20 27 62 6f 72 64 65 72 20 22 ng "0" 'border "
74d0: 31 22 0a 09 28 73 3a 74 72 20 28 73 3a 74 64 20 1"..(s:tr (s:td
74e0: 22 53 74 65 70 20 4e 61 6d 65 22 29 28 73 3a 74 "Step Name")(s:t
74f0: 64 20 22 53 74 61 72 74 22 29 28 73 3a 74 64 20 d "Start")(s:td
7500: 22 45 6e 64 22 29 28 73 3a 74 64 20 22 53 74 61 "End")(s:td "Sta
7510: 74 75 73 22 29 28 73 3a 74 64 20 22 44 75 72 61 tus")(s:td "Dura
7520: 74 69 6f 6e 22 29 28 73 3a 74 64 20 22 4c 6f 67 tion")(s:td "Log
7530: 20 46 69 6c 65 22 29 29 0a 09 28 6d 61 70 20 28 File"))..(map (
7540: 6c 61 6d 62 64 61 20 28 73 74 65 70 2d 64 61 74 lambda (step-dat
7550: 29 0a 09 20 20 20 20 20 20 20 28 73 3a 74 72 20 ).. (s:tr
7560: 28 73 3a 74 64 20 28 74 64 62 3a 73 74 65 70 73 (s:td (tdb:steps
7570: 2d 74 61 62 6c 65 2d 67 65 74 2d 73 74 65 70 6e -table-get-stepn
7580: 61 6d 65 20 73 74 65 70 2d 64 61 74 29 29 0a 09 ame step-dat))..
7590: 09 20 20 20 20 20 28 73 3a 74 64 20 28 74 64 62 . (s:td (tdb
75a0: 3a 73 74 65 70 73 2d 74 61 62 6c 65 2d 67 65 74 :steps-table-get
75b0: 2d 73 74 61 72 74 20 20 20 20 73 74 65 70 2d 64 -start step-d
75c0: 61 74 29 29 0a 09 09 20 20 20 20 20 28 73 3a 74 at))... (s:t
75d0: 64 20 28 74 64 62 3a 73 74 65 70 73 2d 74 61 62 d (tdb:steps-tab
75e0: 6c 65 2d 67 65 74 2d 65 6e 64 20 20 20 20 20 20 le-get-end
75f0: 73 74 65 70 2d 64 61 74 29 29 0a 09 09 20 20 20 step-dat))...
7600: 20 20 28 73 3a 74 64 20 28 74 64 62 3a 73 74 65 (s:td (tdb:ste
7610: 70 73 2d 74 61 62 6c 65 2d 67 65 74 2d 73 74 61 ps-table-get-sta
7620: 74 75 73 20 20 20 73 74 65 70 2d 64 61 74 29 29 tus step-dat))
7630: 0a 09 09 20 20 20 20 20 28 73 3a 74 64 20 28 74 ... (s:td (t
7640: 64 62 3a 73 74 65 70 73 2d 74 61 62 6c 65 2d 67 db:steps-table-g
7650: 65 74 2d 72 75 6e 74 69 6d 65 20 20 73 74 65 70 et-runtime step
7660: 2d 64 61 74 29 29 0a 09 09 20 20 20 20 20 28 73 -dat))... (s
7670: 3a 74 64 20 28 6c 65 74 20 28 28 73 74 65 70 2d :td (let ((step-
7680: 6c 6f 67 20 28 74 64 62 3a 73 74 65 70 73 2d 74 log (tdb:steps-t
7690: 61 62 6c 65 2d 67 65 74 2d 6c 6f 67 2d 66 69 6c able-get-log-fil
76a0: 65 20 73 74 65 70 2d 64 61 74 29 29 29 0a 09 09 e step-dat)))...
76b0: 09 20 20 20 20 20 28 73 3a 61 20 27 68 72 65 66 . (s:a 'href
76c0: 20 73 74 65 70 2d 6c 6f 67 20 73 74 65 70 2d 6c step-log step-l
76d0: 6f 67 29 29 29 29 29 0a 09 20 20 20 20 20 73 74 og))))).. st
76e0: 65 70 73 2d 64 61 74 29 29 0a 09 29 29 29 0a 20 eps-dat))..))).
76f0: 20 20 20 28 63 6c 6f 73 65 2d 6f 75 74 70 75 74 (close-output
7700: 2d 70 6f 72 74 20 6f 75 70 29 29 29 0a 09 20 20 -port oup)))..
7710: 0a 09 20 20 0a 3b 3b 20 4d 55 53 54 20 42 45 20 .. .;; MUST BE
7720: 43 41 4c 4c 45 44 20 6c 6f 63 61 6c 21 0a 3b 3b CALLED local!.;;
7730: 0a 28 64 65 66 69 6e 65 20 28 74 65 73 74 73 3a .(define (tests:
7740: 74 65 73 74 2d 67 65 74 2d 70 61 74 68 73 2d 6d test-get-paths-m
7750: 61 74 63 68 69 6e 67 20 6b 65 79 6e 61 6d 65 73 atching keynames
7760: 20 74 61 72 67 65 74 20 66 6e 61 6d 65 70 61 74 target fnamepat
7770: 74 20 23 21 6b 65 79 20 28 72 65 73 20 27 28 29 t #!key (res '()
7780: 29 29 0a 20 20 3b 3b 20 42 55 47 3a 20 4d 6f 76 )). ;; BUG: Mov
7790: 65 20 74 68 65 20 76 61 6c 75 65 73 20 64 65 72 e the values der
77a0: 69 76 65 64 20 66 72 6f 6d 20 61 72 67 73 20 74 ived from args t
77b0: 6f 20 70 61 72 61 6d 65 74 65 72 73 20 61 6e 64 o parameters and
77c0: 20 70 75 73 68 20 74 6f 20 6d 65 67 61 74 65 73 push to megates
77d0: 74 2e 73 63 6d 0a 20 20 28 6c 65 74 2a 20 28 28 t.scm. (let* ((
77e0: 74 65 73 74 70 61 74 74 20 20 20 28 69 66 20 28 testpatt (if (
77f0: 61 72 67 73 3a 67 65 74 2d 61 72 67 20 22 2d 74 args:get-arg "-t
7800: 65 73 74 70 61 74 74 22 29 28 61 72 67 73 3a 67 estpatt")(args:g
7810: 65 74 2d 61 72 67 20 22 2d 74 65 73 74 70 61 74 et-arg "-testpat
7820: 74 22 29 20 22 25 22 29 29 0a 09 20 28 73 74 61 t") "%")).. (sta
7830: 74 65 70 61 74 74 20 20 28 69 66 20 28 61 72 67 tepatt (if (arg
7840: 73 3a 67 65 74 2d 61 72 67 20 22 3a 73 74 61 74 s:get-arg ":stat
7850: 65 22 29 20 20 20 28 61 72 67 73 3a 67 65 74 2d e") (args:get-
7860: 61 72 67 20 22 3a 73 74 61 74 65 22 29 20 20 20 arg ":state")
7870: 20 22 25 22 29 29 0a 09 20 28 73 74 61 74 75 73 "%")).. (status
7880: 70 61 74 74 20 28 69 66 20 28 61 72 67 73 3a 67 patt (if (args:g
7890: 65 74 2d 61 72 67 20 22 3a 73 74 61 74 75 73 22 et-arg ":status"
78a0: 29 20 20 28 61 72 67 73 3a 67 65 74 2d 61 72 67 ) (args:get-arg
78b0: 20 22 3a 73 74 61 74 75 73 22 29 20 20 20 22 25 ":status") "%
78c0: 22 29 29 0a 09 20 28 72 75 6e 6e 61 6d 65 20 20 ")).. (runname
78d0: 20 20 28 69 66 20 28 61 72 67 73 3a 67 65 74 2d (if (args:get-
78e0: 61 72 67 20 22 3a 72 75 6e 6e 61 6d 65 22 29 20 arg ":runname")
78f0: 28 61 72 67 73 3a 67 65 74 2d 61 72 67 20 22 3a (args:get-arg ":
7900: 72 75 6e 6e 61 6d 65 22 29 20 20 22 25 22 29 29 runname") "%"))
7910: 0a 09 20 28 70 61 74 68 73 2d 66 72 6f 6d 2d 64 .. (paths-from-d
7920: 62 20 28 72 6d 74 3a 74 65 73 74 2d 67 65 74 2d b (rmt:test-get-
7930: 70 61 74 68 73 2d 6d 61 74 63 68 69 6e 67 2d 6b paths-matching-k
7940: 65 79 6e 61 6d 65 73 2d 74 61 72 67 65 74 2d 6e eynames-target-n
7950: 65 77 20 6b 65 79 6e 61 6d 65 73 20 74 61 72 67 ew keynames targ
7960: 65 74 20 72 65 73 0a 09 09 09 09 09 74 65 73 74 et res......test
7970: 70 61 74 74 0a 09 09 09 09 09 73 74 61 74 65 70 patt......statep
7980: 61 74 74 0a 09 09 09 09 09 73 74 61 74 75 73 70 att......statusp
7990: 61 74 74 0a 09 09 09 09 09 72 75 6e 6e 61 6d 65 att......runname
79a0: 29 29 29 0a 20 20 20 20 28 69 66 20 66 6e 61 6d ))). (if fnam
79b0: 65 70 61 74 74 0a 09 28 61 70 70 6c 79 20 61 70 epatt..(apply ap
79c0: 70 65 6e 64 20 0a 09 20 20 20 20 20 20 20 28 6d pend .. (m
79d0: 61 70 20 28 6c 61 6d 62 64 61 20 28 70 29 0a 09 ap (lambda (p)..
79e0: 09 20 20 20 20 20 20 28 69 66 20 28 64 69 72 65 . (if (dire
79f0: 63 74 6f 72 79 2d 65 78 69 73 74 73 3f 20 70 29 ctory-exists? p)
7a00: 0a 09 09 09 20 20 28 67 6c 6f 62 20 28 63 6f 6e .... (glob (con
7a10: 63 20 70 20 22 2f 22 20 66 6e 61 6d 65 70 61 74 c p "/" fnamepat
7a20: 74 29 29 0a 09 09 09 20 20 27 28 29 29 29 0a 09 t)).... '()))..
7a30: 09 20 20 20 20 70 61 74 68 73 2d 66 72 6f 6d 2d . paths-from-
7a40: 64 62 29 29 0a 09 70 61 74 68 73 2d 66 72 6f 6d db))..paths-from
7a50: 2d 64 62 29 29 29 0a 0a 09 09 09 20 20 20 20 20 -db))).....
7a60: 20 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d .;;============
7a70: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7a80: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7a90: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7aa0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 47 61 ==========.;; Ga
7ab0: 74 68 65 72 20 64 61 74 61 20 66 72 6f 6d 20 74 ther data from t
7ac0: 65 73 74 2f 74 61 73 6b 20 73 70 65 63 69 66 69 est/task specifi
7ad0: 63 61 74 69 6f 6e 73 0a 3b 3b 3d 3d 3d 3d 3d 3d cations.;;======
7ae0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7af0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7b00: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7b10: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7b20: 0a 0a 3b 3b 20 28 64 65 66 69 6e 65 20 28 74 65 ..;; (define (te
7b30: 73 74 73 3a 67 65 74 2d 76 61 6c 69 64 2d 74 65 sts:get-valid-te
7b40: 73 74 73 20 74 65 73 74 73 64 69 72 20 74 65 73 sts testsdir tes
7b50: 74 2d 70 61 74 74 73 29 20 3b 3b 20 20 23 21 6b t-patts) ;; #!k
7b60: 65 79 20 28 74 65 73 74 2d 6e 61 6d 65 73 20 27 ey (test-names '
7b70: 28 29 29 29 0a 3b 3b 20 20 20 28 6c 65 74 20 28 ())).;; (let (
7b80: 28 74 65 73 74 73 20 28 67 6c 6f 62 20 28 63 6f (tests (glob (co
7b90: 6e 63 20 74 65 73 74 73 64 69 72 20 22 2f 74 65 nc testsdir "/te
7ba0: 73 74 73 2f 2a 22 29 29 29 29 20 3b 3b 20 22 20 sts/*")))) ;; "
7bb0: 28 73 74 72 69 6e 67 2d 74 72 61 6e 73 6c 61 74 (string-translat
7bc0: 65 20 70 61 74 74 20 22 25 22 20 22 2a 22 29 29 e patt "%" "*"))
7bd0: 29 29 29 0a 3b 3b 20 20 20 20 20 28 73 65 74 21 ))).;; (set!
7be0: 20 74 65 73 74 73 20 28 66 69 6c 74 65 72 20 28 tests (filter (
7bf0: 6c 61 6d 62 64 61 20 28 74 65 73 74 29 28 66 69 lambda (test)(fi
7c00: 6c 65 2d 65 78 69 73 74 73 3f 20 28 63 6f 6e 63 le-exists? (conc
7c10: 20 74 65 73 74 20 22 2f 74 65 73 74 63 6f 6e 66 test "/testconf
7c20: 69 67 22 29 29 29 20 74 65 73 74 73 29 29 0a 3b ig"))) tests)).;
7c30: 3b 20 20 20 20 20 28 64 65 6c 65 74 65 2d 64 75 ; (delete-du
7c40: 70 6c 69 63 61 74 65 73 0a 3b 3b 20 20 20 20 20 plicates.;;
7c50: 20 28 66 69 6c 74 65 72 20 28 6c 61 6d 62 64 61 (filter (lambda
7c60: 20 28 74 65 73 74 6e 61 6d 65 29 0a 3b 3b 20 09 (testname).;; .
7c70: 20 20 20 20 20 20 20 28 74 65 73 74 73 3a 6d 61 (tests:ma
7c80: 74 63 68 20 74 65 73 74 2d 70 61 74 74 73 20 74 tch test-patts t
7c90: 65 73 74 6e 61 6d 65 20 23 66 29 29 0a 3b 3b 20 estname #f)).;;
7ca0: 09 20 20 20 20 20 28 6d 61 70 20 28 6c 61 6d 62 . (map (lamb
7cb0: 64 61 20 28 74 65 73 74 70 29 0a 3b 3b 20 09 09 da (testp).;; ..
7cc0: 20 20 20 20 28 6c 61 73 74 20 28 73 74 72 69 6e (last (strin
7cd0: 67 2d 73 70 6c 69 74 20 74 65 73 74 70 20 22 2f g-split testp "/
7ce0: 22 29 29 29 0a 3b 3b 20 09 09 20 20 74 65 73 74 "))).;; .. test
7cf0: 73 29 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 s)))))..(define
7d00: 28 74 65 73 74 73 3a 67 65 74 2d 74 65 73 74 2d (tests:get-test-
7d10: 70 61 74 68 2d 66 72 6f 6d 2d 65 6e 76 69 72 6f path-from-enviro
7d20: 6e 6d 65 6e 74 29 0a 20 20 28 69 66 20 28 61 6e nment). (if (an
7d30: 64 20 28 67 65 74 65 6e 76 20 22 4d 54 5f 4c 49 d (getenv "MT_LI
7d40: 4e 4b 54 52 45 45 22 29 0a 09 20 20 20 28 67 65 NKTREE").. (ge
7d50: 74 65 6e 76 20 22 4d 54 5f 54 41 52 47 45 54 22 tenv "MT_TARGET"
7d60: 29 0a 09 20 20 20 28 67 65 74 65 6e 76 20 22 4d ).. (getenv "M
7d70: 54 5f 52 55 4e 4e 41 4d 45 22 29 0a 09 20 20 20 T_RUNNAME")..
7d80: 28 67 65 74 65 6e 76 20 22 4d 54 5f 54 45 53 54 (getenv "MT_TEST
7d90: 5f 4e 41 4d 45 22 29 0a 09 20 20 20 28 67 65 74 _NAME").. (get
7da0: 65 6e 76 20 22 4d 54 5f 49 54 45 4d 50 41 54 48 env "MT_ITEMPATH
7db0: 22 29 29 0a 20 20 20 20 20 20 28 63 6f 6e 63 20 ")). (conc
7dc0: 28 67 65 74 65 6e 76 20 22 4d 54 5f 4c 49 4e 4b (getenv "MT_LINK
7dd0: 54 52 45 45 22 29 20 20 22 2f 22 0a 09 20 20 20 TREE") "/"..
7de0: 20 28 67 65 74 65 6e 76 20 22 4d 54 5f 54 41 52 (getenv "MT_TAR
7df0: 47 45 54 22 29 20 20 20 20 22 2f 22 0a 09 20 20 GET") "/"..
7e00: 20 20 28 67 65 74 65 6e 76 20 22 4d 54 5f 52 55 (getenv "MT_RU
7e10: 4e 4e 41 4d 45 22 29 20 20 20 22 2f 22 0a 09 20 NNAME") "/"..
7e20: 20 20 20 28 67 65 74 65 6e 76 20 22 4d 54 5f 54 (getenv "MT_T
7e30: 45 53 54 5f 4e 41 4d 45 22 29 20 22 2f 22 0a 09 EST_NAME") "/"..
7e40: 20 20 20 20 28 69 66 20 28 6f 72 20 28 67 65 74 (if (or (get
7e50: 65 6e 76 20 22 4d 54 5f 49 54 45 4d 50 41 54 48 env "MT_ITEMPATH
7e60: 22 29 0a 09 09 20 20 20 20 28 6e 6f 74 20 28 73 ")... (not (s
7e70: 74 72 69 6e 67 3d 3f 20 22 22 20 28 67 65 74 65 tring=? "" (gete
7e80: 6e 76 20 22 4d 54 5f 49 54 45 4d 50 41 54 48 22 nv "MT_ITEMPATH"
7e90: 29 29 29 29 0a 09 09 28 63 6f 6e 63 20 22 2f 22 ))))...(conc "/"
7ea0: 20 28 67 65 74 65 6e 76 20 22 4d 54 5f 49 54 45 (getenv "MT_ITE
7eb0: 4d 50 41 54 48 22 29 29 29 29 0a 20 20 20 20 20 MPATH")))).
7ec0: 20 23 66 29 29 0a 0a 3b 3b 20 69 66 20 2e 74 65 #f))..;; if .te
7ed0: 73 74 63 6f 6e 66 69 67 20 65 78 69 73 74 73 20 stconfig exists
7ee0: 69 6e 20 74 65 73 74 20 64 69 72 65 63 74 6f 72 in test director
7ef0: 79 20 72 65 61 64 20 61 6e 64 20 72 65 74 75 72 y read and retur
7f00: 6e 20 69 74 0a 3b 3b 20 65 6c 73 65 20 69 66 20 n it.;; else if
7f10: 68 61 76 65 20 63 61 63 68 65 64 20 63 6f 70 79 have cached copy
7f20: 20 69 6e 20 2a 74 65 73 74 63 6f 6e 66 69 67 73 in *testconfigs
7f30: 2a 20 72 65 74 75 72 6e 20 69 74 20 49 46 46 20 * return it IFF
7f40: 74 68 65 72 65 20 69 73 20 61 20 73 65 63 74 69 there is a secti
7f50: 6f 6e 20 22 68 61 76 65 20 66 75 6c 6c 64 61 74 on "have fulldat
7f60: 61 22 0a 3b 3b 20 65 6c 73 65 20 72 65 61 64 20 a".;; else read
7f70: 74 68 65 20 74 65 73 74 63 6f 6e 66 69 67 20 66 the testconfig f
7f80: 69 6c 65 0a 3b 3b 20 20 20 69 66 20 68 61 76 65 ile.;; if have
7f90: 20 70 61 74 68 20 74 6f 20 74 65 73 74 20 64 69 path to test di
7fa0: 72 65 63 74 6f 72 79 20 73 61 76 65 20 74 68 65 rectory save the
7fb0: 20 63 6f 6e 66 69 67 20 61 73 20 2e 74 65 73 74 config as .test
7fc0: 63 6f 6e 66 69 67 20 61 6e 64 20 72 65 74 75 72 config and retur
7fd0: 6e 20 69 74 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 n it.;;.(define
7fe0: 28 74 65 73 74 73 3a 67 65 74 2d 74 65 73 74 63 (tests:get-testc
7ff0: 6f 6e 66 69 67 20 74 65 73 74 2d 6e 61 6d 65 20 onfig test-name
8000: 74 65 73 74 2d 72 65 67 69 73 74 72 79 20 73 79 test-registry sy
8010: 73 74 65 6d 2d 61 6c 6c 6f 77 65 64 20 23 21 6b stem-allowed #!k
8020: 65 79 20 28 66 6f 72 63 65 2d 63 72 65 61 74 65 ey (force-create
8030: 20 23 66 29 29 0a 20 20 28 6c 65 74 2a 20 28 28 #f)). (let* ((
8040: 63 61 63 68 65 2d 70 61 74 68 20 20 20 28 74 65 cache-path (te
8050: 73 74 73 3a 67 65 74 2d 74 65 73 74 2d 70 61 74 sts:get-test-pat
8060: 68 2d 66 72 6f 6d 2d 65 6e 76 69 72 6f 6e 6d 65 h-from-environme
8070: 6e 74 29 29 0a 09 20 28 63 61 63 68 65 2d 66 69 nt)).. (cache-fi
8080: 6c 65 20 20 20 28 61 6e 64 20 63 61 63 68 65 2d le (and cache-
8090: 70 61 74 68 20 28 63 6f 6e 63 20 63 61 63 68 65 path (conc cache
80a0: 2d 70 61 74 68 20 22 2f 2e 74 65 73 74 63 6f 6e -path "/.testcon
80b0: 66 69 67 22 29 29 29 0a 09 20 28 63 61 63 68 65 fig"))).. (cache
80c0: 2d 65 78 69 73 74 73 20 28 61 6e 64 20 63 61 63 -exists (and cac
80d0: 68 65 2d 66 69 6c 65 0a 09 09 09 20 20 20 20 28 he-file.... (
80e0: 6e 6f 74 20 66 6f 72 63 65 2d 63 72 65 61 74 65 not force-create
80f0: 29 20 20 3b 3b 20 69 66 20 66 6f 72 63 65 2d 63 ) ;; if force-c
8100: 72 65 61 74 65 20 74 68 65 6e 20 70 72 65 74 65 reate then prete
8110: 6e 64 20 74 68 65 72 65 20 69 73 20 6e 6f 20 63 nd there is no c
8120: 61 63 68 65 20 74 6f 20 72 65 61 64 0a 09 09 09 ache to read....
8130: 20 20 20 20 28 66 69 6c 65 2d 65 78 69 73 74 73 (file-exists
8140: 3f 20 63 61 63 68 65 2d 66 69 6c 65 29 29 29 0a ? cache-file))).
8150: 09 20 28 63 61 63 68 65 64 2d 64 61 74 20 20 20 . (cached-dat
8160: 28 69 66 20 28 61 6e 64 20 28 6e 6f 74 20 66 6f (if (and (not fo
8170: 72 63 65 2d 63 72 65 61 74 65 29 0a 09 09 09 09 rce-create).....
8180: 63 61 63 68 65 2d 65 78 69 73 74 73 29 0a 09 09 cache-exists)...
8190: 09 20 20 20 28 68 61 6e 64 6c 65 2d 65 78 63 65 . (handle-exce
81a0: 70 74 69 6f 6e 73 0a 09 09 09 20 20 20 20 65 78 ptions.... ex
81b0: 6e 0a 09 09 09 20 20 20 20 23 66 20 3b 3b 20 61 n.... #f ;; a
81c0: 6e 79 20 69 73 73 75 65 73 2c 20 6a 75 73 74 20 ny issues, just
81d0: 67 69 76 65 20 75 70 20 77 69 74 68 20 74 68 65 give up with the
81e0: 20 63 61 63 68 65 64 20 76 65 72 73 69 6f 6e 20 cached version
81f0: 61 6e 64 20 72 65 2d 72 65 61 64 0a 09 09 09 20 and re-read....
8200: 20 20 20 28 63 6f 6e 66 69 67 66 3a 72 65 61 64 (configf:read
8210: 2d 61 6c 69 73 74 20 63 61 63 68 65 2d 66 69 6c -alist cache-fil
8220: 65 29 29 0a 09 09 09 20 20 20 23 66 29 29 29 0a e)).... #f))).
8230: 20 20 20 20 28 69 66 20 63 61 63 68 65 64 2d 64 (if cached-d
8240: 61 74 0a 09 63 61 63 68 65 64 2d 64 61 74 0a 09 at..cached-dat..
8250: 28 6c 65 74 20 28 28 64 61 74 20 28 68 61 73 68 (let ((dat (hash
8260: 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 -table-ref/defau
8270: 6c 74 20 2a 74 65 73 74 63 6f 6e 66 69 67 73 2a lt *testconfigs*
8280: 20 74 65 73 74 2d 6e 61 6d 65 20 23 66 29 29 29 test-name #f)))
8290: 0a 09 20 20 28 69 66 20 28 61 6e 64 20 20 64 61 .. (if (and da
82a0: 74 20 3b 3b 20 68 61 76 65 20 61 20 6c 6f 63 61 t ;; have a loca
82b0: 6c 6c 79 20 63 61 63 68 65 64 20 76 65 72 73 69 lly cached versi
82c0: 6f 6e 0a 09 09 20 20 20 20 28 68 61 73 68 2d 74 on... (hash-t
82d0: 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 able-ref/default
82e0: 20 64 61 74 20 22 68 61 76 65 20 66 75 6c 6c 64 dat "have fulld
82f0: 61 74 61 22 20 23 66 29 29 20 3b 3b 20 6d 61 72 ata" #f)) ;; mar
8300: 6b 65 64 20 61 73 20 67 6f 6f 64 20 64 61 74 61 ked as good data
8310: 3f 0a 09 20 20 20 20 20 20 64 61 74 0a 09 20 20 ?.. dat..
8320: 20 20 20 20 3b 3b 20 6e 6f 20 63 61 63 68 65 64 ;; no cached
8330: 20 64 61 74 61 20 61 76 61 69 6c 61 62 6c 65 0a data available.
8340: 09 20 20 20 20 20 20 28 6c 65 74 2a 20 28 28 74 . (let* ((t
8350: 72 65 67 20 20 20 20 20 20 20 20 20 28 6f 72 20 reg (or
8360: 74 65 73 74 2d 72 65 67 69 73 74 72 79 0a 09 09 test-registry...
8370: 09 09 20 20 20 20 20 20 20 28 74 65 73 74 73 3a .. (tests:
8380: 67 65 74 2d 61 6c 6c 29 29 29 0a 09 09 20 20 20 get-all)))...
8390: 20 20 28 74 65 73 74 2d 70 61 74 68 20 20 20 20 (test-path
83a0: 28 6f 72 20 28 68 61 73 68 2d 74 61 62 6c 65 2d (or (hash-table-
83b0: 72 65 66 2f 64 65 66 61 75 6c 74 20 74 72 65 67 ref/default treg
83c0: 20 74 65 73 74 2d 6e 61 6d 65 20 23 66 29 0a 09 test-name #f)..
83d0: 09 09 09 20 20 20 20 20 20 20 28 63 6f 6e 63 20 ... (conc
83e0: 2a 74 6f 70 70 61 74 68 2a 20 22 2f 74 65 73 74 *toppath* "/test
83f0: 73 2f 22 20 74 65 73 74 2d 6e 61 6d 65 29 29 29 s/" test-name)))
8400: 0a 09 09 20 20 20 20 20 28 74 65 73 74 2d 63 6f ... (test-co
8410: 6e 66 69 67 66 20 28 63 6f 6e 63 20 74 65 73 74 nfigf (conc test
8420: 2d 70 61 74 68 20 22 2f 74 65 73 74 63 6f 6e 66 -path "/testconf
8430: 69 67 22 29 29 0a 09 09 20 20 20 20 20 28 74 65 ig"))... (te
8440: 73 74 65 78 69 73 74 73 20 20 20 28 61 6e 64 20 stexists (and
8450: 28 66 69 6c 65 2d 65 78 69 73 74 73 3f 20 74 65 (file-exists? te
8460: 73 74 2d 63 6f 6e 66 69 67 66 29 28 66 69 6c 65 st-configf)(file
8470: 2d 72 65 61 64 2d 61 63 63 65 73 73 3f 20 74 65 -read-access? te
8480: 73 74 2d 63 6f 6e 66 69 67 66 29 29 29 0a 09 09 st-configf)))...
8490: 20 20 20 20 20 28 74 63 66 67 20 20 20 20 20 20 (tcfg
84a0: 20 20 20 28 69 66 20 74 65 73 74 65 78 69 73 74 (if testexist
84b0: 73 0a 09 09 09 09 20 20 20 20 20 20 20 28 72 65 s..... (re
84c0: 61 64 2d 63 6f 6e 66 69 67 20 74 65 73 74 2d 63 ad-config test-c
84d0: 6f 6e 66 69 67 66 20 23 66 20 73 79 73 74 65 6d onfigf #f system
84e0: 2d 61 6c 6c 6f 77 65 64 0a 09 09 09 09 09 09 20 -allowed.......
84f0: 20 20 20 65 6e 76 69 72 6f 6e 2d 70 61 74 74 3a environ-patt:
8500: 20 28 69 66 20 73 79 73 74 65 6d 2d 61 6c 6c 6f (if system-allo
8510: 77 65 64 0a 09 09 09 09 09 09 09 09 20 20 20 20 wed.........
8520: 20 20 22 70 72 65 2d 6c 61 75 6e 63 68 2d 65 6e "pre-launch-en
8530: 76 2d 76 61 72 73 22 0a 09 09 09 09 09 09 09 09 v-vars".........
8540: 20 20 20 20 20 20 23 66 29 29 0a 09 09 09 09 20 #f)).....
8550: 20 20 20 20 20 20 23 66 29 29 29 0a 09 09 28 69 #f)))...(i
8560: 66 20 28 61 6e 64 20 74 63 66 67 20 63 61 63 68 f (and tcfg cach
8570: 65 2d 66 69 6c 65 29 20 28 68 61 73 68 2d 74 61 e-file) (hash-ta
8580: 62 6c 65 2d 73 65 74 21 20 74 63 66 67 20 22 68 ble-set! tcfg "h
8590: 61 76 65 20 66 75 6c 6c 64 61 74 61 22 20 23 74 ave fulldata" #t
85a0: 29 29 20 3b 3b 20 6d 61 72 6b 20 74 68 69 73 20 )) ;; mark this
85b0: 61 73 20 66 75 6c 6c 79 20 72 65 61 64 20 64 61 as fully read da
85c0: 74 61 0a 09 09 28 69 66 20 74 63 66 67 20 28 68 ta...(if tcfg (h
85d0: 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 2a ash-table-set! *
85e0: 74 65 73 74 63 6f 6e 66 69 67 73 2a 20 74 65 73 testconfigs* tes
85f0: 74 2d 6e 61 6d 65 20 74 63 66 67 29 29 0a 09 09 t-name tcfg))...
8600: 28 69 66 20 28 61 6e 64 20 74 65 73 74 65 78 69 (if (and testexi
8610: 73 74 73 0a 09 09 09 20 63 61 63 68 65 2d 66 69 sts.... cache-fi
8620: 6c 65 0a 09 09 09 20 28 66 69 6c 65 2d 77 72 69 le.... (file-wri
8630: 74 65 2d 61 63 63 65 73 73 3f 20 63 61 63 68 65 te-access? cache
8640: 2d 70 61 74 68 29 29 0a 09 09 20 20 20 20 28 6c -path))... (l
8650: 65 74 20 28 28 74 70 61 74 68 20 28 63 6f 6e 63 et ((tpath (conc
8660: 20 63 61 63 68 65 2d 70 61 74 68 20 22 2f 2e 74 cache-path "/.t
8670: 65 73 74 63 6f 6e 66 69 67 22 29 29 29 0a 09 09 estconfig")))...
8680: 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 (debug:pri
8690: 6e 74 2d 69 6e 66 6f 20 31 20 22 43 61 63 68 69 nt-info 1 "Cachi
86a0: 6e 67 20 74 65 73 74 63 6f 6e 66 69 67 20 66 6f ng testconfig fo
86b0: 72 20 22 20 74 65 73 74 2d 6e 61 6d 65 20 22 20 r " test-name "
86c0: 69 6e 20 22 20 74 70 61 74 68 29 0a 09 09 20 20 in " tpath)...
86d0: 20 20 20 20 28 63 6f 6e 66 69 67 66 3a 77 72 69 (configf:wri
86e0: 74 65 2d 61 6c 69 73 74 20 74 63 66 67 20 74 70 te-alist tcfg tp
86f0: 61 74 68 29 29 29 0a 09 09 74 63 66 67 29 29 29 ath)))...tcfg)))
8700: 29 29 29 0a 20 20 0a 3b 3b 20 73 6f 72 74 20 74 ))). .;; sort t
8710: 65 73 74 73 20 62 79 20 70 72 69 6f 72 69 74 79 ests by priority
8720: 20 61 6e 64 20 77 61 69 74 6f 6e 0a 3b 3b 20 4d and waiton.;; M
8730: 6f 76 65 20 74 65 73 74 20 73 70 65 63 69 66 69 ove test specifi
8740: 63 20 73 74 75 66 66 20 74 6f 20 61 20 74 65 73 c stuff to a tes
8750: 74 20 75 6e 69 74 20 46 49 58 4d 45 20 6f 6e 65 t unit FIXME one
8760: 20 6f 66 20 74 68 65 73 65 20 64 61 79 73 0a 28 of these days.(
8770: 64 65 66 69 6e 65 20 28 74 65 73 74 73 3a 73 6f define (tests:so
8780: 72 74 2d 62 79 2d 70 72 69 6f 72 69 74 79 2d 61 rt-by-priority-a
8790: 6e 64 2d 77 61 69 74 6f 6e 20 74 65 73 74 2d 72 nd-waiton test-r
87a0: 65 63 6f 72 64 73 29 0a 20 20 28 6c 65 74 2a 20 ecords). (let*
87b0: 28 28 6d 75 6e 67 65 70 72 69 6f 72 69 74 79 20 ((mungepriority
87c0: 28 6c 61 6d 62 64 61 20 28 70 72 69 6f 72 69 74 (lambda (priorit
87d0: 79 29 0a 09 09 09 20 20 28 69 66 20 70 72 69 6f y).... (if prio
87e0: 72 69 74 79 0a 09 09 09 20 20 20 20 20 20 28 6c rity.... (l
87f0: 65 74 20 28 28 74 6d 70 20 28 61 6e 79 2d 3e 6e et ((tmp (any->n
8800: 75 6d 62 65 72 20 70 72 69 6f 72 69 74 79 29 29 umber priority))
8810: 29 0a 09 09 09 09 28 69 66 20 74 6d 70 20 74 6d ).....(if tmp tm
8820: 70 20 28 62 65 67 69 6e 20 28 64 65 62 75 67 3a p (begin (debug:
8830: 70 72 69 6e 74 20 30 20 22 45 52 52 4f 52 3a 20 print 0 "ERROR:
8840: 62 61 64 20 70 72 69 6f 72 69 74 79 20 76 61 6c bad priority val
8850: 75 65 20 22 20 70 72 69 6f 72 69 74 79 20 22 2c ue " priority ",
8860: 20 75 73 69 6e 67 20 30 22 29 20 30 29 29 29 0a using 0") 0))).
8870: 09 09 09 20 20 20 20 20 20 30 29 29 29 0a 09 20 ... 0)))..
8880: 28 61 6c 6c 2d 74 65 73 74 73 20 20 20 20 20 20 (all-tests
8890: 28 68 61 73 68 2d 74 61 62 6c 65 2d 6b 65 79 73 (hash-table-keys
88a0: 20 74 65 73 74 2d 72 65 63 6f 72 64 73 29 29 0a test-records)).
88b0: 09 20 28 61 6c 6c 2d 77 61 69 74 65 64 2d 6f 6e . (all-waited-on
88c0: 20 20 28 6c 65 74 20 6c 6f 6f 70 20 28 28 68 65 (let loop ((he
88d0: 64 20 28 63 61 72 20 61 6c 6c 2d 74 65 73 74 73 d (car all-tests
88e0: 29 29 0a 09 09 09 09 20 20 20 20 28 74 61 6c 20 ))..... (tal
88f0: 28 63 64 72 20 61 6c 6c 2d 74 65 73 74 73 29 29 (cdr all-tests))
8900: 0a 09 09 09 09 20 20 20 20 28 72 65 73 20 27 28 ..... (res '(
8910: 29 29 29 0a 09 09 09 20 20 20 28 6c 65 74 2a 20 ))).... (let*
8920: 28 28 74 72 65 63 20 20 20 20 28 68 61 73 68 2d ((trec (hash-
8930: 74 61 62 6c 65 2d 72 65 66 20 74 65 73 74 2d 72 table-ref test-r
8940: 65 63 6f 72 64 73 20 68 65 64 29 29 0a 09 09 09 ecords hed))....
8950: 09 20 20 28 77 61 69 74 6f 6e 73 20 28 6f 72 20 . (waitons (or
8960: 28 74 65 73 74 73 3a 74 65 73 74 71 75 65 75 65 (tests:testqueue
8970: 2d 67 65 74 2d 77 61 69 74 6f 6e 73 20 74 72 65 -get-waitons tre
8980: 63 29 20 27 28 29 29 29 29 0a 09 09 09 20 20 20 c) '())))....
8990: 20 20 28 69 66 20 28 6e 75 6c 6c 3f 20 74 61 6c (if (null? tal
89a0: 29 0a 09 09 09 09 20 28 61 70 70 65 6e 64 20 72 )..... (append r
89b0: 65 73 20 77 61 69 74 6f 6e 73 29 0a 09 09 09 09 es waitons).....
89c0: 20 28 6c 6f 6f 70 20 28 63 61 72 20 74 61 6c 29 (loop (car tal)
89d0: 28 63 64 72 20 74 61 6c 29 28 61 70 70 65 6e 64 (cdr tal)(append
89e0: 20 72 65 73 20 77 61 69 74 6f 6e 73 29 29 29 29 res waitons))))
89f0: 29 29 0a 09 20 28 73 6f 72 74 2d 66 6e 31 20 0a )).. (sort-fn1 .
8a00: 09 20 20 28 6c 61 6d 62 64 61 20 28 61 20 62 29 . (lambda (a b)
8a10: 0a 09 20 20 20 20 28 6c 65 74 2a 20 28 28 61 2d .. (let* ((a-
8a20: 72 65 63 6f 72 64 20 20 20 28 68 61 73 68 2d 74 record (hash-t
8a30: 61 62 6c 65 2d 72 65 66 20 74 65 73 74 2d 72 65 able-ref test-re
8a40: 63 6f 72 64 73 20 61 29 29 0a 09 09 20 20 20 28 cords a))... (
8a50: 62 2d 72 65 63 6f 72 64 20 20 20 28 68 61 73 68 b-record (hash
8a60: 2d 74 61 62 6c 65 2d 72 65 66 20 74 65 73 74 2d -table-ref test-
8a70: 72 65 63 6f 72 64 73 20 62 29 29 0a 09 09 20 20 records b))...
8a80: 20 28 61 2d 77 61 69 74 6f 6e 73 20 20 28 6f 72 (a-waitons (or
8a90: 20 28 74 65 73 74 73 3a 74 65 73 74 71 75 65 75 (tests:testqueu
8aa0: 65 2d 67 65 74 2d 77 61 69 74 6f 6e 73 20 61 2d e-get-waitons a-
8ab0: 72 65 63 6f 72 64 29 20 27 28 29 29 29 0a 09 09 record) '()))...
8ac0: 20 20 20 28 62 2d 77 61 69 74 6f 6e 73 20 20 28 (b-waitons (
8ad0: 6f 72 20 28 74 65 73 74 73 3a 74 65 73 74 71 75 or (tests:testqu
8ae0: 65 75 65 2d 67 65 74 2d 77 61 69 74 6f 6e 73 20 eue-get-waitons
8af0: 62 2d 72 65 63 6f 72 64 29 20 27 28 29 29 29 0a b-record) '())).
8b00: 09 09 20 20 20 28 61 2d 63 6f 6e 66 69 67 20 20 .. (a-config
8b10: 20 28 74 65 73 74 73 3a 74 65 73 74 71 75 65 75 (tests:testqueu
8b20: 65 2d 67 65 74 2d 74 65 73 74 63 6f 6e 66 69 67 e-get-testconfig
8b30: 20 20 61 2d 72 65 63 6f 72 64 29 29 0a 09 09 20 a-record))...
8b40: 20 20 28 62 2d 63 6f 6e 66 69 67 20 20 20 28 74 (b-config (t
8b50: 65 73 74 73 3a 74 65 73 74 71 75 65 75 65 2d 67 ests:testqueue-g
8b60: 65 74 2d 74 65 73 74 63 6f 6e 66 69 67 20 20 62 et-testconfig b
8b70: 2d 72 65 63 6f 72 64 29 29 0a 09 09 20 20 20 28 -record))... (
8b80: 61 2d 72 61 77 2d 70 72 69 20 20 28 63 6f 6e 66 a-raw-pri (conf
8b90: 69 67 2d 6c 6f 6f 6b 75 70 20 61 2d 63 6f 6e 66 ig-lookup a-conf
8ba0: 69 67 20 22 72 65 71 75 69 72 65 6d 65 6e 74 73 ig "requirements
8bb0: 22 20 22 70 72 69 6f 72 69 74 79 22 29 29 0a 09 " "priority"))..
8bc0: 09 20 20 20 28 62 2d 72 61 77 2d 70 72 69 20 20 . (b-raw-pri
8bd0: 28 63 6f 6e 66 69 67 2d 6c 6f 6f 6b 75 70 20 62 (config-lookup b
8be0: 2d 63 6f 6e 66 69 67 20 22 72 65 71 75 69 72 65 -config "require
8bf0: 6d 65 6e 74 73 22 20 22 70 72 69 6f 72 69 74 79 ments" "priority
8c00: 22 29 29 0a 09 09 20 20 20 28 61 2d 70 72 69 6f "))... (a-prio
8c10: 72 69 74 79 20 28 6d 75 6e 67 65 70 72 69 6f 72 rity (mungeprior
8c20: 69 74 79 20 61 2d 72 61 77 2d 70 72 69 29 29 0a ity a-raw-pri)).
8c30: 09 09 20 20 20 28 62 2d 70 72 69 6f 72 69 74 79 .. (b-priority
8c40: 20 28 6d 75 6e 67 65 70 72 69 6f 72 69 74 79 20 (mungepriority
8c50: 62 2d 72 61 77 2d 70 72 69 29 29 29 0a 09 20 20 b-raw-pri)))..
8c60: 20 20 20 20 28 74 65 73 74 73 3a 74 65 73 74 71 (tests:testq
8c70: 75 65 75 65 2d 73 65 74 2d 70 72 69 6f 72 69 74 ueue-set-priorit
8c80: 79 21 20 61 2d 72 65 63 6f 72 64 20 61 2d 70 72 y! a-record a-pr
8c90: 69 6f 72 69 74 79 29 0a 09 20 20 20 20 20 20 28 iority).. (
8ca0: 74 65 73 74 73 3a 74 65 73 74 71 75 65 75 65 2d tests:testqueue-
8cb0: 73 65 74 2d 70 72 69 6f 72 69 74 79 21 20 62 2d set-priority! b-
8cc0: 72 65 63 6f 72 64 20 62 2d 70 72 69 6f 72 69 74 record b-priorit
8cd0: 79 29 0a 09 20 20 20 20 20 20 3b 3b 20 28 64 65 y).. ;; (de
8ce0: 62 75 67 3a 70 72 69 6e 74 20 30 20 22 61 3d 22 bug:print 0 "a="
8cf0: 20 61 20 22 2c 20 62 3d 22 20 62 20 22 2c 20 61 a ", b=" b ", a
8d00: 2d 77 61 69 74 6f 6e 73 3d 22 20 61 2d 77 61 69 -waitons=" a-wai
8d10: 74 6f 6e 73 20 22 2c 20 62 2d 77 61 69 74 6f 6e tons ", b-waiton
8d20: 73 3d 22 20 62 2d 77 61 69 74 6f 6e 73 29 0a 09 s=" b-waitons)..
8d30: 20 20 20 20 20 20 28 63 6f 6e 64 0a 09 20 20 20 (cond..
8d40: 20 20 20 20 3b 3b 20 69 73 20 0a 09 20 20 20 20 ;; is ..
8d50: 20 20 20 28 28 6d 65 6d 62 65 72 20 61 20 62 2d ((member a b-
8d60: 77 61 69 74 6f 6e 73 29 20 20 20 20 20 20 20 20 waitons)
8d70: 20 20 3b 3b 20 69 73 20 62 20 77 61 69 74 69 6e ;; is b waitin
8d80: 67 20 6f 6e 20 61 3f 0a 09 09 3b 3b 20 28 64 65 g on a?...;; (de
8d90: 62 75 67 3a 70 72 69 6e 74 20 30 20 22 63 61 73 bug:print 0 "cas
8da0: 65 31 22 29 0a 09 09 23 74 29 0a 09 20 20 20 20 e1")...#t)..
8db0: 20 20 20 28 28 6d 65 6d 62 65 72 20 62 20 61 2d ((member b a-
8dc0: 77 61 69 74 6f 6e 73 29 20 20 20 20 20 20 20 20 waitons)
8dd0: 20 20 3b 3b 20 69 73 20 61 20 77 61 69 74 69 6e ;; is a waitin
8de0: 67 20 6f 6e 20 62 3f 0a 09 09 3b 3b 20 28 64 65 g on b?...;; (de
8df0: 62 75 67 3a 70 72 69 6e 74 20 30 20 22 63 61 73 bug:print 0 "cas
8e00: 65 32 22 29 0a 09 09 23 66 29 0a 09 20 20 20 20 e2")...#f)..
8e10: 20 20 20 28 28 61 6e 64 20 28 6e 6f 74 20 28 6e ((and (not (n
8e20: 75 6c 6c 3f 20 61 2d 77 61 69 74 6f 6e 73 29 29 ull? a-waitons))
8e30: 20 20 3b 3b 20 62 6f 74 68 20 68 61 76 65 20 77 ;; both have w
8e40: 61 69 74 6f 6e 73 20 2d 20 64 6f 20 6e 6f 74 20 aitons - do not
8e50: 64 69 73 74 75 72 62 0a 09 09 20 20 20 20 20 28 disturb... (
8e60: 6e 6f 74 20 28 6e 75 6c 6c 3f 20 62 2d 77 61 69 not (null? b-wai
8e70: 74 6f 6e 73 29 29 29 0a 09 09 3b 3b 20 28 64 65 tons)))...;; (de
8e80: 62 75 67 3a 70 72 69 6e 74 20 30 20 22 63 61 73 bug:print 0 "cas
8e90: 65 32 2e 31 22 29 0a 09 09 23 74 29 0a 09 20 20 e2.1")...#t)..
8ea0: 20 20 20 20 20 28 28 61 6e 64 20 28 6e 75 6c 6c ((and (null
8eb0: 3f 20 61 2d 77 61 69 74 6f 6e 73 29 20 20 20 20 ? a-waitons)
8ec0: 20 20 20 20 3b 3b 20 6e 6f 20 77 61 69 74 6f 6e ;; no waiton
8ed0: 73 20 66 6f 72 20 61 20 62 75 74 20 62 20 68 61 s for a but b ha
8ee0: 73 20 77 61 69 74 6f 6e 73 0a 09 09 20 20 20 20 s waitons...
8ef0: 20 28 6e 6f 74 20 28 6e 75 6c 6c 3f 20 62 2d 77 (not (null? b-w
8f00: 61 69 74 6f 6e 73 29 29 29 0a 09 09 3b 3b 20 28 aitons)))...;; (
8f10: 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 22 63 debug:print 0 "c
8f20: 61 73 65 33 22 29 0a 09 09 23 66 29 0a 09 20 20 ase3")...#f)..
8f30: 20 20 20 20 20 28 28 61 6e 64 20 28 6e 6f 74 20 ((and (not
8f40: 28 6e 75 6c 6c 3f 20 61 2d 77 61 69 74 6f 6e 73 (null? a-waitons
8f50: 29 29 20 20 3b 3b 20 61 20 68 61 73 20 77 61 69 )) ;; a has wai
8f60: 74 6f 6e 73 20 62 75 74 20 62 20 64 6f 65 73 20 tons but b does
8f70: 6e 6f 74 0a 09 09 20 20 20 20 20 28 6e 75 6c 6c not... (null
8f80: 3f 20 62 2d 77 61 69 74 6f 6e 73 29 29 20 0a 09 ? b-waitons)) ..
8f90: 09 3b 3b 20 28 64 65 62 75 67 3a 70 72 69 6e 74 .;; (debug:print
8fa0: 20 30 20 22 63 61 73 65 34 22 29 0a 09 09 23 74 0 "case4")...#t
8fb0: 29 0a 09 20 20 20 20 20 20 20 28 28 6e 6f 74 20 ).. ((not
8fc0: 28 65 71 3f 20 61 2d 70 72 69 6f 72 69 74 79 20 (eq? a-priority
8fd0: 62 2d 70 72 69 6f 72 69 74 79 29 29 20 3b 3b 20 b-priority)) ;;
8fe0: 75 73 65 0a 09 09 28 3e 20 61 2d 70 72 69 6f 72 use...(> a-prior
8ff0: 69 74 79 20 62 2d 70 72 69 6f 72 69 74 79 29 29 ity b-priority))
9000: 0a 09 20 20 20 20 20 20 20 28 65 6c 73 65 0a 09 .. (else..
9010: 09 3b 3b 20 28 64 65 62 75 67 3a 70 72 69 6e 74 .;; (debug:print
9020: 20 30 20 22 63 61 73 65 35 22 29 0a 09 09 28 73 0 "case5")...(s
9030: 74 72 69 6e 67 3e 3f 20 61 20 62 29 29 29 29 29 tring>? a b)))))
9040: 29 0a 09 20 0a 09 20 28 73 6f 72 74 2d 66 6e 32 ).. .. (sort-fn2
9050: 0a 09 20 20 28 6c 61 6d 62 64 61 20 28 61 20 62 .. (lambda (a b
9060: 29 0a 09 20 20 20 20 28 3e 20 28 6d 75 6e 67 65 ).. (> (munge
9070: 70 72 69 6f 72 69 74 79 20 28 74 65 73 74 73 3a priority (tests:
9080: 74 65 73 74 71 75 65 75 65 2d 67 65 74 2d 70 72 testqueue-get-pr
9090: 69 6f 72 69 74 79 20 28 68 61 73 68 2d 74 61 62 iority (hash-tab
90a0: 6c 65 2d 72 65 66 20 74 65 73 74 2d 72 65 63 6f le-ref test-reco
90b0: 72 64 73 20 61 29 29 29 0a 09 20 20 20 20 20 20 rds a)))..
90c0: 20 28 6d 75 6e 67 65 70 72 69 6f 72 69 74 79 20 (mungepriority
90d0: 28 74 65 73 74 73 3a 74 65 73 74 71 75 65 75 65 (tests:testqueue
90e0: 2d 67 65 74 2d 70 72 69 6f 72 69 74 79 20 28 68 -get-priority (h
90f0: 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 20 74 65 ash-table-ref te
9100: 73 74 2d 72 65 63 6f 72 64 73 20 62 29 29 29 29 st-records b))))
9110: 29 29 29 0a 20 20 20 20 3b 3b 20 28 6c 65 74 20 ))). ;; (let
9120: 28 28 64 6f 74 2d 72 65 73 20 28 74 65 73 74 73 ((dot-res (tests
9130: 3a 72 75 6e 2d 64 6f 74 20 28 74 65 73 74 73 3a :run-dot (tests:
9140: 74 65 73 74 73 2d 3e 64 6f 74 20 74 65 73 74 2d tests->dot test-
9150: 72 65 63 6f 72 64 73 29 20 22 70 6c 61 69 6e 22 records) "plain"
9160: 29 29 29 0a 20 20 20 20 3b 3b 20 20 20 28 64 65 ))). ;; (de
9170: 62 75 67 3a 70 72 69 6e 74 20 22 64 6f 74 2d 72 bug:print "dot-r
9180: 65 73 3d 22 20 64 6f 74 2d 72 65 73 29 29 0a 20 es=" dot-res)).
9190: 20 20 20 3b 3b 20 28 6c 65 74 20 28 28 64 61 74 ;; (let ((dat
91a0: 61 20 28 6d 61 70 20 63 64 72 20 28 66 69 6c 74 a (map cdr (filt
91b0: 65 72 0a 20 20 20 20 3b 3b 20 20 20 20 20 09 09 er. ;; ..
91c0: 20 20 28 6c 61 6d 62 64 61 20 28 78 29 28 65 71 (lambda (x)(eq
91d0: 75 61 6c 3f 20 22 6e 6f 64 65 22 20 28 63 61 72 ual? "node" (car
91e0: 20 78 29 29 29 0a 20 20 20 20 3b 3b 20 20 20 20 x))). ;;
91f0: 20 09 09 20 20 28 6d 61 70 20 73 74 72 69 6e 67 .. (map string
9200: 2d 73 70 6c 69 74 20 28 74 65 73 74 73 3a 65 61 -split (tests:ea
9210: 73 79 2d 64 6f 74 20 74 65 73 74 2d 72 65 63 6f sy-dot test-reco
9220: 72 64 73 20 22 70 6c 61 69 6e 22 29 29 29 29 29 rds "plain")))))
9230: 29 0a 20 20 20 20 3b 3b 20 20 20 28 6d 61 70 20 ). ;; (map
9240: 63 61 72 20 28 73 6f 72 74 20 64 61 74 61 20 28 car (sort data (
9250: 6c 61 6d 62 64 61 20 28 61 20 62 29 0a 20 20 20 lambda (a b).
9260: 20 3b 3b 20 20 20 20 20 09 09 20 20 20 20 28 3e ;; .. (>
9270: 20 28 73 74 72 69 6e 67 2d 3e 6e 75 6d 62 65 72 (string->number
9280: 20 28 63 61 64 64 72 20 61 29 29 28 73 74 72 69 (caddr a))(stri
9290: 6e 67 2d 3e 6e 75 6d 62 65 72 20 28 63 61 64 64 ng->number (cadd
92a0: 72 20 62 29 29 29 29 29 29 29 0a 20 20 20 20 3b r b))))))). ;
92b0: 3b 20 29 29 0a 20 20 20 20 28 73 6f 72 74 20 61 ; )). (sort a
92c0: 6c 6c 2d 74 65 73 74 73 20 73 6f 72 74 2d 66 6e ll-tests sort-fn
92d0: 31 29 29 29 20 3b 3b 20 61 76 6f 69 64 20 64 65 1))) ;; avoid de
92e0: 61 6c 69 6e 67 20 77 69 74 68 20 64 65 6c 65 74 aling with delet
92f0: 65 64 20 74 65 73 74 73 2c 20 6c 6f 6f 6b 20 61 ed tests, look a
9300: 74 20 74 68 65 20 68 61 73 68 20 74 61 62 6c 65 t the hash table
9310: 0a 0a 28 64 65 66 69 6e 65 20 28 74 65 73 74 73 ..(define (tests
9320: 3a 65 61 73 79 2d 64 6f 74 20 74 65 73 74 2d 72 :easy-dot test-r
9330: 65 63 6f 72 64 73 20 6f 75 74 74 79 70 65 29 0a ecords outtype).
9340: 20 20 28 6c 65 74 2d 76 61 6c 75 65 73 20 28 28 (let-values ((
9350: 28 66 64 20 74 65 6d 70 2d 70 61 74 68 29 20 28 (fd temp-path) (
9360: 66 69 6c 65 2d 6d 6b 73 74 65 6d 70 20 28 63 6f file-mkstemp (co
9370: 6e 63 20 22 2f 74 6d 70 2f 22 20 28 63 75 72 72 nc "/tmp/" (curr
9380: 65 6e 74 2d 75 73 65 72 2d 6e 61 6d 65 29 20 22 ent-user-name) "
9390: 2e 58 58 58 58 58 58 22 29 29 29 29 0a 20 20 20 .XXXXXX")))).
93a0: 20 28 6c 65 74 20 28 28 61 6c 6c 2d 74 65 73 74 (let ((all-test
93b0: 6e 61 6d 65 73 20 28 68 61 73 68 2d 74 61 62 6c names (hash-tabl
93c0: 65 2d 6b 65 79 73 20 74 65 73 74 2d 72 65 63 6f e-keys test-reco
93d0: 72 64 73 29 29 0a 09 20 20 28 74 65 6d 70 2d 70 rds)).. (temp-p
93e0: 6f 72 74 20 20 20 20 20 28 6f 70 65 6e 2d 6f 75 ort (open-ou
93f0: 74 70 75 74 2d 66 69 6c 65 2a 20 66 64 29 29 29 tput-file* fd)))
9400: 0a 20 20 20 20 20 20 3b 3b 20 28 66 6f 72 6d 61 . ;; (forma
9410: 74 20 74 65 6d 70 2d 70 6f 72 74 20 22 54 68 69 t temp-port "Thi
9420: 73 20 66 69 6c 65 20 69 73 20 7e 41 2e 7e 25 22 s file is ~A.~%"
9430: 20 74 65 6d 70 2d 70 61 74 68 29 0a 20 20 20 20 temp-path).
9440: 20 20 28 66 6f 72 6d 61 74 20 74 65 6d 70 2d 70 (format temp-p
9450: 6f 72 74 20 22 64 69 67 72 61 70 68 20 74 65 73 ort "digraph tes
9460: 74 73 20 7b 5c 6e 22 29 0a 20 20 20 20 20 20 28 ts {\n"). (
9470: 66 6f 72 6d 61 74 20 74 65 6d 70 2d 70 6f 72 74 format temp-port
9480: 20 22 20 20 73 69 7a 65 3d 34 2c 38 5c 6e 22 29 " size=4,8\n")
9490: 0a 20 20 20 20 20 20 3b 3b 20 28 66 6f 72 6d 61 . ;; (forma
94a0: 74 20 74 65 6d 70 2d 70 6f 72 74 20 22 20 20 20 t temp-port "
94b0: 73 70 6c 69 6e 65 73 3d 6e 6f 6e 65 5c 6e 22 29 splines=none\n")
94c0: 0a 20 20 20 20 20 20 28 66 6f 72 2d 65 61 63 68 . (for-each
94d0: 0a 20 20 20 20 20 20 20 28 6c 61 6d 62 64 61 20 . (lambda
94e0: 28 74 65 73 74 6e 61 6d 65 29 0a 09 20 28 6c 65 (testname).. (le
94f0: 74 2a 20 28 28 74 65 73 74 72 65 63 20 28 68 61 t* ((testrec (ha
9500: 73 68 2d 74 61 62 6c 65 2d 72 65 66 20 74 65 73 sh-table-ref tes
9510: 74 2d 72 65 63 6f 72 64 73 20 74 65 73 74 6e 61 t-records testna
9520: 6d 65 29 29 0a 09 09 28 77 61 69 74 6f 6e 73 20 me))...(waitons
9530: 28 6f 72 20 28 74 65 73 74 73 3a 74 65 73 74 71 (or (tests:testq
9540: 75 65 75 65 2d 67 65 74 2d 77 61 69 74 6f 6e 73 ueue-get-waitons
9550: 20 74 65 73 74 72 65 63 29 20 27 28 29 29 29 29 testrec) '())))
9560: 0a 09 20 20 20 28 66 6f 72 2d 65 61 63 68 0a 09 .. (for-each..
9570: 20 20 20 20 28 6c 61 6d 62 64 61 20 28 77 61 69 (lambda (wai
9580: 74 6f 6e 29 0a 09 20 20 20 20 20 20 28 66 6f 72 ton).. (for
9590: 6d 61 74 20 74 65 6d 70 2d 70 6f 72 74 20 28 63 mat temp-port (c
95a0: 6f 6e 63 20 22 20 20 20 22 20 77 61 69 74 6f 6e onc " " waiton
95b0: 20 22 20 2d 3e 20 22 20 74 65 73 74 6e 61 6d 65 " -> " testname
95c0: 20 22 20 5b 73 70 6c 69 6e 65 73 3d 6f 72 74 68 " [splines=orth
95d0: 6f 5d 5c 6e 22 29 29 29 0a 09 20 20 20 20 77 61 o]\n"))).. wa
95e0: 69 74 6f 6e 73 29 29 29 0a 20 20 20 20 20 20 20 itons))).
95f0: 61 6c 6c 2d 74 65 73 74 6e 61 6d 65 73 29 0a 20 all-testnames).
9600: 20 20 20 20 20 28 66 6f 72 6d 61 74 20 74 65 6d (format tem
9610: 70 2d 70 6f 72 74 20 22 7d 5c 6e 22 29 0a 20 20 p-port "}\n").
9620: 20 20 20 20 28 63 6c 6f 73 65 2d 6f 75 74 70 75 (close-outpu
9630: 74 2d 70 6f 72 74 20 74 65 6d 70 2d 70 6f 72 74 t-port temp-port
9640: 29 0a 20 20 20 20 20 20 28 77 69 74 68 2d 69 6e ). (with-in
9650: 70 75 74 2d 66 72 6f 6d 2d 70 69 70 65 0a 20 20 put-from-pipe.
9660: 20 20 20 20 20 28 63 6f 6e 63 20 22 65 6e 76 20 (conc "env
9670: 2d 69 20 50 41 54 48 3d 24 50 41 54 48 20 64 6f -i PATH=$PATH do
9680: 74 20 2d 54 22 20 6f 75 74 74 79 70 65 20 22 20 t -T" outtype "
9690: 3c 20 22 20 74 65 6d 70 2d 70 61 74 68 29 0a 20 < " temp-path).
96a0: 20 20 20 20 20 20 28 6c 61 6d 62 64 61 20 28 29 (lambda ()
96b0: 0a 09 20 28 6c 65 74 20 28 28 72 65 73 20 28 72 .. (let ((res (r
96c0: 65 61 64 2d 6c 69 6e 65 73 29 29 29 0a 09 20 20 ead-lines)))..
96d0: 20 3b 3b 20 28 64 65 6c 65 74 65 2d 66 69 6c 65 ;; (delete-file
96e0: 20 74 65 6d 70 2d 70 61 74 68 29 0a 09 20 20 20 temp-path)..
96f0: 72 65 73 29 29 29 29 29 29 0a 0a 28 64 65 66 69 res))))))..(defi
9700: 6e 65 20 28 74 65 73 74 73 3a 77 72 69 74 65 2d ne (tests:write-
9710: 64 6f 74 2d 66 69 6c 65 20 74 65 73 74 2d 72 65 dot-file test-re
9720: 63 6f 72 64 73 20 66 6e 61 6d 65 20 73 69 7a 65 cords fname size
9730: 78 20 73 69 7a 65 79 29 0a 20 20 28 69 66 20 28 x sizey). (if (
9740: 66 69 6c 65 2d 77 72 69 74 65 2d 61 63 63 65 73 file-write-acces
9750: 73 3f 20 28 70 61 74 68 6e 61 6d 65 2d 64 69 72 s? (pathname-dir
9760: 65 63 74 6f 72 79 20 66 6e 61 6d 65 29 29 0a 20 ectory fname)).
9770: 20 20 20 20 20 28 77 69 74 68 2d 6f 75 74 70 75 (with-outpu
9780: 74 2d 74 6f 2d 66 69 6c 65 20 66 6e 61 6d 65 0a t-to-file fname.
9790: 09 28 6c 61 6d 62 64 61 20 28 29 0a 09 20 20 28 .(lambda ().. (
97a0: 6d 61 70 20 70 72 69 6e 74 20 28 74 65 73 74 73 map print (tests
97b0: 3a 74 65 73 74 73 2d 3e 64 6f 74 20 74 65 73 74 :tests->dot test
97c0: 2d 72 65 63 6f 72 64 73 20 73 69 7a 65 78 20 73 -records sizex s
97d0: 69 7a 65 79 29 29 29 29 29 29 0a 0a 28 64 65 66 izey))))))..(def
97e0: 69 6e 65 20 28 74 65 73 74 73 3a 74 65 73 74 73 ine (tests:tests
97f0: 2d 3e 64 6f 74 20 74 65 73 74 2d 72 65 63 6f 72 ->dot test-recor
9800: 64 73 20 73 69 7a 65 78 20 73 69 7a 65 79 29 0a ds sizex sizey).
9810: 20 20 28 6c 65 74 20 28 28 61 6c 6c 2d 74 65 73 (let ((all-tes
9820: 74 6e 61 6d 65 73 20 28 68 61 73 68 2d 74 61 62 tnames (hash-tab
9830: 6c 65 2d 6b 65 79 73 20 74 65 73 74 2d 72 65 63 le-keys test-rec
9840: 6f 72 64 73 29 29 29 0a 20 20 20 20 28 69 66 20 ords))). (if
9850: 28 6e 75 6c 6c 3f 20 61 6c 6c 2d 74 65 73 74 6e (null? all-testn
9860: 61 6d 65 73 29 0a 09 27 28 29 0a 09 28 6c 65 74 ames)..'()..(let
9870: 20 6c 6f 6f 70 20 28 28 68 65 64 20 28 63 61 72 loop ((hed (car
9880: 20 61 6c 6c 2d 74 65 73 74 6e 61 6d 65 73 29 29 all-testnames))
9890: 0a 09 09 20 20 20 28 74 61 6c 20 28 63 64 72 20 ... (tal (cdr
98a0: 61 6c 6c 2d 74 65 73 74 6e 61 6d 65 73 29 29 0a all-testnames)).
98b0: 09 09 20 20 20 28 72 65 73 20 28 6c 69 73 74 20 .. (res (list
98c0: 22 64 69 67 72 61 70 68 20 74 65 73 74 73 20 7b "digraph tests {
98d0: 22 0a 09 09 09 20 20 20 20 20 20 28 63 6f 6e 63 ".... (conc
98e0: 20 22 20 73 69 7a 65 3d 5c 22 22 20 28 6f 72 20 " size=\"" (or
98f0: 73 69 7a 65 78 20 31 31 29 20 22 2c 22 20 28 6f sizex 11) "," (o
9900: 72 20 73 69 7a 65 79 20 31 31 29 20 22 5c 22 3b r sizey 11) "\";
9910: 22 29 0a 09 09 09 20 20 20 20 20 20 22 20 72 61 ").... " ra
9920: 74 69 6f 3d 30 2e 39 35 3b 22 0a 09 09 09 20 20 tio=0.95;"....
9930: 20 20 20 20 29 29 29 0a 09 20 20 28 6c 65 74 2a ))).. (let*
9940: 20 28 28 74 65 73 74 72 65 63 20 28 68 61 73 68 ((testrec (hash
9950: 2d 74 61 62 6c 65 2d 72 65 66 20 74 65 73 74 2d -table-ref test-
9960: 72 65 63 6f 72 64 73 20 68 65 64 29 29 0a 09 09 records hed))...
9970: 20 28 77 61 69 74 6f 6e 73 20 28 6f 72 20 28 74 (waitons (or (t
9980: 65 73 74 73 3a 74 65 73 74 71 75 65 75 65 2d 67 ests:testqueue-g
9990: 65 74 2d 77 61 69 74 6f 6e 73 20 74 65 73 74 72 et-waitons testr
99a0: 65 63 29 20 27 28 29 29 29 0a 09 09 20 28 6e 65 ec) '()))... (ne
99b0: 77 72 65 73 20 20 28 61 70 70 65 6e 64 20 72 65 wres (append re
99c0: 73 0a 09 09 09 09 20 20 28 69 66 20 28 6e 75 6c s..... (if (nul
99d0: 6c 3f 20 77 61 69 74 6f 6e 73 29 0a 09 09 09 09 l? waitons).....
99e0: 20 20 20 20 20 20 28 6c 69 73 74 20 28 63 6f 6e (list (con
99f0: 63 20 22 20 20 20 5c 22 22 20 68 65 64 20 22 5c c " \"" hed "\
9a00: 22 20 5b 73 68 61 70 65 3d 62 6f 78 5d 3b 22 29 " [shape=box];")
9a10: 29 0a 09 09 09 09 20 20 20 20 20 20 28 6d 61 70 )..... (map
9a20: 20 28 6c 61 6d 62 64 61 20 28 77 61 69 74 6f 6e (lambda (waiton
9a30: 29 0a 09 09 09 09 09 20 20 20 20 20 28 63 6f 6e )...... (con
9a40: 63 20 22 20 20 20 5c 22 22 20 77 61 69 74 6f 6e c " \"" waiton
9a50: 20 22 5c 22 20 2d 3e 20 5c 22 22 20 68 65 64 20 "\" -> \"" hed
9a60: 22 5c 22 20 5b 73 68 61 70 65 3d 62 6f 78 5d 3b "\" [shape=box];
9a70: 22 29 29 0a 09 09 09 09 09 20 20 20 77 61 69 74 "))...... wait
9a80: 6f 6e 73 29 0a 09 09 09 09 20 20 20 20 20 20 29 ons)..... )
9a90: 29 29 29 0a 09 20 20 20 20 28 69 66 20 28 6e 75 ))).. (if (nu
9aa0: 6c 6c 3f 20 74 61 6c 29 0a 09 09 28 61 70 70 65 ll? tal)...(appe
9ab0: 6e 64 20 6e 65 77 72 65 73 20 28 6c 69 73 74 20 nd newres (list
9ac0: 22 7d 22 29 29 0a 09 09 28 6c 6f 6f 70 20 28 63 "}"))...(loop (c
9ad0: 61 72 20 74 61 6c 29 28 63 64 72 20 74 61 6c 29 ar tal)(cdr tal)
9ae0: 20 6e 65 77 72 65 73 29 0a 09 09 29 29 29 29 29 newres)...)))))
9af0: 29 0a 0a 3b 3b 20 28 74 65 73 74 73 3a 72 75 6e )..;; (tests:run
9b00: 2d 64 6f 74 20 28 6c 69 73 74 20 22 64 69 67 72 -dot (list "digr
9b10: 61 70 68 20 74 65 73 74 73 20 7b 22 20 22 61 20 aph tests {" "a
9b20: 2d 3e 20 62 22 20 22 7d 22 29 20 22 70 6c 61 69 -> b" "}") "plai
9b30: 6e 22 29 0a 0a 28 64 65 66 69 6e 65 20 28 74 65 n")..(define (te
9b40: 73 74 73 3a 72 75 6e 2d 64 6f 74 20 69 6e 64 61 sts:run-dot inda
9b50: 74 20 6f 75 74 74 79 70 65 29 20 3b 3b 20 6f 75 t outtype) ;; ou
9b60: 74 74 79 70 65 20 69 73 20 70 6c 61 69 6e 2c 20 ttype is plain,
9b70: 66 69 67 2c 20 64 6f 74 2c 20 65 74 63 2e 20 68 fig, dot, etc. h
9b80: 74 74 70 3a 2f 2f 77 77 77 2e 67 72 61 70 68 76 ttp://www.graphv
9b90: 69 7a 2e 6f 72 67 2f 63 6f 6e 74 65 6e 74 2f 6f iz.org/content/o
9ba0: 75 74 70 75 74 2d 66 6f 72 6d 61 74 73 0a 20 20 utput-formats.
9bb0: 28 6c 65 74 2d 76 61 6c 75 65 73 20 28 28 28 69 (let-values (((i
9bc0: 6e 70 20 6f 75 70 20 70 69 64 29 28 70 72 6f 63 np oup pid)(proc
9bd0: 65 73 73 20 22 65 6e 76 20 2d 69 20 50 41 54 48 ess "env -i PATH
9be0: 3d 24 50 41 54 48 20 64 6f 74 22 20 28 6c 69 73 =$PATH dot" (lis
9bf0: 74 20 22 2d 54 22 20 6f 75 74 74 79 70 65 29 29 t "-T" outtype))
9c00: 29 29 0a 20 20 20 20 28 77 69 74 68 2d 6f 75 74 )). (with-out
9c10: 70 75 74 2d 74 6f 2d 70 6f 72 74 20 6f 75 70 0a put-to-port oup.
9c20: 20 20 20 20 20 20 28 6c 61 6d 62 64 61 20 28 29 (lambda ()
9c30: 0a 09 28 6d 61 70 20 70 72 69 6e 74 20 69 6e 64 ..(map print ind
9c40: 61 74 29 29 29 0a 20 20 20 20 28 63 6c 6f 73 65 at))). (close
9c50: 2d 6f 75 74 70 75 74 2d 70 6f 72 74 20 6f 75 70 -output-port oup
9c60: 29 0a 20 20 20 20 28 6c 65 74 20 28 28 72 65 73 ). (let ((res
9c70: 20 28 77 69 74 68 2d 69 6e 70 75 74 2d 66 72 6f (with-input-fro
9c80: 6d 2d 70 6f 72 74 20 69 6e 70 0a 09 09 20 28 6c m-port inp... (l
9c90: 61 6d 62 64 61 20 28 29 0a 09 09 20 20 20 28 72 ambda ()... (r
9ca0: 65 61 64 2d 6c 69 6e 65 73 29 29 29 29 29 0a 20 ead-lines))))).
9cb0: 20 20 20 20 20 28 63 6c 6f 73 65 2d 69 6e 70 75 (close-inpu
9cc0: 74 2d 70 6f 72 74 20 69 6e 70 29 0a 20 20 20 20 t-port inp).
9cd0: 20 20 72 65 73 29 29 29 0a 0a 3b 3b 20 72 65 61 res)))..;; rea
9ce0: 64 20 64 61 74 61 20 66 72 6f 6d 20 74 6d 70 20 d data from tmp
9cf0: 66 69 6c 65 20 6f 72 20 63 72 65 61 74 65 20 69 file or create i
9d00: 66 20 6e 6f 74 20 65 78 69 73 74 73 0a 3b 3b 20 f not exists.;;
9d10: 69 66 20 65 78 69 73 74 73 20 72 65 67 65 6e 20 if exists regen
9d20: 69 6e 20 62 61 63 6b 67 72 6f 75 6e 64 0a 3b 3b in background.;;
9d30: 0a 28 64 65 66 69 6e 65 20 28 74 65 73 74 73 3a .(define (tests:
9d40: 6c 61 7a 79 2d 64 6f 74 20 74 65 73 74 72 65 63 lazy-dot testrec
9d50: 6f 72 64 73 20 20 6f 75 74 74 79 70 65 20 73 69 ords outtype si
9d60: 7a 65 78 20 73 69 7a 65 79 29 0a 20 20 28 6c 65 zex sizey). (le
9d70: 74 20 28 28 64 66 69 6c 65 20 28 63 6f 6e 63 20 t ((dfile (conc
9d80: 22 2f 74 6d 70 2f 2e 22 20 28 63 75 72 72 65 6e "/tmp/." (curren
9d90: 74 2d 75 73 65 72 2d 6e 61 6d 65 29 20 22 2d 22 t-user-name) "-"
9da0: 20 28 73 65 72 76 65 72 3a 6d 6b 2d 73 69 67 6e (server:mk-sign
9db0: 61 74 75 72 65 29 20 22 2e 64 6f 74 22 29 29 0a ature) ".dot")).
9dc0: 09 28 66 6e 61 6d 65 20 28 63 6f 6e 63 20 22 2f .(fname (conc "/
9dd0: 74 6d 70 2f 2e 22 20 28 63 75 72 72 65 6e 74 2d tmp/." (current-
9de0: 75 73 65 72 2d 6e 61 6d 65 29 20 22 2d 22 20 28 user-name) "-" (
9df0: 73 65 72 76 65 72 3a 6d 6b 2d 73 69 67 6e 61 74 server:mk-signat
9e00: 75 72 65 29 20 22 2e 64 6f 74 64 61 74 22 29 29 ure) ".dotdat"))
9e10: 29 0a 20 20 20 20 28 74 65 73 74 73 3a 77 72 69 ). (tests:wri
9e20: 74 65 2d 64 6f 74 2d 66 69 6c 65 20 74 65 73 74 te-dot-file test
9e30: 72 65 63 6f 72 64 73 20 64 66 69 6c 65 20 73 69 records dfile si
9e40: 7a 65 78 20 73 69 7a 65 79 29 0a 20 20 20 20 28 zex sizey). (
9e50: 69 66 20 28 66 69 6c 65 2d 65 78 69 73 74 73 3f if (file-exists?
9e60: 20 66 6e 61 6d 65 29 0a 09 28 6c 65 74 20 28 28 fname)..(let ((
9e70: 72 65 73 20 28 77 69 74 68 2d 69 6e 70 75 74 2d res (with-input-
9e80: 66 72 6f 6d 2d 66 69 6c 65 20 66 6e 61 6d 65 0a from-file fname.
9e90: 09 09 20 20 20 20 20 28 6c 61 6d 62 64 61 20 28 .. (lambda (
9ea0: 29 0a 09 09 20 20 20 20 20 20 20 28 72 65 61 64 )... (read
9eb0: 2d 6c 69 6e 65 73 29 29 29 29 29 0a 09 20 20 28 -lines))))).. (
9ec0: 73 79 73 74 65 6d 20 28 63 6f 6e 63 20 22 65 6e system (conc "en
9ed0: 76 20 2d 69 20 50 41 54 48 3d 24 50 41 54 48 20 v -i PATH=$PATH
9ee0: 64 6f 74 20 2d 54 20 22 20 6f 75 74 74 79 70 65 dot -T " outtype
9ef0: 20 22 20 3c 20 22 20 64 66 69 6c 65 20 22 20 3e " < " dfile " >
9f00: 20 22 20 66 6e 61 6d 65 20 22 26 22 29 29 0a 09 " fname "&"))..
9f10: 20 20 72 65 73 29 0a 09 28 62 65 67 69 6e 0a 09 res)..(begin..
9f20: 20 20 28 73 79 73 74 65 6d 20 28 63 6f 6e 63 20 (system (conc
9f30: 22 65 6e 76 20 2d 69 20 50 41 54 48 3d 24 50 41 "env -i PATH=$PA
9f40: 54 48 20 64 6f 74 20 2d 54 20 22 20 6f 75 74 74 TH dot -T " outt
9f50: 79 70 65 20 22 20 3c 20 22 20 64 66 69 6c 65 20 ype " < " dfile
9f60: 22 20 3e 20 22 20 66 6e 61 6d 65 29 29 0a 09 20 " > " fname))..
9f70: 20 28 77 69 74 68 2d 69 6e 70 75 74 2d 66 72 6f (with-input-fro
9f80: 6d 2d 66 69 6c 65 20 66 6e 61 6d 65 0a 09 20 20 m-file fname..
9f90: 20 20 28 6c 61 6d 62 64 61 20 28 29 0a 09 20 20 (lambda ()..
9fa0: 20 20 20 20 28 72 65 61 64 2d 6c 69 6e 65 73 29 (read-lines)
9fb0: 29 29 29 29 29 29 0a 09 20 20 0a 0a 3b 3b 20 66 )))))).. ..;; f
9fc0: 6f 72 20 65 61 63 68 20 74 65 73 74 3a 0a 3b 3b or each test:.;;
9fd0: 20 20 20 0a 28 64 65 66 69 6e 65 20 28 74 65 73 .(define (tes
9fe0: 74 73 3a 66 69 6c 74 65 72 2d 6e 6f 6e 2d 72 75 ts:filter-non-ru
9ff0: 6e 6e 61 62 6c 65 20 72 75 6e 2d 69 64 20 74 65 nnable run-id te
a000: 73 74 6b 65 79 6e 61 6d 65 73 20 74 65 73 74 72 stkeynames testr
a010: 65 63 6f 72 64 73 68 61 73 68 29 0a 20 20 28 6c ecordshash). (l
a020: 65 74 20 28 28 72 75 6e 6e 61 62 6c 65 73 20 27 et ((runnables '
a030: 28 29 29 29 0a 20 20 20 20 28 66 6f 72 2d 65 61 ())). (for-ea
a040: 63 68 0a 20 20 20 20 20 28 6c 61 6d 62 64 61 20 ch. (lambda
a050: 28 74 65 73 74 6b 65 79 6e 61 6d 65 29 0a 20 20 (testkeyname).
a060: 20 20 20 20 20 28 6c 65 74 2a 20 28 28 74 65 73 (let* ((tes
a070: 74 2d 72 65 63 6f 72 64 20 28 68 61 73 68 2d 74 t-record (hash-t
a080: 61 62 6c 65 2d 72 65 66 20 74 65 73 74 72 65 63 able-ref testrec
a090: 6f 72 64 73 68 61 73 68 20 74 65 73 74 6b 65 79 ordshash testkey
a0a0: 6e 61 6d 65 29 29 0a 09 20 20 20 20 20 20 28 74 name)).. (t
a0b0: 65 73 74 2d 6e 61 6d 65 20 20 20 28 74 65 73 74 est-name (test
a0c0: 73 3a 74 65 73 74 71 75 65 75 65 2d 67 65 74 2d s:testqueue-get-
a0d0: 74 65 73 74 6e 61 6d 65 20 20 74 65 73 74 2d 72 testname test-r
a0e0: 65 63 6f 72 64 29 29 0a 09 20 20 20 20 20 20 28 ecord)).. (
a0f0: 69 74 65 6d 64 61 74 20 20 20 20 20 28 74 65 73 itemdat (tes
a100: 74 73 3a 74 65 73 74 71 75 65 75 65 2d 67 65 74 ts:testqueue-get
a110: 2d 69 74 65 6d 64 61 74 20 20 20 74 65 73 74 2d -itemdat test-
a120: 72 65 63 6f 72 64 29 29 0a 09 20 20 20 20 20 20 record))..
a130: 28 69 74 65 6d 2d 70 61 74 68 20 20 20 28 74 65 (item-path (te
a140: 73 74 73 3a 74 65 73 74 71 75 65 75 65 2d 67 65 sts:testqueue-ge
a150: 74 2d 69 74 65 6d 5f 70 61 74 68 20 74 65 73 74 t-item_path test
a160: 2d 72 65 63 6f 72 64 29 29 0a 09 20 20 20 20 20 -record))..
a170: 20 28 77 61 69 74 6f 6e 73 20 20 20 20 20 28 74 (waitons (t
a180: 65 73 74 73 3a 74 65 73 74 71 75 65 75 65 2d 67 ests:testqueue-g
a190: 65 74 2d 77 61 69 74 6f 6e 73 20 20 20 74 65 73 et-waitons tes
a1a0: 74 2d 72 65 63 6f 72 64 29 29 0a 09 20 20 20 20 t-record))..
a1b0: 20 20 28 6b 65 65 70 2d 74 65 73 74 20 20 20 23 (keep-test #
a1c0: 74 29 0a 09 20 20 20 20 20 20 28 74 65 73 74 2d t).. (test-
a1d0: 69 64 20 20 20 20 20 28 72 6d 74 3a 67 65 74 2d id (rmt:get-
a1e0: 74 65 73 74 2d 69 64 20 72 75 6e 2d 69 64 20 74 test-id run-id t
a1f0: 65 73 74 2d 6e 61 6d 65 20 69 74 65 6d 2d 70 61 est-name item-pa
a200: 74 68 29 29 0a 09 20 20 20 20 20 20 28 74 64 61 th)).. (tda
a210: 74 20 20 20 20 20 20 20 20 28 72 6d 74 3a 67 65 t (rmt:ge
a220: 74 2d 74 65 73 74 69 6e 66 6f 2d 73 74 61 74 65 t-testinfo-state
a230: 2d 73 74 61 74 75 73 20 72 75 6e 2d 69 64 20 74 -status run-id t
a240: 65 73 74 2d 69 64 29 29 29 20 3b 3b 20 28 63 64 est-id))) ;; (cd
a250: 62 3a 67 65 74 2d 74 65 73 74 2d 69 6e 66 6f 2d b:get-test-info-
a260: 62 79 2d 69 64 20 2a 72 75 6e 72 65 6d 6f 74 65 by-id *runremote
a270: 2a 20 74 65 73 74 2d 69 64 29 29 29 0a 09 20 28 * test-id))).. (
a280: 69 66 20 74 64 61 74 0a 09 20 20 20 20 20 28 62 if tdat.. (b
a290: 65 67 69 6e 0a 09 20 20 20 20 20 20 20 3b 3b 20 egin.. ;;
a2a0: 4c 6f 6f 6b 20 61 74 20 74 68 65 20 74 65 73 74 Look at the test
a2b0: 20 73 74 61 74 65 20 61 6e 64 20 73 74 61 74 75 state and statu
a2c0: 73 0a 09 20 20 20 20 20 20 20 28 69 66 20 28 6f s.. (if (o
a2d0: 72 20 28 61 6e 64 20 28 6d 65 6d 62 65 72 20 28 r (and (member (
a2e0: 64 62 3a 74 65 73 74 2d 67 65 74 2d 73 74 61 74 db:test-get-stat
a2f0: 75 73 20 74 64 61 74 29 20 0a 09 09 09 09 20 20 us tdat) .....
a300: 20 20 27 28 22 50 41 53 53 22 20 22 57 41 52 4e '("PASS" "WARN
a310: 22 20 22 57 41 49 56 45 44 22 20 22 43 48 45 43 " "WAIVED" "CHEC
a320: 4b 22 20 22 53 4b 49 50 22 29 29 0a 09 09 09 20 K" "SKIP"))....
a330: 20 20 20 28 65 71 75 61 6c 3f 20 28 64 62 3a 74 (equal? (db:t
a340: 65 73 74 2d 67 65 74 2d 73 74 61 74 65 20 74 64 est-get-state td
a350: 61 74 29 20 22 43 4f 4d 50 4c 45 54 45 44 22 29 at) "COMPLETED")
a360: 29 0a 09 09 20 20 20 20 20 20 20 28 6d 65 6d 62 )... (memb
a370: 65 72 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d er (db:test-get-
a380: 73 74 61 74 65 20 74 64 61 74 29 0a 09 09 09 09 state tdat).....
a390: 20 20 20 20 27 28 22 49 4e 43 4f 4d 50 4c 45 54 '("INCOMPLET
a3a0: 45 22 20 22 4b 49 4c 4c 45 44 22 29 29 29 0a 09 E" "KILLED")))..
a3b0: 09 20 20 20 28 73 65 74 21 20 6b 65 65 70 2d 74 . (set! keep-t
a3c0: 65 73 74 20 23 66 29 29 0a 0a 09 20 20 20 20 20 est #f))...
a3d0: 20 20 3b 3b 20 65 78 61 6d 69 6e 65 20 77 61 69 ;; examine wai
a3e0: 74 6f 6e 73 20 66 6f 72 20 61 6e 79 20 66 61 69 tons for any fai
a3f0: 6c 73 2e 20 49 66 20 69 74 20 69 73 20 46 41 49 ls. If it is FAI
a400: 4c 20 6f 72 20 49 4e 43 4f 4d 50 4c 45 54 45 20 L or INCOMPLETE
a410: 74 68 65 6e 20 65 6c 69 6d 69 6e 61 74 65 20 74 then eliminate t
a420: 68 69 73 20 74 65 73 74 0a 09 20 20 20 20 20 20 his test..
a430: 20 3b 3b 20 66 72 6f 6d 20 74 68 65 20 72 75 6e ;; from the run
a440: 6e 61 62 6c 65 20 6c 69 73 74 0a 09 20 20 20 20 nable list..
a450: 20 20 20 28 69 66 20 6b 65 65 70 2d 74 65 73 74 (if keep-test
a460: 0a 09 09 20 20 20 28 66 6f 72 2d 65 61 63 68 20 ... (for-each
a470: 28 6c 61 6d 62 64 61 20 28 77 61 69 74 6f 6e 29 (lambda (waiton)
a480: 0a 09 09 09 20 20 20 20 20 20 20 3b 3b 20 66 6f .... ;; fo
a490: 72 20 6e 6f 77 20 77 65 20 61 72 65 20 77 61 69 r now we are wai
a4a0: 74 69 6e 67 20 6f 6e 6c 79 20 6f 6e 20 74 68 65 ting only on the
a4b0: 20 70 61 72 65 6e 74 20 74 65 73 74 0a 09 09 09 parent test....
a4c0: 20 20 20 20 20 20 20 28 6c 65 74 2a 20 28 28 70 (let* ((p
a4d0: 61 72 65 6e 74 2d 74 65 73 74 2d 69 64 20 28 72 arent-test-id (r
a4e0: 6d 74 3a 67 65 74 2d 74 65 73 74 2d 69 64 20 72 mt:get-test-id r
a4f0: 75 6e 2d 69 64 20 77 61 69 74 6f 6e 20 22 22 29 un-id waiton "")
a500: 29 0a 09 09 09 09 20 20 20 20 20 20 28 77 74 64 )..... (wtd
a510: 61 74 20 20 20 20 20 20 20 20 20 20 28 72 6d 74 at (rmt
a520: 3a 67 65 74 2d 74 65 73 74 69 6e 66 6f 2d 73 74 :get-testinfo-st
a530: 61 74 65 2d 73 74 61 74 75 73 20 72 75 6e 2d 69 ate-status run-i
a540: 64 20 74 65 73 74 2d 69 64 29 29 29 20 3b 3b 20 d test-id))) ;;
a550: 28 63 64 62 3a 67 65 74 2d 74 65 73 74 2d 69 6e (cdb:get-test-in
a560: 66 6f 2d 62 79 2d 69 64 20 2a 72 75 6e 72 65 6d fo-by-id *runrem
a570: 6f 74 65 2a 20 74 65 73 74 2d 69 64 29 29 29 0a ote* test-id))).
a580: 09 09 09 09 20 28 69 66 20 28 6f 72 20 28 61 6e .... (if (or (an
a590: 64 20 28 65 71 75 61 6c 3f 20 28 64 62 3a 74 65 d (equal? (db:te
a5a0: 73 74 2d 67 65 74 2d 73 74 61 74 65 20 77 74 64 st-get-state wtd
a5b0: 61 74 29 20 22 43 4f 4d 50 4c 45 54 45 44 22 29 at) "COMPLETED")
a5c0: 0a 09 09 09 09 09 20 20 20 20 20 20 28 6d 65 6d ...... (mem
a5d0: 62 65 72 20 28 64 62 3a 74 65 73 74 2d 67 65 74 ber (db:test-get
a5e0: 2d 73 74 61 74 75 73 20 77 74 64 61 74 29 20 27 -status wtdat) '
a5f0: 28 22 46 41 49 4c 22 20 22 41 42 4f 52 54 22 29 ("FAIL" "ABORT")
a600: 29 29 0a 09 09 09 09 09 20 28 6d 65 6d 62 65 72 ))...... (member
a610: 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 73 74 (db:test-get-st
a620: 61 74 75 73 20 77 74 64 61 74 29 20 20 27 28 22 atus wtdat) '("
a630: 4b 49 4c 4c 45 44 22 29 29 0a 09 09 09 09 09 20 KILLED"))......
a640: 28 6d 65 6d 62 65 72 20 28 64 62 3a 74 65 73 74 (member (db:test
a650: 2d 67 65 74 2d 73 74 61 74 65 20 77 74 64 61 74 -get-state wtdat
a660: 29 20 20 20 27 28 22 49 4e 43 4f 4d 50 45 54 45 ) '("INCOMPETE
a670: 22 29 29 29 0a 09 09 09 09 20 3b 3b 20 28 69 66 ")))..... ;; (if
a680: 20 28 6f 72 20 28 6d 65 6d 62 65 72 20 28 64 62 (or (member (db
a690: 3a 74 65 73 74 2d 67 65 74 2d 73 74 61 74 75 73 :test-get-status
a6a0: 20 77 74 64 61 74 29 0a 09 09 09 09 20 3b 3b 20 wtdat)..... ;;
a6b0: 20 20 20 20 20 20 20 09 20 27 28 22 46 41 49 4c . '("FAIL
a6c0: 22 20 22 4b 49 4c 4c 45 44 22 29 29 0a 09 09 09 " "KILLED"))....
a6d0: 09 20 3b 3b 20 20 20 20 20 20 20 20 20 28 6d 65 . ;; (me
a6e0: 6d 62 65 72 20 28 64 62 3a 74 65 73 74 2d 67 65 mber (db:test-ge
a6f0: 74 2d 73 74 61 74 65 20 77 74 64 61 74 29 0a 09 t-state wtdat)..
a700: 09 09 09 20 3b 3b 20 20 20 20 20 20 20 20 09 20 ... ;; .
a710: 27 28 22 49 4e 43 4f 4d 50 45 54 45 22 29 29 29 '("INCOMPETE")))
a720: 0a 09 09 09 09 20 20 20 20 20 28 73 65 74 21 20 ..... (set!
a730: 6b 65 65 70 2d 74 65 73 74 20 23 66 29 29 29 29 keep-test #f))))
a740: 20 3b 3b 20 6e 6f 20 70 6f 69 6e 74 20 69 6e 20 ;; no point in
a750: 72 75 6e 6e 69 6e 67 20 74 68 69 73 20 6f 6e 65 running this one
a760: 20 61 67 61 69 6e 0a 09 09 09 20 20 20 20 20 77 again.... w
a770: 61 69 74 6f 6e 73 29 29 29 29 0a 09 20 28 69 66 aitons)))).. (if
a780: 20 6b 65 65 70 2d 74 65 73 74 20 28 73 65 74 21 keep-test (set!
a790: 20 72 75 6e 6e 61 62 6c 65 73 20 28 63 6f 6e 73 runnables (cons
a7a0: 20 74 65 73 74 6b 65 79 6e 61 6d 65 20 72 75 6e testkeyname run
a7b0: 6e 61 62 6c 65 73 29 29 29 29 29 0a 20 20 20 20 nables))))).
a7c0: 20 74 65 73 74 6b 65 79 6e 61 6d 65 73 29 0a 20 testkeynames).
a7d0: 20 20 20 72 75 6e 6e 61 62 6c 65 73 29 29 0a 0a runnables))..
a7e0: 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;;==============
a7f0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
a800: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
a810: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
a820: 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 72 65 66 61 ========.;; refa
a830: 63 74 6f 72 69 6e 67 20 74 68 69 73 20 62 6c 6f ctoring this blo
a840: 63 6b 20 69 6e 74 6f 20 74 65 73 74 73 3a 67 65 ck into tests:ge
a850: 74 2d 66 75 6c 6c 2d 64 61 74 61 20 66 72 6f 6d t-full-data from
a860: 20 6c 69 6e 65 20 32 36 33 20 6f 66 20 72 75 6e line 263 of run
a870: 73 2e 73 63 6d 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d s.scm.;;========
a880: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
a890: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
a8a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
a8b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b ==============.;
a8c0: 3b 20 68 65 64 20 69 73 20 74 68 65 20 74 65 73 ; hed is the tes
a8d0: 74 20 6e 61 6d 65 0a 3b 3b 20 74 65 73 74 2d 72 t name.;; test-r
a8e0: 65 63 6f 72 64 73 20 69 73 20 61 20 68 61 73 68 ecords is a hash
a8f0: 20 6f 66 20 74 65 73 74 2d 6e 61 6d 65 20 3d 3e of test-name =>
a900: 20 74 65 73 74 20 72 65 63 6f 72 64 0a 28 64 65 test record.(de
a910: 66 69 6e 65 20 28 74 65 73 74 73 3a 67 65 74 2d fine (tests:get-
a920: 66 75 6c 6c 2d 64 61 74 61 20 74 65 73 74 2d 6e full-data test-n
a930: 61 6d 65 73 20 74 65 73 74 2d 72 65 63 6f 72 64 ames test-record
a940: 73 20 72 65 71 75 69 72 65 64 2d 74 65 73 74 73 s required-tests
a950: 20 61 6c 6c 2d 74 65 73 74 73 2d 72 65 67 69 73 all-tests-regis
a960: 74 72 79 29 0a 20 20 28 69 66 20 28 6e 6f 74 20 try). (if (not
a970: 28 6e 75 6c 6c 3f 20 74 65 73 74 2d 6e 61 6d 65 (null? test-name
a980: 73 29 29 0a 20 20 20 20 20 20 28 6c 65 74 20 6c s)). (let l
a990: 6f 6f 70 20 28 28 68 65 64 20 28 63 61 72 20 74 oop ((hed (car t
a9a0: 65 73 74 2d 6e 61 6d 65 73 29 29 0a 09 09 20 28 est-names))... (
a9b0: 74 61 6c 20 28 63 64 72 20 74 65 73 74 2d 6e 61 tal (cdr test-na
a9c0: 6d 65 73 29 29 29 20 20 20 20 20 20 20 20 20 3b mes))) ;
a9d0: 3b 20 27 72 65 74 75 72 6e 2d 70 72 6f 63 73 20 ; 'return-procs
a9e0: 74 65 6c 6c 73 20 74 68 65 20 63 6f 6e 66 69 67 tells the config
a9f0: 20 72 65 61 64 65 72 20 74 6f 20 70 72 65 70 20 reader to prep
aa00: 72 75 6e 6e 69 6e 67 20 73 79 73 74 65 6d 20 62 running system b
aa10: 75 74 20 72 65 74 75 72 6e 20 61 20 70 72 6f 63 ut return a proc
aa20: 0a 09 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 ..(debug:print-i
aa30: 6e 66 6f 20 34 20 22 68 65 64 3d 22 20 68 65 64 nfo 4 "hed=" hed
aa40: 20 22 20 61 74 20 74 6f 70 20 6f 66 20 6c 6f 6f " at top of loo
aa50: 70 22 29 0a 09 28 6c 65 74 2a 20 28 28 63 6f 6e p")..(let* ((con
aa60: 66 69 67 20 20 28 74 65 73 74 73 3a 67 65 74 2d fig (tests:get-
aa70: 74 65 73 74 63 6f 6e 66 69 67 20 68 65 64 20 61 testconfig hed a
aa80: 6c 6c 2d 74 65 73 74 73 2d 72 65 67 69 73 74 72 ll-tests-registr
aa90: 79 20 27 72 65 74 75 72 6e 2d 70 72 6f 63 73 29 y 'return-procs)
aaa0: 29 0a 09 20 20 20 20 20 20 20 28 77 61 69 74 6f ).. (waito
aab0: 6e 73 20 28 6c 65 74 20 28 28 69 6e 73 74 72 20 ns (let ((instr
aac0: 28 69 66 20 63 6f 6e 66 69 67 20 0a 09 09 09 09 (if config .....
aad0: 09 20 28 63 6f 6e 66 69 67 2d 6c 6f 6f 6b 75 70 . (config-lookup
aae0: 20 63 6f 6e 66 69 67 20 22 72 65 71 75 69 72 65 config "require
aaf0: 6d 65 6e 74 73 22 20 22 77 61 69 74 6f 6e 22 29 ments" "waiton")
ab00: 0a 09 09 09 09 09 20 28 62 65 67 69 6e 20 3b 3b ...... (begin ;;
ab10: 20 4e 6f 20 63 6f 6e 66 69 67 20 6d 65 61 6e 73 No config means
ab20: 20 74 68 69 73 20 69 73 20 61 20 6e 6f 6e 2d 65 this is a non-e
ab30: 78 69 73 74 61 6e 74 20 74 65 73 74 0a 09 09 09 xistant test....
ab40: 09 09 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e .. (debug:prin
ab50: 74 20 30 20 22 45 52 52 4f 52 3a 20 6e 6f 6e 2d t 0 "ERROR: non-
ab60: 65 78 69 73 74 65 6e 74 20 72 65 71 75 69 72 65 existent require
ab70: 64 20 74 65 73 74 20 5c 22 22 20 68 65 64 20 22 d test \"" hed "
ab80: 5c 22 2c 20 67 72 65 70 20 74 68 72 6f 75 67 68 \", grep through
ab90: 20 79 6f 75 72 20 74 65 73 74 63 6f 6e 66 69 67 your testconfig
aba0: 73 20 74 6f 20 66 69 6e 64 20 61 6e 64 20 72 65 s to find and re
abb0: 6d 6f 76 65 20 6f 72 20 63 72 65 61 74 65 20 74 move or create t
abc0: 68 65 20 74 65 73 74 2e 20 44 69 73 63 61 72 64 he test. Discard
abd0: 69 6e 67 20 61 6e 64 20 63 6f 6e 74 69 6e 75 69 ing and continui
abe0: 6e 67 2e 22 29 0a 09 09 09 09 09 20 20 20 20 20 ng.")......
abf0: 22 22 29 29 29 29 0a 09 09 09 20 20 28 64 65 62 "")))).... (deb
ac00: 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 38 20 ug:print-info 8
ac10: 22 77 61 69 74 6f 6e 73 20 73 74 72 69 6e 67 20 "waitons string
ac20: 69 73 20 22 20 69 6e 73 74 72 29 0a 09 09 09 20 is " instr)....
ac30: 20 28 73 74 72 69 6e 67 2d 73 70 6c 69 74 20 28 (string-split (
ac40: 63 6f 6e 64 0a 09 09 09 09 09 20 28 28 70 72 6f cond...... ((pro
ac50: 63 65 64 75 72 65 3f 20 69 6e 73 74 72 29 0a 09 cedure? instr)..
ac60: 09 09 09 09 20 20 28 6c 65 74 20 28 28 72 65 73 .... (let ((res
ac70: 20 28 69 6e 73 74 72 29 29 29 0a 09 09 09 09 09 (instr)))......
ac80: 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 (debug:print
ac90: 2d 69 6e 66 6f 20 38 20 22 77 61 69 74 6f 6e 20 -info 8 "waiton
aca0: 70 72 6f 63 65 64 75 72 65 20 72 65 73 75 6c 74 procedure result
acb0: 73 20 69 6e 20 73 74 72 69 6e 67 20 22 20 72 65 s in string " re
acc0: 73 20 22 20 66 6f 72 20 74 65 73 74 20 22 20 68 s " for test " h
acd0: 65 64 29 0a 09 09 09 09 09 20 20 20 20 72 65 73 ed)...... res
ace0: 29 29 0a 09 09 09 09 09 20 28 28 73 74 72 69 6e ))...... ((strin
acf0: 67 3f 20 69 6e 73 74 72 29 20 20 20 20 20 69 6e g? instr) in
ad00: 73 74 72 29 0a 09 09 09 09 09 20 28 65 6c 73 65 str)...... (else
ad10: 20 0a 09 09 09 09 09 20 20 3b 3b 20 4e 4f 54 45 ...... ;; NOTE
ad20: 3a 20 54 68 69 73 20 69 73 20 61 63 74 75 61 6c : This is actual
ad30: 6c 79 20 74 68 65 20 63 61 73 65 20 6f 66 20 2a ly the case of *
ad40: 6e 6f 2a 20 77 61 69 74 6f 6e 73 21 20 3b 3b 20 no* waitons! ;;
ad50: 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 22 (debug:print 0 "
ad60: 45 52 52 4f 52 3a 20 73 6f 6d 65 74 68 69 6e 67 ERROR: something
ad70: 20 77 65 6e 74 20 77 72 6f 6e 67 20 69 6e 20 70 went wrong in p
ad80: 72 6f 63 65 73 73 69 6e 67 20 77 61 69 74 6f 6e rocessing waiton
ad90: 73 20 66 6f 72 20 74 65 73 74 20 22 20 68 65 64 s for test " hed
ada0: 29 0a 09 09 09 09 09 20 20 22 22 29 29 29 29 29 )...... "")))))
adb0: 29 0a 09 20 20 28 69 66 20 28 6e 6f 74 20 63 6f ).. (if (not co
adc0: 6e 66 69 67 29 20 3b 3b 20 74 68 69 73 20 69 73 nfig) ;; this is
add0: 20 61 20 6e 6f 6e 2d 65 78 69 73 74 61 6e 74 20 a non-existant
ade0: 74 65 73 74 20 63 61 6c 6c 65 64 20 69 6e 20 61 test called in a
adf0: 20 77 61 69 74 6f 6e 2e 20 0a 09 20 20 20 20 20 waiton. ..
ae00: 20 28 69 66 20 28 6e 75 6c 6c 3f 20 74 61 6c 29 (if (null? tal)
ae10: 0a 09 09 20 20 74 65 73 74 2d 72 65 63 6f 72 64 ... test-record
ae20: 73 0a 09 09 20 20 28 6c 6f 6f 70 20 28 63 61 72 s... (loop (car
ae30: 20 74 61 6c 29 28 63 64 72 20 74 61 6c 29 29 29 tal)(cdr tal)))
ae40: 0a 09 20 20 20 20 20 20 28 62 65 67 69 6e 0a 09 .. (begin..
ae50: 09 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e .(debug:print-in
ae60: 66 6f 20 38 20 22 77 61 69 74 6f 6e 73 3a 20 22 fo 8 "waitons: "
ae70: 20 77 61 69 74 6f 6e 73 29 0a 09 09 3b 3b 20 63 waitons)...;; c
ae80: 68 65 63 6b 20 66 6f 72 20 68 65 64 20 69 6e 20 heck for hed in
ae90: 77 61 69 74 6f 6e 73 20 3d 3e 20 74 68 69 73 20 waitons => this
aea0: 77 6f 75 6c 64 20 62 65 20 63 69 72 63 75 6c 61 would be circula
aeb0: 72 2c 20 72 65 6d 6f 76 65 20 69 74 20 61 6e 64 r, remove it and
aec0: 20 69 73 73 75 65 20 61 6e 0a 09 09 3b 3b 20 65 issue an...;; e
aed0: 72 72 6f 72 0a 09 09 28 69 66 20 28 6d 65 6d 62 rror...(if (memb
aee0: 65 72 20 68 65 64 20 77 61 69 74 6f 6e 73 29 0a er hed waitons).
aef0: 09 09 20 20 20 20 28 62 65 67 69 6e 0a 09 09 20 .. (begin...
af00: 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e (debug:prin
af10: 74 20 30 20 22 45 52 52 4f 52 3a 20 74 65 73 74 t 0 "ERROR: test
af20: 20 22 20 68 65 64 20 22 20 68 61 73 20 6c 69 73 " hed " has lis
af30: 74 65 64 20 69 74 73 65 6c 66 20 61 73 20 61 20 ted itself as a
af40: 77 61 69 74 6f 6e 2c 20 70 6c 65 61 73 65 20 63 waiton, please c
af50: 6f 72 72 65 63 74 20 74 68 69 73 21 22 29 0a 09 orrect this!")..
af60: 09 20 20 20 20 20 20 28 73 65 74 21 20 77 61 69 . (set! wai
af70: 74 6f 6e 73 20 28 66 69 6c 74 65 72 20 28 6c 61 tons (filter (la
af80: 6d 62 64 61 20 28 78 29 28 6e 6f 74 20 28 65 71 mbda (x)(not (eq
af90: 75 61 6c 3f 20 78 20 68 65 64 29 29 29 20 77 61 ual? x hed))) wa
afa0: 69 74 6f 6e 73 29 29 29 29 0a 09 09 0a 09 09 3b itons))))......;
afb0: 3b 20 28 69 74 65 6d 73 20 20 20 28 69 74 65 6d ; (items (item
afc0: 73 3a 67 65 74 2d 69 74 65 6d 73 2d 66 72 6f 6d s:get-items-from
afd0: 2d 63 6f 6e 66 69 67 20 63 6f 6e 66 69 67 29 29 -config config))
afe0: 29 0a 09 09 28 69 66 20 28 6e 6f 74 20 28 68 61 )...(if (not (ha
aff0: 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 sh-table-ref/def
b000: 61 75 6c 74 20 74 65 73 74 2d 72 65 63 6f 72 64 ault test-record
b010: 73 20 68 65 64 20 23 66 29 29 0a 09 09 20 20 20 s hed #f))...
b020: 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 (hash-table-set
b030: 21 20 74 65 73 74 2d 72 65 63 6f 72 64 73 0a 09 ! test-records..
b040: 09 09 09 20 20 20 20 20 68 65 64 20 28 76 65 63 ... hed (vec
b050: 74 6f 72 20 68 65 64 20 20 20 20 20 3b 3b 20 30 tor hed ;; 0
b060: 0a 09 09 09 09 09 09 20 63 6f 6e 66 69 67 20 20 ....... config
b070: 3b 3b 20 31 0a 09 09 09 09 09 09 20 77 61 69 74 ;; 1....... wait
b080: 6f 6e 73 20 3b 3b 20 32 0a 09 09 09 09 09 09 20 ons ;; 2.......
b090: 28 63 6f 6e 66 69 67 2d 6c 6f 6f 6b 75 70 20 63 (config-lookup c
b0a0: 6f 6e 66 69 67 20 22 72 65 71 75 69 72 65 6d 65 onfig "requireme
b0b0: 6e 74 73 22 20 22 70 72 69 6f 72 69 74 79 22 29 nts" "priority")
b0c0: 20 20 20 20 20 3b 3b 20 70 72 69 6f 72 69 74 79 ;; priority
b0d0: 20 33 0a 09 09 09 09 09 09 20 28 6c 65 74 20 28 3....... (let (
b0e0: 28 69 74 65 6d 73 20 20 20 20 20 20 28 68 61 73 (items (has
b0f0: 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 h-table-ref/defa
b100: 75 6c 74 20 63 6f 6e 66 69 67 20 22 69 74 65 6d ult config "item
b110: 73 22 20 23 66 29 29 20 3b 3b 20 69 74 65 6d 73 s" #f)) ;; items
b120: 20 34 0a 09 09 09 09 09 09 20 20 20 20 20 20 20 4.......
b130: 28 69 74 65 6d 73 74 61 62 6c 65 20 28 68 61 73 (itemstable (has
b140: 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 h-table-ref/defa
b150: 75 6c 74 20 63 6f 6e 66 69 67 20 22 69 74 65 6d ult config "item
b160: 73 74 61 62 6c 65 22 20 23 66 29 29 29 20 0a 09 stable" #f))) ..
b170: 09 09 09 09 09 20 20 20 3b 3b 20 69 66 20 65 69 ..... ;; if ei
b180: 74 68 65 72 20 69 74 65 6d 73 20 6f 72 20 69 74 ther items or it
b190: 65 6d 73 20 74 61 62 6c 65 20 69 73 20 61 20 70 ems table is a p
b1a0: 72 6f 63 20 72 65 74 75 72 6e 20 69 74 20 73 6f roc return it so
b1b0: 20 74 65 73 74 20 72 75 6e 6e 69 6e 67 0a 09 09 test running...
b1c0: 09 09 09 09 20 20 20 3b 3b 20 70 72 6f 63 65 73 .... ;; proces
b1d0: 73 20 63 61 6e 20 6b 6e 6f 77 20 74 6f 20 63 61 s can know to ca
b1e0: 6c 6c 20 69 74 65 6d 73 3a 67 65 74 2d 69 74 65 ll items:get-ite
b1f0: 6d 73 2d 66 72 6f 6d 2d 63 6f 6e 66 69 67 0a 09 ms-from-config..
b200: 09 09 09 09 09 20 20 20 3b 3b 20 69 66 20 65 69 ..... ;; if ei
b210: 74 68 65 72 20 69 73 20 61 20 6c 69 73 74 20 61 ther is a list a
b220: 6e 64 20 6e 6f 6e 65 20 69 73 20 61 20 70 72 6f nd none is a pro
b230: 63 20 67 6f 20 61 68 65 61 64 20 61 6e 64 20 63 c go ahead and c
b240: 61 6c 6c 20 67 65 74 2d 69 74 65 6d 73 0a 09 09 all get-items...
b250: 09 09 09 09 20 20 20 3b 3b 20 6f 74 68 65 72 77 .... ;; otherw
b260: 69 73 65 20 72 65 74 75 72 6e 20 23 66 20 2d 20 ise return #f -
b270: 74 68 69 73 20 69 73 20 6e 6f 74 20 61 6e 20 69 this is not an i
b280: 74 65 72 61 74 65 64 20 74 65 73 74 0a 09 09 09 terated test....
b290: 09 09 09 20 20 20 28 63 6f 6e 64 0a 09 09 09 09 ... (cond.....
b2a0: 09 09 20 20 20 20 28 28 70 72 6f 63 65 64 75 72 .. ((procedur
b2b0: 65 3f 20 69 74 65 6d 73 29 20 20 20 20 20 20 0a e? items) .
b2c0: 09 09 09 09 09 09 20 20 20 20 20 28 64 65 62 75 ...... (debu
b2d0: 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 34 20 22 g:print-info 4 "
b2e0: 69 74 65 6d 73 20 69 73 20 61 20 70 72 6f 63 65 items is a proce
b2f0: 64 75 72 65 2c 20 77 69 6c 6c 20 63 61 6c 63 20 dure, will calc
b300: 6c 61 74 65 72 22 29 0a 09 09 09 09 09 09 20 20 later").......
b310: 20 20 20 69 74 65 6d 73 29 20 20 20 20 20 20 20 items)
b320: 20 20 20 20 20 3b 3b 20 63 61 6c 63 20 6c 61 74 ;; calc lat
b330: 65 72 0a 09 09 09 09 09 09 20 20 20 20 28 28 70 er....... ((p
b340: 72 6f 63 65 64 75 72 65 3f 20 69 74 65 6d 73 74 rocedure? itemst
b350: 61 62 6c 65 29 0a 09 09 09 09 09 09 20 20 20 20 able).......
b360: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e (debug:print-in
b370: 66 6f 20 34 20 22 69 74 65 6d 73 74 61 62 6c 65 fo 4 "itemstable
b380: 20 69 73 20 61 20 70 72 6f 63 65 64 75 72 65 2c is a procedure,
b390: 20 77 69 6c 6c 20 63 61 6c 63 20 6c 61 74 65 72 will calc later
b3a0: 22 29 0a 09 09 09 09 09 09 20 20 20 20 20 69 74 ")....... it
b3b0: 65 6d 73 74 61 62 6c 65 29 20 20 20 20 20 20 20 emstable)
b3c0: 3b 3b 20 63 61 6c 63 20 6c 61 74 65 72 0a 09 09 ;; calc later...
b3d0: 09 09 09 09 20 20 20 20 28 28 66 69 6c 74 65 72 .... ((filter
b3e0: 20 28 6c 61 6d 62 64 61 20 28 78 29 0a 09 09 09 (lambda (x)....
b3f0: 09 09 09 09 20 20 20 20 20 20 20 28 6c 65 74 20 .... (let
b400: 28 28 76 61 6c 20 28 63 61 72 20 78 29 29 29 0a ((val (car x))).
b410: 09 09 09 09 09 09 09 09 20 28 69 66 20 28 70 72 ........ (if (pr
b420: 6f 63 65 64 75 72 65 3f 20 76 61 6c 29 20 76 61 ocedure? val) va
b430: 6c 20 23 66 29 29 29 0a 09 09 09 09 09 09 09 20 l #f)))........
b440: 20 20 20 20 28 61 70 70 65 6e 64 20 28 69 66 20 (append (if
b450: 28 6c 69 73 74 3f 20 69 74 65 6d 73 29 20 69 74 (list? items) it
b460: 65 6d 73 20 27 28 29 29 0a 09 09 09 09 09 09 09 ems '())........
b470: 09 20 20 20 20 20 28 69 66 20 28 6c 69 73 74 3f . (if (list?
b480: 20 69 74 65 6d 73 74 61 62 6c 65 29 20 69 74 65 itemstable) ite
b490: 6d 73 74 61 62 6c 65 20 27 28 29 29 29 29 0a 09 mstable '())))..
b4a0: 09 09 09 09 09 20 20 20 20 20 27 68 61 76 65 2d ..... 'have-
b4b0: 70 72 6f 63 65 64 75 72 65 29 0a 09 09 09 09 09 procedure)......
b4c0: 09 20 20 20 20 28 28 6f 72 20 28 6c 69 73 74 3f . ((or (list?
b4d0: 20 69 74 65 6d 73 29 28 6c 69 73 74 3f 20 69 74 items)(list? it
b4e0: 65 6d 73 74 61 62 6c 65 29 29 20 3b 3b 20 63 61 emstable)) ;; ca
b4f0: 6c 63 20 6e 6f 77 0a 09 09 09 09 09 09 20 20 20 lc now.......
b500: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 (debug:print-i
b510: 6e 66 6f 20 34 20 22 69 74 65 6d 73 20 61 6e 64 nfo 4 "items and
b520: 20 69 74 65 6d 73 74 61 62 6c 65 20 61 72 65 20 itemstable are
b530: 6c 69 73 74 73 2c 20 63 61 6c 63 20 6e 6f 77 5c lists, calc now\
b540: 6e 22 0a 09 09 09 09 09 09 09 09 20 20 20 20 20 n".........
b550: 20 20 22 20 20 20 20 69 74 65 6d 73 3a 20 22 20 " items: "
b560: 69 74 65 6d 73 20 22 20 69 74 65 6d 73 74 61 62 items " itemstab
b570: 6c 65 3a 20 22 20 69 74 65 6d 73 74 61 62 6c 65 le: " itemstable
b580: 29 0a 09 09 09 09 09 09 20 20 20 20 20 28 69 74 )....... (it
b590: 65 6d 73 3a 67 65 74 2d 69 74 65 6d 73 2d 66 72 ems:get-items-fr
b5a0: 6f 6d 2d 63 6f 6e 66 69 67 20 63 6f 6e 66 69 67 om-config config
b5b0: 29 29 0a 09 09 09 09 09 09 20 20 20 20 28 65 6c ))....... (el
b5c0: 73 65 20 23 66 29 29 29 20 20 20 20 20 20 20 20 se #f)))
b5d0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
b5e0: 20 20 20 3b 3b 20 6e 6f 74 20 69 74 65 72 61 74 ;; not iterat
b5f0: 65 64 0a 09 09 09 09 09 09 20 23 66 20 20 20 20 ed....... #f
b600: 20 20 3b 3b 20 69 74 65 6d 73 64 61 74 20 35 0a ;; itemsdat 5.
b610: 09 09 09 09 09 09 20 23 66 20 20 20 20 20 20 3b ...... #f ;
b620: 3b 20 73 70 61 72 65 20 2d 20 75 73 65 64 20 66 ; spare - used f
b630: 6f 72 20 69 74 65 6d 2d 70 61 74 68 0a 09 09 09 or item-path....
b640: 09 09 09 20 29 29 29 0a 09 09 28 66 6f 72 2d 65 ... )))...(for-e
b650: 61 63 68 20 0a 09 09 20 28 6c 61 6d 62 64 61 20 ach ... (lambda
b660: 28 77 61 69 74 6f 6e 29 0a 09 09 20 20 20 28 69 (waiton)... (i
b670: 66 20 28 61 6e 64 20 77 61 69 74 6f 6e 20 28 6e f (and waiton (n
b680: 6f 74 20 28 6d 65 6d 62 65 72 20 77 61 69 74 6f ot (member waito
b690: 6e 20 74 65 73 74 2d 6e 61 6d 65 73 29 29 29 0a n test-names))).
b6a0: 09 09 20 20 20 20 20 20 20 28 62 65 67 69 6e 0a .. (begin.
b6b0: 09 09 09 20 28 73 65 74 21 20 72 65 71 75 69 72 ... (set! requir
b6c0: 65 64 2d 74 65 73 74 73 20 28 63 6f 6e 73 20 77 ed-tests (cons w
b6d0: 61 69 74 6f 6e 20 72 65 71 75 69 72 65 64 2d 74 aiton required-t
b6e0: 65 73 74 73 29 29 0a 09 09 09 20 28 73 65 74 21 ests)).... (set!
b6f0: 20 74 65 73 74 2d 6e 61 6d 65 73 20 28 63 6f 6e test-names (con
b700: 73 20 77 61 69 74 6f 6e 20 74 65 73 74 2d 6e 61 s waiton test-na
b710: 6d 65 73 29 29 29 29 29 20 3b 3b 20 77 61 73 20 mes))))) ;; was
b720: 61 6e 20 61 70 70 65 6e 64 2c 20 6e 6f 77 20 61 an append, now a
b730: 20 63 6f 6e 73 0a 09 09 20 77 61 69 74 6f 6e 73 cons... waitons
b740: 29 0a 09 09 28 6c 65 74 20 28 28 72 65 6d 74 65 )...(let ((remte
b750: 73 74 73 20 28 64 65 6c 65 74 65 2d 64 75 70 6c sts (delete-dupl
b760: 69 63 61 74 65 73 20 28 61 70 70 65 6e 64 20 77 icates (append w
b770: 61 69 74 6f 6e 73 20 74 61 6c 29 29 29 29 0a 09 aitons tal))))..
b780: 09 20 20 28 69 66 20 28 6e 6f 74 20 28 6e 75 6c . (if (not (nul
b790: 6c 3f 20 72 65 6d 74 65 73 74 73 29 29 0a 09 09 l? remtests))...
b7a0: 20 20 20 20 20 20 28 6c 6f 6f 70 20 28 63 61 72 (loop (car
b7b0: 20 72 65 6d 74 65 73 74 73 29 28 63 64 72 20 72 remtests)(cdr r
b7c0: 65 6d 74 65 73 74 73 29 29 0a 09 09 20 20 20 20 emtests))...
b7d0: 20 20 74 65 73 74 2d 72 65 63 6f 72 64 73 29 29 test-records))
b7e0: 29 29 29 29 29 29 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d ))))))..;;======
b7f0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
b800: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
b810: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
b820: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
b830: 0a 3b 3b 20 74 65 73 74 20 73 74 65 70 73 0a 3b .;; test steps.;
b840: 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;===============
b850: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
b860: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
b870: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
b880: 3d 3d 3d 3d 3d 3d 3d 0a 0a 3b 3b 20 74 65 73 74 =======..;; test
b890: 73 74 65 70 2d 73 65 74 2d 73 74 61 74 75 73 21 step-set-status!
b8a0: 20 75 73 65 64 20 74 6f 20 62 65 20 68 65 72 65 used to be here
b8b0: 0a 0a 28 64 65 66 69 6e 65 20 28 74 65 73 74 2d ..(define (test-
b8c0: 67 65 74 2d 6b 69 6c 6c 2d 72 65 71 75 65 73 74 get-kill-request
b8d0: 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 69 64 29 run-id test-id)
b8e0: 20 3b 3b 20 72 75 6e 2d 69 64 20 74 65 73 74 2d ;; run-id test-
b8f0: 6e 61 6d 65 20 69 74 65 6d 64 61 74 29 0a 20 20 name itemdat).
b900: 28 6c 65 74 2a 20 28 28 74 65 73 74 64 61 74 20 (let* ((testdat
b910: 20 20 28 72 6d 74 3a 67 65 74 2d 74 65 73 74 2d (rmt:get-test-
b920: 69 6e 66 6f 2d 62 79 2d 69 64 20 72 75 6e 2d 69 info-by-id run-i
b930: 64 20 74 65 73 74 2d 69 64 29 29 29 0a 20 20 20 d test-id))).
b940: 20 28 61 6e 64 20 74 65 73 74 64 61 74 0a 09 20 (and testdat..
b950: 28 65 71 75 61 6c 3f 20 28 74 65 73 74 3a 67 65 (equal? (test:ge
b960: 74 2d 73 74 61 74 65 20 74 65 73 74 64 61 74 29 t-state testdat)
b970: 20 22 4b 49 4c 4c 52 45 51 22 29 29 29 29 0a 0a "KILLREQ"))))..
b980: 28 64 65 66 69 6e 65 20 28 74 65 73 74 3a 74 64 (define (test:td
b990: 62 2d 67 65 74 2d 72 75 6e 64 61 74 2d 63 6f 75 b-get-rundat-cou
b9a0: 6e 74 20 74 64 62 29 0a 20 20 28 69 66 20 74 64 nt tdb). (if td
b9b0: 62 0a 20 20 20 20 20 20 28 6c 65 74 20 28 28 72 b. (let ((r
b9c0: 65 73 20 30 29 29 0a 09 28 73 71 6c 69 74 65 33 es 0))..(sqlite3
b9d0: 3a 66 6f 72 2d 65 61 63 68 2d 72 6f 77 0a 09 20 :for-each-row..
b9e0: 28 6c 61 6d 62 64 61 20 28 63 6f 75 6e 74 29 0a (lambda (count).
b9f0: 09 20 20 20 28 73 65 74 21 20 72 65 73 20 63 6f . (set! res co
ba00: 75 6e 74 29 29 0a 09 20 74 64 62 0a 09 20 22 53 unt)).. tdb.. "S
ba10: 45 4c 45 43 54 20 63 6f 75 6e 74 28 69 64 29 20 ELECT count(id)
ba20: 46 52 4f 4d 20 74 65 73 74 5f 72 75 6e 64 61 74 FROM test_rundat
ba30: 3b 22 29 0a 09 72 65 73 29 29 0a 20 20 30 29 0a ;")..res)). 0).
ba40: 0a 28 64 65 66 69 6e 65 20 28 74 65 73 74 73 3a .(define (tests:
ba50: 75 70 64 61 74 65 2d 63 65 6e 74 72 61 6c 2d 6d update-central-m
ba60: 65 74 61 2d 69 6e 66 6f 20 72 75 6e 2d 69 64 20 eta-info run-id
ba70: 74 65 73 74 2d 69 64 20 63 70 75 6c 6f 61 64 20 test-id cpuload
ba80: 64 69 73 6b 66 72 65 65 20 6d 69 6e 75 74 65 73 diskfree minutes
ba90: 20 75 6e 61 6d 65 20 68 6f 73 74 6e 61 6d 65 29 uname hostname)
baa0: 0a 20 20 28 69 66 20 28 61 6e 64 20 63 70 75 6c . (if (and cpul
bab0: 6f 61 64 20 64 69 73 6b 66 72 65 65 29 0a 20 20 oad diskfree).
bac0: 20 20 20 20 28 72 6d 74 3a 67 65 6e 65 72 61 6c (rmt:general
bad0: 2d 63 61 6c 6c 20 27 75 70 64 61 74 65 2d 63 70 -call 'update-cp
bae0: 75 6c 6f 61 64 2d 64 69 73 6b 66 72 65 65 20 72 uload-diskfree r
baf0: 75 6e 2d 69 64 20 63 70 75 6c 6f 61 64 20 64 69 un-id cpuload di
bb00: 73 6b 66 72 65 65 20 74 65 73 74 2d 69 64 29 29 skfree test-id))
bb10: 0a 20 20 28 69 66 20 6d 69 6e 75 74 65 73 20 0a . (if minutes .
bb20: 20 20 20 20 20 20 28 72 6d 74 3a 67 65 6e 65 72 (rmt:gener
bb30: 61 6c 2d 63 61 6c 6c 20 27 75 70 64 61 74 65 2d al-call 'update-
bb40: 72 75 6e 2d 64 75 72 61 74 69 6f 6e 20 72 75 6e run-duration run
bb50: 2d 69 64 20 6d 69 6e 75 74 65 73 20 74 65 73 74 -id minutes test
bb60: 2d 69 64 29 29 0a 20 20 28 69 66 20 28 61 6e 64 -id)). (if (and
bb70: 20 75 6e 61 6d 65 20 68 6f 73 74 6e 61 6d 65 29 uname hostname)
bb80: 0a 20 20 20 20 20 20 28 72 6d 74 3a 67 65 6e 65 . (rmt:gene
bb90: 72 61 6c 2d 63 61 6c 6c 20 27 75 70 64 61 74 65 ral-call 'update
bba0: 2d 75 6e 61 6d 65 2d 68 6f 73 74 20 72 75 6e 2d -uname-host run-
bbb0: 69 64 20 75 6e 61 6d 65 20 68 6f 73 74 6e 61 6d id uname hostnam
bbc0: 65 20 74 65 73 74 2d 69 64 29 29 29 0a 20 20 0a e test-id))). .
bbd0: 3b 3b 20 54 68 69 73 20 6f 6e 65 20 69 73 20 66 ;; This one is f
bbe0: 6f 72 20 72 75 6e 6e 69 6e 67 20 77 69 74 68 20 or running with
bbf0: 6e 6f 20 64 62 20 61 63 63 65 73 73 20 28 69 2e no db access (i.
bc00: 65 2e 20 76 69 61 20 72 6d 74 3a 20 69 6e 74 65 e. via rmt: inte
bc10: 72 6e 61 6c 6c 79 29 0a 28 64 65 66 69 6e 65 20 rnally).(define
bc20: 28 74 65 73 74 73 3a 73 65 74 2d 66 75 6c 6c 2d (tests:set-full-
bc30: 6d 65 74 61 2d 69 6e 66 6f 20 64 62 20 74 65 73 meta-info db tes
bc40: 74 2d 69 64 20 72 75 6e 2d 69 64 20 6d 69 6e 75 t-id run-id minu
bc50: 74 65 73 20 77 6f 72 6b 2d 61 72 65 61 20 72 65 tes work-area re
bc60: 6d 74 72 69 65 73 29 0a 3b 3b 20 28 64 65 66 69 mtries).;; (defi
bc70: 6e 65 20 28 74 65 73 74 73 3a 73 65 74 2d 66 75 ne (tests:set-fu
bc80: 6c 6c 2d 6d 65 74 61 2d 69 6e 66 6f 20 74 65 73 ll-meta-info tes
bc90: 74 2d 69 64 20 72 75 6e 2d 69 64 20 6d 69 6e 75 t-id run-id minu
bca0: 74 65 73 20 77 6f 72 6b 2d 61 72 65 61 29 0a 3b tes work-area).;
bcb0: 3b 20 20 28 6c 65 74 20 28 28 72 65 6d 74 72 69 ; (let ((remtri
bcc0: 65 73 20 31 30 29 29 0a 20 20 28 6c 65 74 2a 20 es 10)). (let*
bcd0: 28 28 63 70 75 6c 6f 61 64 20 20 28 67 65 74 2d ((cpuload (get-
bce0: 63 70 75 2d 6c 6f 61 64 29 29 0a 09 20 28 64 69 cpu-load)).. (di
bcf0: 73 6b 66 72 65 65 20 28 67 65 74 2d 64 66 20 28 skfree (get-df (
bd00: 63 75 72 72 65 6e 74 2d 64 69 72 65 63 74 6f 72 current-director
bd10: 79 29 29 29 0a 09 20 28 75 6e 61 6d 65 20 20 20 y))).. (uname
bd20: 20 28 67 65 74 2d 75 6e 61 6d 65 20 22 2d 73 72 (get-uname "-sr
bd30: 76 70 69 6f 22 29 29 0a 09 20 28 68 6f 73 74 6e vpio")).. (hostn
bd40: 61 6d 65 20 28 67 65 74 2d 68 6f 73 74 2d 6e 61 ame (get-host-na
bd50: 6d 65 29 29 29 0a 20 20 20 20 28 74 65 73 74 73 me))). (tests
bd60: 3a 75 70 64 61 74 65 2d 63 65 6e 74 72 61 6c 2d :update-central-
bd70: 6d 65 74 61 2d 69 6e 66 6f 20 72 75 6e 2d 69 64 meta-info run-id
bd80: 20 74 65 73 74 2d 69 64 20 63 70 75 6c 6f 61 64 test-id cpuload
bd90: 20 64 69 73 6b 66 72 65 65 20 6d 69 6e 75 74 65 diskfree minute
bda0: 73 20 75 6e 61 6d 65 20 68 6f 73 74 6e 61 6d 65 s uname hostname
bdb0: 29 29 29 0a 20 20 20 20 0a 3b 3b 20 28 64 65 66 ))). .;; (def
bdc0: 69 6e 65 20 28 74 65 73 74 73 3a 73 65 74 2d 70 ine (tests:set-p
bdd0: 61 72 74 69 61 6c 2d 6d 65 74 61 2d 69 6e 66 6f artial-meta-info
bde0: 20 74 65 73 74 2d 69 64 20 72 75 6e 2d 69 64 20 test-id run-id
bdf0: 6d 69 6e 75 74 65 73 20 77 6f 72 6b 2d 61 72 65 minutes work-are
be00: 61 29 0a 28 64 65 66 69 6e 65 20 28 74 65 73 74 a).(define (test
be10: 73 3a 73 65 74 2d 70 61 72 74 69 61 6c 2d 6d 65 s:set-partial-me
be20: 74 61 2d 69 6e 66 6f 20 74 65 73 74 2d 69 64 20 ta-info test-id
be30: 72 75 6e 2d 69 64 20 6d 69 6e 75 74 65 73 20 77 run-id minutes w
be40: 6f 72 6b 2d 61 72 65 61 20 72 65 6d 74 72 69 65 ork-area remtrie
be50: 73 29 0a 20 20 28 6c 65 74 2a 20 28 28 63 70 75 s). (let* ((cpu
be60: 6c 6f 61 64 20 20 28 67 65 74 2d 63 70 75 2d 6c load (get-cpu-l
be70: 6f 61 64 29 29 0a 09 20 28 64 69 73 6b 66 72 65 oad)).. (diskfre
be80: 65 20 28 67 65 74 2d 64 66 20 28 63 75 72 72 65 e (get-df (curre
be90: 6e 74 2d 64 69 72 65 63 74 6f 72 79 29 29 29 0a nt-directory))).
bea0: 09 20 28 72 65 6d 74 72 69 65 73 20 31 30 29 29 . (remtries 10))
beb0: 0a 20 20 20 20 28 68 61 6e 64 6c 65 2d 65 78 63 . (handle-exc
bec0: 65 70 74 69 6f 6e 73 0a 20 20 20 20 20 65 78 6e eptions. exn
bed0: 0a 20 20 20 20 20 28 69 66 20 28 3e 20 72 65 6d . (if (> rem
bee0: 74 72 69 65 73 20 30 29 0a 09 20 28 62 65 67 69 tries 0).. (begi
bef0: 6e 0a 09 20 20 20 28 70 72 69 6e 74 2d 63 61 6c n.. (print-cal
bf00: 6c 2d 63 68 61 69 6e 20 28 63 75 72 72 65 6e 74 l-chain (current
bf10: 2d 65 72 72 6f 72 2d 70 6f 72 74 29 29 0a 09 20 -error-port))..
bf20: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 (debug:print-i
bf30: 6e 66 6f 20 30 20 22 57 41 52 4e 49 4e 47 3a 20 nfo 0 "WARNING:
bf40: 66 61 69 6c 65 64 20 74 6f 20 73 65 74 20 6d 65 failed to set me
bf50: 74 61 20 69 6e 66 6f 2e 20 57 69 6c 6c 20 74 72 ta info. Will tr
bf60: 79 20 22 20 72 65 6d 74 72 69 65 73 20 22 20 6d y " remtries " m
bf70: 6f 72 65 20 74 69 6d 65 73 22 29 0a 09 20 20 20 ore times")..
bf80: 28 73 65 74 21 20 72 65 6d 74 72 69 65 73 20 28 (set! remtries (
bf90: 2d 20 72 65 6d 74 72 69 65 73 20 31 29 29 0a 09 - remtries 1))..
bfa0: 20 20 20 28 74 68 72 65 61 64 2d 73 6c 65 65 70 (thread-sleep
bfb0: 21 20 31 30 29 0a 09 20 20 20 28 74 65 73 74 73 ! 10).. (tests
bfc0: 3a 73 65 74 2d 66 75 6c 6c 2d 6d 65 74 61 2d 69 :set-full-meta-i
bfd0: 6e 66 6f 20 64 62 20 74 65 73 74 2d 69 64 20 72 nfo db test-id r
bfe0: 75 6e 2d 69 64 20 6d 69 6e 75 74 65 73 20 77 6f un-id minutes wo
bff0: 72 6b 2d 61 72 65 61 20 28 2d 20 72 65 6d 74 72 rk-area (- remtr
c000: 69 65 73 20 31 29 29 29 0a 09 20 28 6c 65 74 20 ies 1))).. (let
c010: 28 28 65 72 72 2d 73 74 61 74 75 73 20 28 28 63 ((err-status ((c
c020: 6f 6e 64 69 74 69 6f 6e 2d 70 72 6f 70 65 72 74 ondition-propert
c030: 79 2d 61 63 63 65 73 73 6f 72 20 27 73 71 6c 69 y-accessor 'sqli
c040: 74 65 33 20 27 73 74 61 74 75 73 20 23 66 29 20 te3 'status #f)
c050: 65 78 6e 29 29 29 0a 09 20 20 20 28 64 65 62 75 exn))).. (debu
c060: 67 3a 70 72 69 6e 74 20 30 20 22 45 52 52 4f 52 g:print 0 "ERROR
c070: 3a 20 74 72 69 65 64 20 66 6f 72 20 6f 76 65 72 : tried for over
c080: 20 61 20 6d 69 6e 75 74 65 20 74 6f 20 75 70 64 a minute to upd
c090: 61 74 65 20 6d 65 74 61 20 69 6e 66 6f 20 61 6e ate meta info an
c0a0: 64 20 66 61 69 6c 65 64 2e 20 47 69 76 69 6e 67 d failed. Giving
c0b0: 20 75 70 22 29 0a 09 20 20 20 28 64 65 62 75 67 up").. (debug
c0c0: 3a 70 72 69 6e 74 20 30 20 22 45 58 43 45 50 54 :print 0 "EXCEPT
c0d0: 49 4f 4e 3a 20 64 61 74 61 62 61 73 65 20 70 72 ION: database pr
c0e0: 6f 62 61 62 6c 79 20 6f 76 65 72 6c 6f 61 64 65 obably overloade
c0f0: 64 20 6f 72 20 75 6e 72 65 61 64 61 62 6c 65 2e d or unreadable.
c100: 22 29 0a 09 20 20 20 28 64 65 62 75 67 3a 70 72 ").. (debug:pr
c110: 69 6e 74 20 30 20 22 20 6d 65 73 73 61 67 65 3a int 0 " message:
c120: 20 22 20 28 28 63 6f 6e 64 69 74 69 6f 6e 2d 70 " ((condition-p
c130: 72 6f 70 65 72 74 79 2d 61 63 63 65 73 73 6f 72 roperty-accessor
c140: 20 27 65 78 6e 20 27 6d 65 73 73 61 67 65 29 20 'exn 'message)
c150: 65 78 6e 29 29 0a 09 20 20 20 28 70 72 69 6e 74 exn)).. (print
c160: 20 22 65 78 6e 3d 22 20 28 63 6f 6e 64 69 74 69 "exn=" (conditi
c170: 6f 6e 2d 3e 6c 69 73 74 20 65 78 6e 29 29 0a 09 on->list exn))..
c180: 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 (debug:print
c190: 30 20 22 20 73 74 61 74 75 73 3a 20 20 22 20 28 0 " status: " (
c1a0: 28 63 6f 6e 64 69 74 69 6f 6e 2d 70 72 6f 70 65 (condition-prope
c1b0: 72 74 79 2d 61 63 63 65 73 73 6f 72 20 27 73 71 rty-accessor 'sq
c1c0: 6c 69 74 65 33 20 27 73 74 61 74 75 73 29 20 65 lite3 'status) e
c1d0: 78 6e 29 29 0a 09 20 20 20 28 70 72 69 6e 74 2d xn)).. (print-
c1e0: 63 61 6c 6c 2d 63 68 61 69 6e 20 28 63 75 72 72 call-chain (curr
c1f0: 65 6e 74 2d 65 72 72 6f 72 2d 70 6f 72 74 29 29 ent-error-port))
c200: 29 29 0a 20 20 20 20 20 28 74 65 73 74 73 3a 75 )). (tests:u
c210: 70 64 61 74 65 2d 74 65 73 74 64 61 74 2d 6d 65 pdate-testdat-me
c220: 74 61 2d 69 6e 66 6f 20 64 62 20 74 65 73 74 2d ta-info db test-
c230: 69 64 20 77 6f 72 6b 2d 61 72 65 61 20 63 70 75 id work-area cpu
c240: 6c 6f 61 64 20 64 69 73 6b 66 72 65 65 20 6d 69 load diskfree mi
c250: 6e 75 74 65 73 29 0a 20 20 29 29 29 0a 09 20 0a nutes). ))).. .
c260: 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;;==============
c270: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
c280: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
c290: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
c2a0: 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 41 20 52 20 ========.;; A R
c2b0: 43 20 48 20 49 20 56 20 49 20 4e 20 47 0a 3b 3b C H I V I N G.;;
c2c0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
c2d0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
c2e0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
c2f0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
c300: 3d 3d 3d 3d 3d 3d 0a 0a 28 64 65 66 69 6e 65 20 ======..(define
c310: 28 74 65 73 74 3a 61 72 63 68 69 76 65 20 64 62 (test:archive db
c320: 20 74 65 73 74 2d 69 64 29 0a 20 20 23 66 29 0a test-id). #f).
c330: 0a 28 64 65 66 69 6e 65 20 28 74 65 73 74 3a 61 .(define (test:a
c340: 72 63 68 69 76 65 2d 74 65 73 74 73 20 64 62 20 rchive-tests db
c350: 6b 65 79 6e 61 6d 65 73 20 74 61 72 67 65 74 29 keynames target)
c360: 0a 20 20 23 66 29 0a 0a . #f)..