Artifact
e1a4eceb51eaee400a51f2b80b33f8f21e640aea:
0000: 3b 3b 20 43 6f 70 79 72 69 67 68 74 20 32 30 30 ;; Copyright 200
0010: 36 2d 32 30 31 33 2c 20 4d 61 74 74 68 65 77 20 6-2013, Matthew
0020: 57 65 6c 6c 61 6e 64 2e 0a 3b 3b 20 0a 3b 3b 20 Welland..;; .;;
0030: 20 54 68 69 73 20 70 72 6f 67 72 61 6d 20 69 73 This program is
0040: 20 6d 61 64 65 20 61 76 61 69 6c 61 62 6c 65 20 made available
0050: 75 6e 64 65 72 20 74 68 65 20 47 4e 55 20 47 50 under the GNU GP
0060: 4c 20 76 65 72 73 69 6f 6e 20 32 2e 30 20 6f 72 L version 2.0 or
0070: 0a 3b 3b 20 20 67 72 65 61 74 65 72 2e 20 53 65 .;; greater. Se
0080: 65 20 74 68 65 20 61 63 63 6f 6d 70 61 6e 79 69 e the accompanyi
0090: 6e 67 20 66 69 6c 65 20 43 4f 50 59 49 4e 47 20 ng file COPYING
00a0: 66 6f 72 20 64 65 74 61 69 6c 73 2e 0a 3b 3b 20 for details..;;
00b0: 0a 3b 3b 20 20 54 68 69 73 20 70 72 6f 67 72 61 .;; This progra
00c0: 6d 20 69 73 20 64 69 73 74 72 69 62 75 74 65 64 m is distributed
00d0: 20 57 49 54 48 4f 55 54 20 41 4e 59 20 57 41 52 WITHOUT ANY WAR
00e0: 52 41 4e 54 59 3b 20 77 69 74 68 6f 75 74 20 65 RANTY; without e
00f0: 76 65 6e 20 74 68 65 0a 3b 3b 20 20 69 6d 70 6c ven the.;; impl
0100: 69 65 64 20 77 61 72 72 61 6e 74 79 20 6f 66 20 ied warranty of
0110: 4d 45 52 43 48 41 4e 54 41 42 49 4c 49 54 59 20 MERCHANTABILITY
0120: 6f 72 20 46 49 54 4e 45 53 53 20 46 4f 52 20 41 or FITNESS FOR A
0130: 20 50 41 52 54 49 43 55 4c 41 52 0a 3b 3b 20 20 PARTICULAR.;;
0140: 50 55 52 50 4f 53 45 2e 0a 0a 0a 28 75 73 65 20 PURPOSE....(use
0150: 73 71 6c 69 74 65 33 20 73 72 66 69 2d 31 20 70 sqlite3 srfi-1 p
0160: 6f 73 69 78 20 72 65 67 65 78 20 72 65 67 65 78 osix regex regex
0170: 2d 63 61 73 65 20 73 72 66 69 2d 36 39 20 64 6f -case srfi-69 do
0180: 74 2d 6c 6f 63 6b 69 6e 67 20 28 73 72 66 69 20 t-locking (srfi
0190: 31 38 29 20 70 6f 73 69 78 2d 65 78 74 72 61 73 18) posix-extras
01a0: 20 64 69 72 65 63 74 6f 72 79 2d 75 74 69 6c 73 directory-utils
01b0: 29 0a 28 69 6d 70 6f 72 74 20 28 70 72 65 66 69 ).(import (prefi
01c0: 78 20 73 71 6c 69 74 65 33 20 73 71 6c 69 74 65 x sqlite3 sqlite
01d0: 33 3a 29 29 0a 0a 28 64 65 63 6c 61 72 65 20 28 3:))..(declare (
01e0: 75 6e 69 74 20 6d 74 29 29 0a 28 64 65 63 6c 61 unit mt)).(decla
01f0: 72 65 20 28 75 73 65 73 20 64 62 29 29 0a 28 64 re (uses db)).(d
0200: 65 63 6c 61 72 65 20 28 75 73 65 73 20 63 6f 6d eclare (uses com
0210: 6d 6f 6e 29 29 0a 28 64 65 63 6c 61 72 65 20 28 mon)).(declare (
0220: 75 73 65 73 20 69 74 65 6d 73 29 29 0a 28 64 65 uses items)).(de
0230: 63 6c 61 72 65 20 28 75 73 65 73 20 72 75 6e 63 clare (uses runc
0240: 6f 6e 66 69 67 29 29 0a 28 64 65 63 6c 61 72 65 onfig)).(declare
0250: 20 28 75 73 65 73 20 74 65 73 74 73 29 29 0a 28 (uses tests)).(
0260: 64 65 63 6c 61 72 65 20 28 75 73 65 73 20 73 65 declare (uses se
0270: 72 76 65 72 29 29 0a 28 64 65 63 6c 61 72 65 20 rver)).(declare
0280: 28 75 73 65 73 20 72 75 6e 73 29 29 0a 0a 28 69 (uses runs))..(i
0290: 6e 63 6c 75 64 65 20 22 63 6f 6d 6d 6f 6e 5f 72 nclude "common_r
02a0: 65 63 6f 72 64 73 2e 73 63 6d 22 29 0a 28 69 6e ecords.scm").(in
02b0: 63 6c 75 64 65 20 22 6b 65 79 5f 72 65 63 6f 72 clude "key_recor
02c0: 64 73 2e 73 63 6d 22 29 0a 28 69 6e 63 6c 75 64 ds.scm").(includ
02d0: 65 20 22 64 62 5f 72 65 63 6f 72 64 73 2e 73 63 e "db_records.sc
02e0: 6d 22 29 0a 28 69 6e 63 6c 75 64 65 20 22 72 75 m").(include "ru
02f0: 6e 5f 72 65 63 6f 72 64 73 2e 73 63 6d 22 29 0a n_records.scm").
0300: 28 69 6e 63 6c 75 64 65 20 22 74 65 73 74 5f 72 (include "test_r
0310: 65 63 6f 72 64 73 2e 73 63 6d 22 29 0a 0a 3b 3b ecords.scm")..;;
0320: 20 54 68 69 73 20 69 73 20 74 68 65 20 4d 65 67 This is the Meg
0330: 61 74 65 73 74 20 41 50 49 2e 20 41 6c 6c 20 67 atest API. All g
0340: 65 6e 65 72 61 6c 6c 79 20 22 75 73 65 66 75 6c enerally "useful
0350: 22 20 72 6f 75 74 69 6e 65 73 20 77 69 6c 6c 20 " routines will
0360: 62 65 20 77 72 61 70 70 65 64 20 6f 72 20 65 78 be wrapped or ex
0370: 74 65 6e 64 65 64 0a 3b 3b 20 68 65 72 65 2e 0a tended.;; here..
0380: 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d .;;=============
0390: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
03a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
03b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
03c0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 20 52 20 =========.;; R
03d0: 55 20 4e 20 53 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d U N S.;;========
03e0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
03f0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0400: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0410: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a ==============..
0420: 3b 3b 20 72 75 6e 73 3a 67 65 74 2d 72 75 6e 73 ;; runs:get-runs
0430: 2d 62 79 2d 70 61 74 74 0a 3b 3b 20 67 65 74 20 -by-patt.;; get
0440: 72 75 6e 73 20 62 79 20 6c 69 73 74 20 6f 66 20 runs by list of
0450: 63 72 69 74 65 72 69 61 0a 3b 3b 20 72 65 67 69 criteria.;; regi
0460: 73 74 65 72 20 61 20 74 65 73 74 20 72 75 6e 20 ster a test run
0470: 77 69 74 68 20 74 68 65 20 64 62 0a 3b 3b 0a 3b with the db.;;.;
0480: 3b 20 55 73 65 3a 20 28 64 62 2d 67 65 74 2d 76 ; Use: (db-get-v
0490: 61 6c 75 65 2d 62 79 2d 68 65 61 64 65 72 20 28 alue-by-header (
04a0: 64 62 3a 67 65 74 2d 68 65 61 64 65 72 20 72 75 db:get-header ru
04b0: 6e 69 6e 66 6f 29 28 64 62 3a 67 65 74 2d 72 6f ninfo)(db:get-ro
04c0: 77 20 72 75 6e 69 6e 66 6f 29 29 0a 3b 3b 20 20 w runinfo)).;;
04d0: 74 6f 20 65 78 74 72 61 63 74 20 69 6e 66 6f 20 to extract info
04e0: 66 72 6f 6d 20 74 68 65 20 73 74 72 75 63 74 75 from the structu
04f0: 72 65 20 72 65 74 75 72 6e 65 64 0a 3b 3b 0a 28 re returned.;;.(
0500: 64 65 66 69 6e 65 20 28 6d 74 3a 67 65 74 2d 72 define (mt:get-r
0510: 75 6e 73 2d 62 79 2d 70 61 74 74 20 6b 65 79 73 uns-by-patt keys
0520: 20 72 75 6e 6e 61 6d 65 70 61 74 74 20 74 61 72 runnamepatt tar
0530: 67 70 61 74 74 29 0a 20 20 28 6c 65 74 20 6c 6f gpatt). (let lo
0540: 6f 70 20 28 28 72 75 6e 73 64 61 74 20 20 28 63 op ((runsdat (c
0550: 64 62 3a 72 65 6d 6f 74 65 2d 72 75 6e 20 64 62 db:remote-run db
0560: 3a 67 65 74 2d 72 75 6e 73 2d 62 79 2d 70 61 74 :get-runs-by-pat
0570: 74 20 23 66 20 6b 65 79 73 20 72 75 6e 6e 61 6d t #f keys runnam
0580: 65 70 61 74 74 20 74 61 72 67 70 61 74 74 20 30 epatt targpatt 0
0590: 20 35 30 30 29 29 0a 09 20 20 20 20 20 28 72 65 500)).. (re
05a0: 73 20 20 20 20 20 20 27 28 29 29 0a 09 20 20 20 s '())..
05b0: 20 20 28 6f 66 66 73 65 74 20 20 20 30 29 0a 09 (offset 0)..
05c0: 20 20 20 20 20 28 6c 69 6d 69 74 20 20 20 20 35 (limit 5
05d0: 30 30 29 29 0a 20 20 20 20 3b 3b 20 28 70 72 69 00)). ;; (pri
05e0: 6e 74 20 22 72 75 6e 73 64 61 74 3a 20 22 20 72 nt "runsdat: " r
05f0: 75 6e 73 64 61 74 29 0a 20 20 20 20 28 6c 65 74 unsdat). (let
0600: 2a 20 28 28 68 65 61 64 65 72 20 20 20 20 28 76 * ((header (v
0610: 65 63 74 6f 72 2d 72 65 66 20 72 75 6e 73 64 61 ector-ref runsda
0620: 74 20 30 29 29 0a 09 20 20 20 28 72 75 6e 73 6c t 0)).. (runsl
0630: 73 74 20 20 20 28 76 65 63 74 6f 72 2d 72 65 66 st (vector-ref
0640: 20 72 75 6e 73 64 61 74 20 31 29 29 0a 09 20 20 runsdat 1))..
0650: 20 28 66 75 6c 6c 2d 6c 69 73 74 20 28 61 70 70 (full-list (app
0660: 65 6e 64 20 72 65 73 20 72 75 6e 73 6c 73 74 29 end res runslst)
0670: 29 0a 09 20 20 20 28 68 61 76 65 2d 6d 6f 72 65 ).. (have-more
0680: 20 28 65 71 3f 20 28 6c 65 6e 67 74 68 20 72 75 (eq? (length ru
0690: 6e 73 6c 73 74 29 20 6c 69 6d 69 74 29 29 29 0a nslst) limit))).
06a0: 20 20 20 20 20 20 3b 3b 20 28 64 65 62 75 67 3a ;; (debug:
06b0: 70 72 69 6e 74 20 30 20 22 68 65 61 64 65 72 3a print 0 "header:
06c0: 20 22 20 68 65 61 64 65 72 20 22 20 72 75 6e 73 " header " runs
06d0: 6c 73 74 3a 20 22 20 72 75 6e 73 6c 73 74 20 22 lst: " runslst "
06e0: 20 68 61 76 65 2d 6d 6f 72 65 3a 20 22 20 68 61 have-more: " ha
06f0: 76 65 2d 6d 6f 72 65 29 0a 20 20 20 20 20 20 28 ve-more). (
0700: 69 66 20 68 61 76 65 2d 6d 6f 72 65 20 0a 09 20 if have-more ..
0710: 20 28 6c 65 74 20 28 28 6e 65 77 2d 6f 66 66 73 (let ((new-offs
0720: 65 74 20 28 2b 20 6f 66 66 73 65 74 20 6c 69 6d et (+ offset lim
0730: 69 74 29 29 0a 09 09 28 6e 65 78 74 2d 62 61 74 it))...(next-bat
0740: 63 68 20 28 63 64 62 3a 72 65 6d 6f 74 65 2d 72 ch (cdb:remote-r
0750: 75 6e 20 64 62 3a 67 65 74 2d 72 75 6e 73 2d 62 un db:get-runs-b
0760: 79 2d 70 61 74 74 20 23 66 20 6b 65 79 73 20 72 y-patt #f keys r
0770: 75 6e 6e 61 6d 65 70 61 74 74 20 74 61 72 67 70 unnamepatt targp
0780: 61 74 74 20 6f 66 66 73 65 74 20 6c 69 6d 69 74 att offset limit
0790: 29 29 29 0a 09 20 20 20 20 28 64 65 62 75 67 3a ))).. (debug:
07a0: 70 72 69 6e 74 2d 69 6e 66 6f 20 34 20 22 4d 6f print-info 4 "Mo
07b0: 72 65 20 74 68 61 6e 20 22 20 6c 69 6d 69 74 20 re than " limit
07c0: 22 20 72 75 6e 73 2c 20 68 61 76 65 20 22 20 28 " runs, have " (
07d0: 6c 65 6e 67 74 68 20 66 75 6c 6c 2d 6c 69 73 74 length full-list
07e0: 29 20 22 20 72 75 6e 73 20 73 6f 20 66 61 72 2e ) " runs so far.
07f0: 22 29 0a 09 20 20 20 20 28 64 65 62 75 67 3a 70 ").. (debug:p
0800: 72 69 6e 74 2d 69 6e 66 6f 20 30 20 22 6e 65 78 rint-info 0 "nex
0810: 74 2d 62 61 74 63 68 3a 20 22 20 6e 65 78 74 2d t-batch: " next-
0820: 62 61 74 63 68 29 0a 09 20 20 20 20 28 6c 6f 6f batch).. (loo
0830: 70 20 6e 65 78 74 2d 62 61 74 63 68 0a 09 09 20 p next-batch...
0840: 20 66 75 6c 6c 2d 6c 69 73 74 0a 09 09 20 20 6e full-list... n
0850: 65 77 2d 6f 66 66 73 65 74 0a 09 09 20 20 6c 69 ew-offset... li
0860: 6d 69 74 29 29 0a 09 20 28 76 65 63 74 6f 72 20 mit)).. (vector
0870: 68 65 61 64 65 72 20 66 75 6c 6c 2d 6c 69 73 74 header full-list
0880: 29 29 29 29 29 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d )))))..;;=======
0890: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
08a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
08b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
08c0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a ===============.
08d0: 3b 3b 20 20 54 20 45 20 53 20 54 20 53 0a 3b 3b ;; T E S T S.;;
08e0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
08f0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0900: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0910: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0920: 3d 3d 3d 3d 3d 3d 0a 0a 28 64 65 66 69 6e 65 20 ======..(define
0930: 28 6d 74 3a 67 65 74 2d 74 65 73 74 73 2d 66 6f (mt:get-tests-fo
0940: 72 2d 72 75 6e 20 72 75 6e 2d 69 64 20 74 65 73 r-run run-id tes
0950: 74 70 61 74 74 20 73 74 61 74 65 73 20 73 74 61 tpatt states sta
0960: 74 75 73 20 23 21 6b 65 79 20 28 6e 6f 74 2d 69 tus #!key (not-i
0970: 6e 20 23 74 29 20 28 73 6f 72 74 2d 62 79 20 27 n #t) (sort-by '
0980: 65 76 65 6e 74 5f 74 69 6d 65 29 20 28 73 6f 72 event_time) (sor
0990: 74 2d 6f 72 64 65 72 20 22 41 53 43 22 29 20 28 t-order "ASC") (
09a0: 71 72 79 76 61 6c 73 20 23 66 29 29 0a 20 20 28 qryvals #f)). (
09b0: 6c 65 74 20 6c 6f 6f 70 20 28 28 74 65 73 74 73 let loop ((tests
09c0: 64 61 74 20 28 63 64 62 3a 72 65 6d 6f 74 65 2d dat (cdb:remote-
09d0: 72 75 6e 20 64 62 3a 67 65 74 2d 74 65 73 74 73 run db:get-tests
09e0: 2d 66 6f 72 2d 72 75 6e 20 23 66 20 72 75 6e 2d -for-run #f run-
09f0: 69 64 20 74 65 73 74 70 61 74 74 20 73 74 61 74 id testpatt stat
0a00: 65 73 20 73 74 61 74 75 73 20 30 20 35 30 30 20 es status 0 500
0a10: 6e 6f 74 2d 69 6e 20 73 6f 72 74 2d 62 79 20 73 not-in sort-by s
0a20: 6f 72 74 2d 6f 72 64 65 72 20 71 72 79 76 61 6c ort-order qryval
0a30: 73 3a 20 71 72 79 76 61 6c 73 29 29 0a 09 20 20 s: qryvals))..
0a40: 20 20 20 28 72 65 73 20 20 20 20 20 20 27 28 29 (res '()
0a50: 29 0a 09 20 20 20 20 20 28 6f 66 66 73 65 74 20 ).. (offset
0a60: 20 20 30 29 0a 09 20 20 20 20 20 28 6c 69 6d 69 0).. (limi
0a70: 74 20 20 20 20 35 30 30 29 29 0a 20 20 20 20 28 t 500)). (
0a80: 6c 65 74 2a 20 28 28 66 75 6c 6c 2d 6c 69 73 74 let* ((full-list
0a90: 20 28 61 70 70 65 6e 64 20 72 65 73 20 74 65 73 (append res tes
0aa0: 74 73 64 61 74 29 29 0a 09 20 20 20 28 68 61 76 tsdat)).. (hav
0ab0: 65 2d 6d 6f 72 65 20 28 65 71 3f 20 28 6c 65 6e e-more (eq? (len
0ac0: 67 74 68 20 74 65 73 74 73 64 61 74 29 20 6c 69 gth testsdat) li
0ad0: 6d 69 74 29 29 29 0a 20 20 20 20 20 20 28 69 66 mit))). (if
0ae0: 20 68 61 76 65 2d 6d 6f 72 65 20 0a 09 20 20 28 have-more .. (
0af0: 6c 65 74 20 28 28 6e 65 77 2d 6f 66 66 73 65 74 let ((new-offset
0b00: 20 28 2b 20 6f 66 66 73 65 74 20 6c 69 6d 69 74 (+ offset limit
0b10: 29 29 29 0a 09 20 20 20 20 28 64 65 62 75 67 3a ))).. (debug:
0b20: 70 72 69 6e 74 2d 69 6e 66 6f 20 34 20 22 4d 6f print-info 4 "Mo
0b30: 72 65 20 74 68 61 6e 20 22 20 6c 69 6d 69 74 20 re than " limit
0b40: 22 20 74 65 73 74 73 2c 20 68 61 76 65 20 22 20 " tests, have "
0b50: 28 6c 65 6e 67 74 68 20 66 75 6c 6c 2d 6c 69 73 (length full-lis
0b60: 74 29 20 22 20 74 65 73 74 73 20 73 6f 20 66 61 t) " tests so fa
0b70: 72 2e 22 29 0a 09 20 20 20 20 28 6c 6f 6f 70 20 r.").. (loop
0b80: 28 63 64 62 3a 72 65 6d 6f 74 65 2d 72 75 6e 20 (cdb:remote-run
0b90: 64 62 3a 67 65 74 2d 74 65 73 74 73 2d 66 6f 72 db:get-tests-for
0ba0: 2d 72 75 6e 20 23 66 20 72 75 6e 2d 69 64 20 74 -run #f run-id t
0bb0: 65 73 74 70 61 74 74 20 73 74 61 74 65 73 20 73 estpatt states s
0bc0: 74 61 74 75 73 20 6e 65 77 2d 6f 66 66 73 65 74 tatus new-offset
0bd0: 20 6c 69 6d 69 74 20 6e 6f 74 2d 69 6e 20 73 6f limit not-in so
0be0: 72 74 2d 62 79 20 73 6f 72 74 2d 6f 72 64 65 72 rt-by sort-order
0bf0: 20 71 72 79 76 61 6c 73 3a 20 71 72 79 76 61 6c qryvals: qryval
0c00: 73 29 0a 09 09 20 20 66 75 6c 6c 2d 6c 69 73 74 s)... full-list
0c10: 0a 09 09 20 20 6e 65 77 2d 6f 66 66 73 65 74 0a ... new-offset.
0c20: 09 09 20 20 6c 69 6d 69 74 29 29 0a 09 20 20 66 .. limit)).. f
0c30: 75 6c 6c 2d 6c 69 73 74 29 29 29 29 0a 0a 28 64 ull-list))))..(d
0c40: 65 66 69 6e 65 20 28 6d 74 3a 67 65 74 2d 70 72 efine (mt:get-pr
0c50: 65 72 65 71 73 2d 6e 6f 74 2d 6d 65 74 20 72 75 ereqs-not-met ru
0c60: 6e 2d 69 64 20 77 61 69 74 6f 6e 73 20 72 65 66 n-id waitons ref
0c70: 2d 69 74 65 6d 2d 70 61 74 68 20 23 21 6b 65 79 -item-path #!key
0c80: 20 28 6d 6f 64 65 20 27 6e 6f 72 6d 61 6c 29 29 (mode 'normal))
0c90: 0a 20 20 28 64 62 3a 67 65 74 2d 70 72 65 72 65 . (db:get-prere
0ca0: 71 73 2d 6e 6f 74 2d 6d 65 74 20 72 75 6e 2d 69 qs-not-met run-i
0cb0: 64 20 77 61 69 74 6f 6e 73 20 72 65 66 2d 69 74 d waitons ref-it
0cc0: 65 6d 2d 70 61 74 68 20 6d 6f 64 65 3a 20 6d 6f em-path mode: mo
0cd0: 64 65 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 6d de))..(define (m
0ce0: 74 3a 6c 61 7a 79 2d 67 65 74 2d 70 72 65 72 65 t:lazy-get-prere
0cf0: 71 73 2d 6e 6f 74 2d 6d 65 74 20 72 75 6e 2d 69 qs-not-met run-i
0d00: 64 20 77 61 69 74 6f 6e 73 20 72 65 66 2d 69 74 d waitons ref-it
0d10: 65 6d 2d 70 61 74 68 20 23 21 6b 65 79 20 28 6d em-path #!key (m
0d20: 6f 64 65 20 27 6e 6f 72 6d 61 6c 29 29 0a 20 20 ode 'normal)).
0d30: 28 6c 65 74 2a 20 28 28 6b 65 79 20 20 20 20 28 (let* ((key (
0d40: 6c 69 73 74 20 72 75 6e 2d 69 64 20 77 61 69 74 list run-id wait
0d50: 6f 6e 73 20 72 65 66 2d 69 74 65 6d 2d 70 61 74 ons ref-item-pat
0d60: 68 20 6d 6f 64 65 29 29 0a 09 20 28 72 65 73 20 h mode)).. (res
0d70: 20 20 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 (hash-table-r
0d80: 65 66 2f 64 65 66 61 75 6c 74 20 2a 70 72 65 2d ef/default *pre-
0d90: 72 65 71 73 2d 6d 65 74 2d 63 61 63 68 65 2a 20 reqs-met-cache*
0da0: 6b 65 79 20 23 66 29 29 0a 09 20 28 75 73 65 72 key #f)).. (user
0db0: 65 73 20 28 6c 65 74 20 28 28 6c 61 73 74 2d 74 es (let ((last-t
0dc0: 69 6d 65 20 28 69 66 20 28 76 65 63 74 6f 72 3f ime (if (vector?
0dd0: 20 72 65 73 29 20 28 76 65 63 74 6f 72 2d 72 65 res) (vector-re
0de0: 66 20 72 65 73 20 30 29 20 23 66 29 29 29 0a 09 f res 0) #f)))..
0df0: 09 20 20 20 28 69 66 20 6c 61 73 74 2d 74 69 6d . (if last-tim
0e00: 65 0a 09 09 20 20 20 20 20 20 20 28 3c 20 28 63 e... (< (c
0e10: 75 72 72 65 6e 74 2d 73 65 63 6f 6e 64 73 29 28 urrent-seconds)(
0e20: 2b 20 6c 61 73 74 2d 74 69 6d 65 20 35 29 29 0a + last-time 5)).
0e30: 09 09 20 20 20 20 20 20 20 23 66 29 29 29 29 0a .. #f)))).
0e40: 20 20 20 20 28 69 66 20 75 73 65 72 65 73 0a 09 (if useres..
0e50: 28 6c 65 74 20 28 28 72 65 73 75 6c 74 20 28 76 (let ((result (v
0e60: 65 63 74 6f 72 2d 72 65 66 20 72 65 73 20 31 29 ector-ref res 1)
0e70: 29 29 0a 09 20 20 28 64 65 62 75 67 3a 70 72 69 )).. (debug:pri
0e80: 6e 74 20 34 20 22 55 73 69 6e 67 20 6c 61 7a 79 nt 4 "Using lazy
0e90: 20 76 61 6c 75 65 20 72 65 73 3a 20 22 20 72 65 value res: " re
0ea0: 73 75 6c 74 29 0a 09 20 20 72 65 73 75 6c 74 29 sult).. result)
0eb0: 0a 09 28 6c 65 74 20 28 28 6e 65 77 72 65 73 20 ..(let ((newres
0ec0: 28 64 62 3a 67 65 74 2d 70 72 65 72 65 71 73 2d (db:get-prereqs-
0ed0: 6e 6f 74 2d 6d 65 74 20 72 75 6e 2d 69 64 20 77 not-met run-id w
0ee0: 61 69 74 6f 6e 73 20 72 65 66 2d 69 74 65 6d 2d aitons ref-item-
0ef0: 70 61 74 68 20 6d 6f 64 65 3a 20 6d 6f 64 65 29 path mode: mode)
0f00: 29 29 0a 09 20 20 28 68 61 73 68 2d 74 61 62 6c )).. (hash-tabl
0f10: 65 2d 73 65 74 21 20 2a 70 72 65 2d 72 65 71 73 e-set! *pre-reqs
0f20: 2d 6d 65 74 2d 63 61 63 68 65 2a 20 6b 65 79 20 -met-cache* key
0f30: 28 76 65 63 74 6f 72 20 28 63 75 72 72 65 6e 74 (vector (current
0f40: 2d 73 65 63 6f 6e 64 73 29 20 6e 65 77 72 65 73 -seconds) newres
0f50: 29 29 0a 09 20 20 6e 65 77 72 65 73 29 29 29 29 )).. newres))))
0f60: 0a 0a 28 64 65 66 69 6e 65 20 28 6d 74 3a 67 65 ..(define (mt:ge
0f70: 74 2d 72 75 6e 2d 73 74 61 74 73 29 0a 20 20 28 t-run-stats). (
0f80: 63 64 62 3a 72 65 6d 6f 74 65 2d 72 75 6e 20 64 cdb:remote-run d
0f90: 62 3a 67 65 74 2d 72 75 6e 2d 73 74 61 74 73 20 b:get-run-stats
0fa0: 23 66 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 6d #f))..(define (m
0fb0: 74 3a 64 69 73 63 61 72 64 2d 62 6c 6f 63 6b 65 t:discard-blocke
0fc0: 64 2d 74 65 73 74 73 20 72 75 6e 2d 69 64 20 66 d-tests run-id f
0fd0: 61 69 6c 65 64 2d 74 65 73 74 20 74 65 73 74 73 ailed-test tests
0fe0: 20 74 65 73 74 2d 72 65 63 6f 72 64 73 29 0a 20 test-records).
0ff0: 20 28 69 66 20 28 6e 75 6c 6c 3f 20 74 65 73 74 (if (null? test
1000: 73 29 0a 20 20 20 20 20 20 74 65 73 74 73 0a 20 s). tests.
1010: 20 20 20 20 20 28 62 65 67 69 6e 0a 09 28 64 65 (begin..(de
1020: 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 31 bug:print-info 1
1030: 20 22 44 69 73 63 61 72 64 69 6e 67 20 74 65 73 "Discarding tes
1040: 74 73 20 66 72 6f 6d 20 22 20 74 65 73 74 73 20 ts from " tests
1050: 22 20 74 68 61 74 20 61 72 65 20 77 61 69 74 69 " that are waiti
1060: 6e 67 20 6f 6e 20 22 20 66 61 69 6c 65 64 2d 74 ng on " failed-t
1070: 65 73 74 29 0a 09 28 6c 65 74 20 6c 6f 6f 70 20 est)..(let loop
1080: 28 28 74 65 73 74 6e 20 28 63 61 72 20 74 65 73 ((testn (car tes
1090: 74 73 29 29 0a 09 09 20 20 20 28 72 65 6d 74 20 ts))... (remt
10a0: 20 28 63 64 72 20 74 65 73 74 73 29 29 0a 09 09 (cdr tests))...
10b0: 20 20 20 28 72 65 73 20 20 20 27 28 29 29 29 0a (res '())).
10c0: 09 20 20 28 6c 65 74 20 28 28 77 61 69 74 6f 6e . (let ((waiton
10d0: 73 20 28 76 65 63 74 6f 72 2d 72 65 66 20 28 68 s (vector-ref (h
10e0: 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 ash-table-ref/de
10f0: 66 61 75 6c 74 20 74 65 73 74 2d 72 65 63 6f 72 fault test-recor
1100: 64 73 20 74 65 73 74 6e 20 28 76 65 63 74 6f 72 ds testn (vector
1110: 20 23 66 20 23 66 20 27 28 29 29 29 20 32 29 29 #f #f '())) 2))
1120: 29 0a 09 20 20 20 20 3b 3b 20 28 70 72 69 6e 74 ).. ;; (print
1130: 20 22 6d 74 3a 64 69 73 63 61 72 64 2d 62 6c 6f "mt:discard-blo
1140: 63 6b 65 64 2d 74 65 73 74 73 20 72 75 6e 2d 69 cked-tests run-i
1150: 64 3a 20 22 20 72 75 6e 2d 69 64 20 22 20 66 61 d: " run-id " fa
1160: 69 6c 65 64 2d 74 65 73 74 3a 20 22 20 66 61 69 iled-test: " fai
1170: 6c 65 64 2d 74 65 73 74 20 22 20 74 65 73 74 6e led-test " testn
1180: 3a 20 22 20 74 65 73 74 6e 20 22 20 77 69 74 68 : " testn " with
1190: 20 77 61 69 74 6f 6e 73 3a 20 22 20 77 61 69 74 waitons: " wait
11a0: 6f 6e 73 29 0a 09 20 20 20 20 28 69 66 20 28 6e ons).. (if (n
11b0: 75 6c 6c 3f 20 72 65 6d 74 29 0a 09 09 28 6c 65 ull? remt)...(le
11c0: 74 20 28 28 6e 65 77 2d 72 65 73 20 28 72 65 76 t ((new-res (rev
11d0: 65 72 73 65 20 72 65 73 29 29 29 0a 09 09 20 20 erse res)))...
11e0: 3b 3b 20 28 70 72 69 6e 74 20 22 20 20 20 20 20 ;; (print "
11f0: 20 20 6e 65 77 2d 72 65 73 3a 20 22 20 6e 65 77 new-res: " new
1200: 2d 72 65 73 29 0a 09 09 20 20 6e 65 77 2d 72 65 -res)... new-re
1210: 73 29 0a 09 09 28 6c 6f 6f 70 20 28 63 61 72 20 s)...(loop (car
1220: 72 65 6d 74 29 0a 09 09 20 20 20 20 20 20 28 63 remt)... (c
1230: 64 72 20 72 65 6d 74 29 0a 09 09 20 20 20 20 20 dr remt)...
1240: 20 28 69 66 20 28 6d 65 6d 62 65 72 20 66 61 69 (if (member fai
1250: 6c 65 64 2d 74 65 73 74 20 77 61 69 74 6f 6e 73 led-test waitons
1260: 29 0a 09 09 09 20 20 72 65 73 0a 09 09 09 20 20 ).... res....
1270: 28 63 6f 6e 73 20 74 65 73 74 6e 20 72 65 73 29 (cons testn res)
1280: 29 29 29 29 29 29 29 29 0a 0a 3b 3b 3d 3d 3d 3d ))))))))..;;====
1290: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
12a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
12b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
12c0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
12d0: 3d 3d 0a 3b 3b 20 20 54 20 52 20 49 20 47 20 47 ==.;; T R I G G
12e0: 20 45 20 52 20 53 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d E R S.;;=======
12f0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1300: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1310: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1320: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a ===============.
1330: 0a 28 64 65 66 69 6e 65 20 28 6d 74 3a 70 72 6f .(define (mt:pro
1340: 63 65 73 73 2d 74 72 69 67 67 65 72 73 20 74 65 cess-triggers te
1350: 73 74 2d 69 64 20 6e 65 77 73 74 61 74 65 20 6e st-id newstate n
1360: 65 77 73 74 61 74 75 73 29 0a 20 20 28 6c 65 74 ewstatus). (let
1370: 2a 20 28 28 74 65 73 74 2d 64 61 74 20 20 20 20 * ((test-dat
1380: 20 20 28 6d 74 3a 6c 61 7a 79 2d 67 65 74 2d 74 (mt:lazy-get-t
1390: 65 73 74 2d 69 6e 66 6f 2d 62 79 2d 69 64 20 74 est-info-by-id t
13a0: 65 73 74 2d 69 64 29 29 0a 09 20 28 74 65 73 74 est-id)).. (test
13b0: 2d 72 75 6e 64 69 72 20 20 20 28 64 62 3a 74 65 -rundir (db:te
13c0: 73 74 2d 67 65 74 2d 72 75 6e 64 69 72 20 74 65 st-get-rundir te
13d0: 73 74 2d 64 61 74 29 29 0a 09 20 28 74 65 73 74 st-dat)).. (test
13e0: 2d 6e 61 6d 65 20 20 20 20 20 28 64 62 3a 74 65 -name (db:te
13f0: 73 74 2d 67 65 74 2d 74 65 73 74 6e 61 6d 65 20 st-get-testname
1400: 74 65 73 74 2d 64 61 74 29 29 0a 09 20 28 74 63 test-dat)).. (tc
1410: 6f 6e 66 69 67 20 20 20 20 20 20 20 23 66 29 0a onfig #f).
1420: 09 20 28 73 74 61 74 65 20 20 20 20 20 20 20 20 . (state
1430: 20 28 69 66 20 6e 65 77 73 74 61 74 65 20 20 6e (if newstate n
1440: 65 77 73 74 61 74 65 20 20 28 64 62 3a 74 65 73 ewstate (db:tes
1450: 74 2d 67 65 74 2d 73 74 61 74 65 20 20 74 65 73 t-get-state tes
1460: 74 2d 64 61 74 29 29 29 0a 09 20 28 73 74 61 74 t-dat))).. (stat
1470: 75 73 20 20 20 20 20 20 20 20 28 69 66 20 6e 65 us (if ne
1480: 77 73 74 61 74 75 73 20 6e 65 77 73 74 61 74 75 wstatus newstatu
1490: 73 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 73 s (db:test-get-s
14a0: 74 61 74 75 73 20 74 65 73 74 2d 64 61 74 29 29 tatus test-dat))
14b0: 29 29 0a 20 20 20 20 28 69 66 20 28 61 6e 64 20 )). (if (and
14c0: 28 66 69 6c 65 2d 65 78 69 73 74 73 3f 20 74 65 (file-exists? te
14d0: 73 74 2d 72 75 6e 64 69 72 29 0a 09 20 20 20 20 st-rundir)..
14e0: 20 28 64 69 72 65 63 74 6f 72 79 3f 20 74 65 73 (directory? tes
14f0: 74 2d 72 75 6e 64 69 72 29 29 0a 09 28 62 65 67 t-rundir))..(beg
1500: 69 6e 0a 09 20 20 28 70 75 73 68 2d 64 69 72 65 in.. (push-dire
1510: 63 74 6f 72 79 20 74 65 73 74 2d 72 75 6e 64 69 ctory test-rundi
1520: 72 29 0a 09 20 20 28 73 65 74 21 20 74 63 6f 6e r).. (set! tcon
1530: 66 69 67 20 28 6d 74 3a 6c 61 7a 79 2d 72 65 61 fig (mt:lazy-rea
1540: 64 2d 74 65 73 74 2d 63 6f 6e 66 69 67 20 74 65 d-test-config te
1550: 73 74 2d 6e 61 6d 65 29 29 0a 09 20 20 28 70 6f st-name)).. (po
1560: 70 2d 64 69 72 65 63 74 6f 72 79 29 0a 09 20 20 p-directory)..
1570: 28 66 6f 72 2d 65 61 63 68 20 28 6c 61 6d 62 64 (for-each (lambd
1580: 61 20 28 74 72 69 67 67 65 72 29 0a 09 09 20 20 a (trigger)...
1590: 20 20 20 20 28 6c 65 74 20 28 28 63 6d 64 20 20 (let ((cmd
15a0: 28 63 6f 6e 66 69 67 66 3a 6c 6f 6f 6b 75 70 20 (configf:lookup
15b0: 74 63 6f 6e 66 69 67 20 22 74 72 69 67 67 65 72 tconfig "trigger
15c0: 73 22 20 74 72 69 67 67 65 72 29 29 0a 09 09 09 s" trigger))....
15d0: 20 20 20 20 28 6c 6f 67 66 20 28 63 6f 6e 63 20 (logf (conc
15e0: 20 74 65 73 74 2d 72 75 6e 64 69 72 20 22 2f 6c test-rundir "/l
15f0: 61 73 74 2d 74 72 69 67 67 65 72 2e 6c 6f 67 22 ast-trigger.log"
1600: 29 29 29 0a 09 09 09 28 69 66 20 63 6d 64 0a 09 )))....(if cmd..
1610: 09 09 20 20 20 20 3b 3b 20 50 75 74 74 69 6e 67 .. ;; Putting
1620: 20 74 68 65 20 63 6f 6d 6d 61 6e 64 6c 69 6e 65 the commandline
1630: 20 69 6e 74 6f 20 28 20 29 27 73 20 6d 65 61 6e into ( )'s mean
1640: 73 20 6e 6f 20 63 6f 6e 74 72 6f 6c 20 6f 76 65 s no control ove
1650: 72 20 74 68 65 20 73 68 65 6c 6c 2e 20 0a 09 09 r the shell. ...
1660: 09 20 20 20 20 3b 3b 20 73 74 64 6f 75 74 20 61 . ;; stdout a
1670: 6e 64 20 73 74 64 65 72 72 20 77 69 6c 6c 20 62 nd stderr will b
1680: 65 20 63 61 75 67 68 74 20 69 6e 20 74 68 65 20 e caught in the
1690: 4e 42 46 41 4b 45 20 6f 72 20 6d 74 5f 6c 61 75 NBFAKE or mt_lau
16a0: 6e 63 68 2e 6c 6f 67 20 66 69 6c 65 73 0a 09 09 nch.log files...
16b0: 09 20 20 20 20 3b 3b 20 6f 72 20 65 71 75 69 76 . ;; or equiv
16c0: 61 6c 65 6e 74 2e 20 4e 6f 20 6e 65 65 64 20 74 alent. No need t
16d0: 6f 20 64 6f 20 74 68 69 73 2e 20 4a 75 73 74 20 o do this. Just
16e0: 72 75 6e 20 69 74 3f 0a 09 09 09 20 20 20 20 28 run it?.... (
16f0: 6c 65 74 20 28 28 66 75 6c 6c 63 6d 64 20 28 63 let ((fullcmd (c
1700: 6f 6e 63 20 63 6d 64 20 22 20 22 20 74 65 73 74 onc cmd " " test
1710: 2d 69 64 20 22 20 22 20 74 65 73 74 2d 72 75 6e -id " " test-run
1720: 64 69 72 20 22 20 22 20 74 72 69 67 67 65 72 20 dir " " trigger
1730: 22 26 22 29 29 29 0a 09 09 09 20 20 20 20 20 20 "&")))....
1740: 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 (debug:print-inf
1750: 6f 20 30 20 22 54 52 49 47 47 45 52 45 44 20 6f o 0 "TRIGGERED o
1760: 6e 20 22 20 74 72 69 67 67 65 72 20 22 2c 20 72 n " trigger ", r
1770: 75 6e 6e 69 6e 67 20 63 6f 6d 6d 61 6e 64 20 22 unning command "
1780: 20 66 75 6c 6c 63 6d 64 29 0a 09 09 09 20 20 20 fullcmd)....
1790: 20 20 20 28 70 72 6f 63 65 73 73 2d 72 75 6e 20 (process-run
17a0: 66 75 6c 6c 63 6d 64 29 29 29 29 29 0a 09 09 20 fullcmd)))))...
17b0: 20 20 20 28 6c 69 73 74 0a 09 09 20 20 20 20 20 (list...
17c0: 28 63 6f 6e 63 20 73 74 61 74 65 20 22 2f 22 20 (conc state "/"
17d0: 73 74 61 74 75 73 29 0a 09 09 20 20 20 20 20 28 status)... (
17e0: 63 6f 6e 63 20 73 74 61 74 65 20 22 2f 22 29 0a conc state "/").
17f0: 09 09 20 20 20 20 20 28 63 6f 6e 63 20 22 2f 22 .. (conc "/"
1800: 20 73 74 61 74 75 73 29 29 29 29 29 29 29 0a 0a status)))))))..
1810: 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;;==============
1820: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1830: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1840: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1850: 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 20 53 20 54 ========.;; S T
1860: 20 41 20 54 20 45 20 20 20 41 20 4e 20 44 20 20 A T E A N D
1870: 20 53 20 54 20 41 20 54 20 55 20 53 20 20 20 46 S T A T U S F
1880: 20 4f 20 52 20 20 20 54 20 45 20 53 20 54 20 53 O R T E S T S
1890: 20 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d .;;============
18a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
18b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
18c0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
18d0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 28 64 65 66 ==========..(def
18e0: 69 6e 65 20 28 6d 74 3a 72 6f 6c 6c 2d 75 70 2d ine (mt:roll-up-
18f0: 70 61 73 73 2d 66 61 69 6c 2d 63 6f 75 6e 74 73 pass-fail-counts
1900: 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 6e 61 6d run-id test-nam
1910: 65 20 69 74 65 6d 2d 70 61 74 68 20 73 74 61 74 e item-path stat
1920: 75 73 29 0a 20 20 28 69 66 20 28 61 6e 64 20 28 us). (if (and (
1930: 6e 6f 74 20 28 65 71 75 61 6c 3f 20 69 74 65 6d not (equal? item
1940: 2d 70 61 74 68 20 22 22 29 29 0a 09 20 20 20 28 -path "")).. (
1950: 6d 65 6d 62 65 72 20 73 74 61 74 75 73 20 27 28 member status '(
1960: 22 50 41 53 53 22 20 22 57 41 52 4e 22 20 22 46 "PASS" "WARN" "F
1970: 41 49 4c 22 20 22 57 41 49 56 45 44 22 20 22 52 AIL" "WAIVED" "R
1980: 55 4e 4e 49 4e 47 22 20 22 43 48 45 43 4b 22 20 UNNING" "CHECK"
1990: 22 53 4b 49 50 22 29 29 29 0a 20 20 20 20 20 20 "SKIP"))).
19a0: 28 62 65 67 69 6e 0a 09 28 63 64 62 3a 75 70 64 (begin..(cdb:upd
19b0: 61 74 65 2d 70 61 73 73 2d 66 61 69 6c 2d 63 6f ate-pass-fail-co
19c0: 75 6e 74 73 20 2a 72 75 6e 72 65 6d 6f 74 65 2a unts *runremote*
19d0: 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 6e 61 6d run-id test-nam
19e0: 65 29 0a 09 28 69 66 20 28 65 71 75 61 6c 3f 20 e)..(if (equal?
19f0: 73 74 61 74 75 73 20 22 52 55 4e 4e 49 4e 47 22 status "RUNNING"
1a00: 29 0a 09 20 20 20 20 28 63 64 62 3a 74 6f 70 2d ).. (cdb:top-
1a10: 74 65 73 74 2d 73 65 74 2d 72 75 6e 6e 69 6e 67 test-set-running
1a20: 20 2a 72 75 6e 72 65 6d 6f 74 65 2a 20 72 75 6e *runremote* run
1a30: 2d 69 64 20 74 65 73 74 2d 6e 61 6d 65 29 0a 09 -id test-name)..
1a40: 20 20 20 20 28 63 64 62 3a 74 6f 70 2d 74 65 73 (cdb:top-tes
1a50: 74 2d 73 65 74 2d 70 65 72 2d 70 66 2d 63 6f 75 t-set-per-pf-cou
1a60: 6e 74 73 20 2a 72 75 6e 72 65 6d 6f 74 65 2a 20 nts *runremote*
1a70: 72 75 6e 2d 69 64 20 74 65 73 74 2d 6e 61 6d 65 run-id test-name
1a80: 29 29 0a 09 23 66 29 0a 20 20 20 20 20 20 23 66 ))..#f). #f
1a90: 29 29 0a 0a 3b 3b 20 73 70 65 65 64 20 75 70 20 ))..;; speed up
1aa0: 66 6f 72 20 63 6f 6d 6d 6f 6e 20 63 61 73 65 73 for common cases
1ab0: 20 77 69 74 68 20 61 20 6c 69 74 74 6c 65 20 6c with a little l
1ac0: 6f 67 69 63 0a 28 64 65 66 69 6e 65 20 28 6d 74 ogic.(define (mt
1ad0: 3a 74 65 73 74 2d 73 65 74 2d 73 74 61 74 65 2d :test-set-state-
1ae0: 73 74 61 74 75 73 2d 62 79 2d 69 64 20 74 65 73 status-by-id tes
1af0: 74 2d 69 64 20 6e 65 77 73 74 61 74 65 20 6e 65 t-id newstate ne
1b00: 77 73 74 61 74 75 73 20 6e 65 77 63 6f 6d 6d 65 wstatus newcomme
1b10: 6e 74 29 0a 20 20 28 63 6f 6e 64 0a 20 20 20 28 nt). (cond. (
1b20: 28 61 6e 64 20 6e 65 77 73 74 61 74 65 20 6e 65 (and newstate ne
1b30: 77 73 74 61 74 75 73 20 6e 65 77 63 6f 6d 6d 65 wstatus newcomme
1b40: 6e 74 29 0a 20 20 20 20 28 63 64 62 3a 63 6c 69 nt). (cdb:cli
1b50: 65 6e 74 2d 63 61 6c 6c 20 2a 72 75 6e 72 65 6d ent-call *runrem
1b60: 6f 74 65 2a 20 27 73 74 61 74 65 2d 73 74 61 74 ote* 'state-stat
1b70: 75 73 2d 6d 73 67 20 23 74 20 2a 64 65 66 61 75 us-msg #t *defau
1b80: 6c 74 2d 6e 75 6d 74 72 69 65 73 2a 20 6e 65 77 lt-numtries* new
1b90: 73 74 61 74 65 20 6e 65 77 73 74 61 74 75 73 20 state newstatus
1ba0: 6e 65 77 63 6f 6d 6d 65 6e 74 20 74 65 73 74 2d newcomment test-
1bb0: 69 64 29 29 0a 20 20 20 28 28 61 6e 64 20 6e 65 id)). ((and ne
1bc0: 77 73 74 61 74 65 20 6e 65 77 73 74 61 74 75 73 wstate newstatus
1bd0: 29 0a 20 20 20 20 28 63 64 62 3a 63 6c 69 65 6e ). (cdb:clien
1be0: 74 2d 63 61 6c 6c 20 2a 72 75 6e 72 65 6d 6f 74 t-call *runremot
1bf0: 65 2a 20 27 73 74 61 74 65 2d 73 74 61 74 75 73 e* 'state-status
1c00: 20 23 74 20 2a 64 65 66 61 75 6c 74 2d 6e 75 6d #t *default-num
1c10: 74 72 69 65 73 2a 20 6e 65 77 73 74 61 74 65 20 tries* newstate
1c20: 6e 65 77 73 74 61 74 75 73 20 74 65 73 74 2d 69 newstatus test-i
1c30: 64 29 29 0a 20 20 20 28 65 6c 73 65 0a 20 20 20 d)). (else.
1c40: 20 28 69 66 20 6e 65 77 73 74 61 74 65 20 20 20 (if newstate
1c50: 28 63 64 62 3a 63 6c 69 65 6e 74 2d 63 61 6c 6c (cdb:client-call
1c60: 20 2a 72 75 6e 72 65 6d 6f 74 65 2a 20 27 73 65 *runremote* 'se
1c70: 74 2d 74 65 73 74 2d 73 74 61 74 65 20 23 74 20 t-test-state #t
1c80: 2a 64 65 66 61 75 6c 74 2d 6e 75 6d 74 72 69 65 *default-numtrie
1c90: 73 2a 20 6e 65 77 73 74 61 74 65 20 74 65 73 74 s* newstate test
1ca0: 2d 69 64 29 29 0a 20 20 20 20 28 69 66 20 6e 65 -id)). (if ne
1cb0: 77 73 74 61 74 75 73 20 20 28 63 64 62 3a 63 6c wstatus (cdb:cl
1cc0: 69 65 6e 74 2d 63 61 6c 6c 20 2a 72 75 6e 72 65 ient-call *runre
1cd0: 6d 6f 74 65 2a 20 27 73 65 74 2d 74 65 73 74 2d mote* 'set-test-
1ce0: 73 74 61 74 75 73 20 23 74 20 2a 64 65 66 61 75 status #t *defau
1cf0: 6c 74 2d 6e 75 6d 74 72 69 65 73 2a 20 6e 65 77 lt-numtries* new
1d00: 73 74 61 74 75 73 20 74 65 73 74 2d 69 64 29 29 status test-id))
1d10: 0a 20 20 20 20 28 69 66 20 6e 65 77 63 6f 6d 6d . (if newcomm
1d20: 65 6e 74 20 28 63 64 62 3a 63 6c 69 65 6e 74 2d ent (cdb:client-
1d30: 63 61 6c 6c 20 2a 72 75 6e 72 65 6d 6f 74 65 2a call *runremote*
1d40: 20 27 73 65 74 2d 74 65 73 74 2d 63 6f 6d 6d 65 'set-test-comme
1d50: 6e 74 20 23 74 20 2a 64 65 66 61 75 6c 74 2d 6e nt #t *default-n
1d60: 75 6d 74 72 69 65 73 2a 20 6e 65 77 63 6f 6d 6d umtries* newcomm
1d70: 65 6e 74 20 74 65 73 74 2d 69 64 29 29 29 29 0a ent test-id)))).
1d80: 20 20 20 28 6d 74 3a 70 72 6f 63 65 73 73 2d 74 (mt:process-t
1d90: 72 69 67 67 65 72 73 20 74 65 73 74 2d 69 64 20 riggers test-id
1da0: 6e 65 77 73 74 61 74 65 20 6e 65 77 73 74 61 74 newstate newstat
1db0: 75 73 29 0a 20 20 20 23 74 29 0a 0a 28 64 65 66 us). #t)..(def
1dc0: 69 6e 65 20 28 6d 74 3a 6c 61 7a 79 2d 67 65 74 ine (mt:lazy-get
1dd0: 2d 74 65 73 74 2d 69 6e 66 6f 2d 62 79 2d 69 64 -test-info-by-id
1de0: 20 74 65 73 74 2d 69 64 29 0a 20 20 28 6c 65 74 test-id). (let
1df0: 2a 20 28 28 74 64 61 74 20 28 68 61 73 68 2d 74 * ((tdat (hash-t
1e00: 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 able-ref/default
1e10: 20 2a 74 65 73 74 2d 69 6e 66 6f 2a 20 74 65 73 *test-info* tes
1e20: 74 2d 69 64 20 23 66 29 29 29 0a 20 20 20 20 28 t-id #f))). (
1e30: 69 66 20 28 61 6e 64 20 74 64 61 74 20 0a 09 20 if (and tdat ..
1e40: 20 20 20 20 28 3c 20 28 63 75 72 72 65 6e 74 2d (< (current-
1e50: 73 65 63 6f 6e 64 73 29 28 2b 20 28 76 65 63 74 seconds)(+ (vect
1e60: 6f 72 2d 72 65 66 20 74 64 61 74 20 30 29 20 31 or-ref tdat 0) 1
1e70: 30 29 29 29 0a 09 28 76 65 63 74 6f 72 2d 72 65 0)))..(vector-re
1e80: 66 20 74 64 61 74 20 31 29 0a 09 3b 3b 20 6e 6f f tdat 1)..;; no
1e90: 20 6e 65 65 64 20 74 6f 20 75 70 64 61 74 65 20 need to update
1ea0: 2a 74 65 73 74 2d 69 6e 66 6f 2a 20 61 73 20 74 *test-info* as t
1eb0: 68 61 74 20 69 73 20 64 6f 6e 65 20 69 6e 20 63 hat is done in c
1ec0: 64 62 3a 67 65 74 2d 74 65 73 74 2d 69 6e 66 6f db:get-test-info
1ed0: 2d 62 79 2d 69 64 0a 09 28 63 64 62 3a 67 65 74 -by-id..(cdb:get
1ee0: 2d 74 65 73 74 2d 69 6e 66 6f 2d 62 79 2d 69 64 -test-info-by-id
1ef0: 20 2a 72 75 6e 72 65 6d 6f 74 65 2a 20 74 65 73 *runremote* tes
1f00: 74 2d 69 64 29 29 29 29 0a 0a 28 64 65 66 69 6e t-id))))..(defin
1f10: 65 20 28 6d 74 3a 6c 61 7a 79 2d 72 65 61 64 2d e (mt:lazy-read-
1f20: 74 65 73 74 2d 63 6f 6e 66 69 67 20 74 65 73 74 test-config test
1f30: 2d 6e 61 6d 65 29 0a 20 20 28 6c 65 74 20 28 28 -name). (let ((
1f40: 74 63 6f 6e 66 20 28 68 61 73 68 2d 74 61 62 6c tconf (hash-tabl
1f50: 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 2a 74 e-ref/default *t
1f60: 65 73 74 63 6f 6e 66 69 67 73 2a 20 74 65 73 74 estconfigs* test
1f70: 2d 6e 61 6d 65 20 23 66 29 29 29 0a 20 20 20 20 -name #f))).
1f80: 28 69 66 20 74 63 6f 6e 66 0a 09 74 63 6f 6e 66 (if tconf..tconf
1f90: 0a 09 28 6c 65 74 20 28 28 74 65 73 74 2d 64 69 ..(let ((test-di
1fa0: 72 73 20 28 74 65 73 74 73 3a 67 65 74 2d 74 65 rs (tests:get-te
1fb0: 73 74 73 2d 73 65 61 72 63 68 2d 70 61 74 68 20 sts-search-path
1fc0: 2a 63 6f 6e 66 69 67 64 61 74 2a 29 29 29 0a 09 *configdat*)))..
1fd0: 20 20 28 6c 65 74 20 6c 6f 6f 70 20 28 28 68 65 (let loop ((he
1fe0: 64 20 28 63 61 72 20 74 65 73 74 2d 64 69 72 73 d (car test-dirs
1ff0: 29 29 0a 09 09 20 20 20 20 20 28 74 61 6c 20 28 ))... (tal (
2000: 63 64 72 20 74 65 73 74 2d 64 69 72 73 29 29 29 cdr test-dirs)))
2010: 0a 09 20 20 20 20 28 6c 65 74 20 28 28 74 63 6f .. (let ((tco
2020: 6e 66 69 67 2d 66 69 6c 65 20 28 63 6f 6e 63 20 nfig-file (conc
2030: 68 65 64 20 22 2f 22 20 74 65 73 74 2d 6e 61 6d hed "/" test-nam
2040: 65 20 22 2f 74 65 73 74 63 6f 6e 66 69 67 22 29 e "/testconfig")
2050: 29 29 0a 09 20 20 20 20 20 20 28 69 66 20 28 61 )).. (if (a
2060: 6e 64 20 28 66 69 6c 65 2d 65 78 69 73 74 73 3f nd (file-exists?
2070: 20 74 63 6f 6e 66 69 67 2d 66 69 6c 65 29 0a 09 tconfig-file)..
2080: 09 20 20 20 20 20 20 20 28 66 69 6c 65 2d 72 65 . (file-re
2090: 61 64 2d 61 63 63 65 73 73 3f 20 74 63 6f 6e 66 ad-access? tconf
20a0: 69 67 2d 66 69 6c 65 29 29 0a 09 09 20 20 28 6c ig-file))... (l
20b0: 65 74 20 28 28 6e 65 77 74 63 66 67 20 28 72 65 et ((newtcfg (re
20c0: 61 64 2d 63 6f 6e 66 69 67 20 74 63 6f 6e 66 69 ad-config tconfi
20d0: 67 2d 66 69 6c 65 20 23 66 20 23 66 29 29 29 20 g-file #f #f)))
20e0: 3b 3b 20 4e 4f 54 45 3a 20 44 6f 65 73 20 4e 4f ;; NOTE: Does NO
20f0: 54 20 72 75 6e 20 5b 73 79 73 74 65 6d 20 2e 2e T run [system ..
2100: 2e 5d 0a 09 09 20 20 20 20 28 68 61 73 68 2d 74 .]... (hash-t
2110: 61 62 6c 65 2d 73 65 74 21 20 2a 74 65 73 74 63 able-set! *testc
2120: 6f 6e 66 69 67 73 2a 20 74 65 73 74 2d 6e 61 6d onfigs* test-nam
2130: 65 20 6e 65 77 74 63 66 67 29 0a 09 09 20 20 20 e newtcfg)...
2140: 20 6e 65 77 74 63 66 67 29 0a 09 09 20 20 28 69 newtcfg)... (i
2150: 66 20 28 6e 75 6c 6c 3f 20 74 61 6c 29 0a 09 09 f (null? tal)...
2160: 20 20 20 20 20 20 28 62 65 67 69 6e 0a 09 09 09 (begin....
2170: 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 22 (debug:print 0 "
2180: 45 52 52 4f 52 3a 20 4e 6f 20 72 65 61 64 61 62 ERROR: No readab
2190: 6c 65 20 74 65 73 74 63 6f 6e 66 69 67 20 66 6f le testconfig fo
21a0: 75 6e 64 20 66 6f 72 20 22 20 74 65 73 74 2d 6e und for " test-n
21b0: 61 6d 65 29 0a 09 09 09 23 66 29 0a 09 09 20 20 ame)....#f)...
21c0: 20 20 20 20 28 6c 6f 6f 70 20 28 63 61 72 20 74 (loop (car t
21d0: 61 6c 29 28 63 64 72 20 74 61 6c 29 29 29 29 29 al)(cdr tal)))))
21e0: 29 29 29 29 29 0a 0a )))))..