0000: 0a 3b 3b 20 43 6f 70 79 72 69 67 68 74 20 32 30 .;; Copyright 20
0010: 30 36 2d 32 30 31 31 2c 20 4d 61 74 74 68 65 77 06-2011, Matthew
0020: 20 57 65 6c 6c 61 6e 64 2e 0a 3b 3b 20 0a 3b 3b Welland..;; .;;
0030: 20 20 54 68 69 73 20 70 72 6f 67 72 61 6d 20 69 This program i
0040: 73 20 6d 61 64 65 20 61 76 61 69 6c 61 62 6c 65 s made available
0050: 20 75 6e 64 65 72 20 74 68 65 20 47 4e 55 20 47 under the GNU G
0060: 50 4c 20 76 65 72 73 69 6f 6e 20 32 2e 30 20 6f PL version 2.0 o
0070: 72 0a 3b 3b 20 20 67 72 65 61 74 65 72 2e 20 53 r.;; greater. S
0080: 65 65 20 74 68 65 20 61 63 63 6f 6d 70 61 6e 79 ee the accompany
0090: 69 6e 67 20 66 69 6c 65 20 43 4f 50 59 49 4e 47 ing file COPYING
00a0: 20 66 6f 72 20 64 65 74 61 69 6c 73 2e 0a 3b 3b for details..;;
00b0: 20 0a 3b 3b 20 20 54 68 69 73 20 70 72 6f 67 72 .;; This progr
00c0: 61 6d 20 69 73 20 64 69 73 74 72 69 62 75 74 65 am is distribute
00d0: 64 20 57 49 54 48 4f 55 54 20 41 4e 59 20 57 41 d WITHOUT ANY WA
00e0: 52 52 41 4e 54 59 3b 20 77 69 74 68 6f 75 74 20 RRANTY; without
00f0: 65 76 65 6e 20 74 68 65 0a 3b 3b 20 20 69 6d 70 even the.;; imp
0100: 6c 69 65 64 20 77 61 72 72 61 6e 74 79 20 6f 66 lied warranty of
0110: 20 4d 45 52 43 48 41 4e 54 41 42 49 4c 49 54 59 MERCHANTABILITY
0120: 20 6f 72 20 46 49 54 4e 45 53 53 20 46 4f 52 20 or FITNESS FOR
0130: 41 20 50 41 52 54 49 43 55 4c 41 52 0a 3b 3b 20 A PARTICULAR.;;
0140: 20 50 55 52 50 4f 53 45 2e 0a 0a 3b 3b 20 20 73 PURPOSE...;; s
0150: 74 72 66 74 69 6d 65 28 27 25 6d 2f 25 64 2f 25 trftime('%m/%d/%
0160: 59 20 25 48 3a 25 4d 3a 25 53 27 2c 27 6e 6f 77 Y %H:%M:%S','now
0170: 27 2c 27 6c 6f 63 61 6c 74 69 6d 65 27 29 0a 0a ','localtime')..
0180: 28 75 73 65 20 73 71 6c 69 74 65 33 20 73 72 66 (use sqlite3 srf
0190: 69 2d 31 20 70 6f 73 69 78 20 72 65 67 65 78 20 i-1 posix regex
01a0: 72 65 67 65 78 2d 63 61 73 65 20 73 72 66 69 2d regex-case srfi-
01b0: 36 39 20 64 6f 74 2d 6c 6f 63 6b 69 6e 67 20 28 69 dot-locking (
01c0: 73 72 66 69 20 31 38 29 20 70 6f 73 69 78 2d 65 srfi 18) posix-e
01d0: 78 74 72 61 73 20 64 69 72 65 63 74 6f 72 79 2d xtras directory-
01e0: 75 74 69 6c 73 29 0a 28 69 6d 70 6f 72 74 20 28 utils).(import (
01f0: 70 72 65 66 69 78 20 73 71 6c 69 74 65 33 20 73 prefix sqlite3 s
0200: 71 6c 69 74 65 33 3a 29 29 0a 0a 28 64 65 63 6c qlite3:))..(decl
0210: 61 72 65 20 28 75 6e 69 74 20 72 75 6e 73 29 29 are (unit runs))
0220: 0a 28 64 65 63 6c 61 72 65 20 28 75 73 65 73 20 .(declare (uses
0230: 64 62 29 29 0a 28 64 65 63 6c 61 72 65 20 28 75 db)).(declare (u
0240: 73 65 73 20 63 6f 6d 6d 6f 6e 29 29 0a 28 64 65 ses common)).(de
0250: 63 6c 61 72 65 20 28 75 73 65 73 20 69 74 65 6d clare (uses item
0260: 73 29 29 0a 28 64 65 63 6c 61 72 65 20 28 75 73 s)).(declare (us
0270: 65 73 20 72 75 6e 63 6f 6e 66 69 67 29 29 0a 28 es runconfig)).(
0280: 64 65 63 6c 61 72 65 20 28 75 73 65 73 20 74 65 declare (uses te
0290: 73 74 73 29 29 0a 28 64 65 63 6c 61 72 65 20 28 sts)).(declare (
02a0: 75 73 65 73 20 73 65 72 76 65 72 29 29 0a 0a 28 uses server))..(
02b0: 69 6e 63 6c 75 64 65 20 22 63 6f 6d 6d 6f 6e 5f include "common_
02c0: 72 65 63 6f 72 64 73 2e 73 63 6d 22 29 0a 28 69 records.scm").(i
02d0: 6e 63 6c 75 64 65 20 22 6b 65 79 5f 72 65 63 6f nclude "key_reco
02e0: 72 64 73 2e 73 63 6d 22 29 0a 28 69 6e 63 6c 75 rds.scm").(inclu
02f0: 64 65 20 22 64 62 5f 72 65 63 6f 72 64 73 2e 73 de "db_records.s
0300: 63 6d 22 29 0a 28 69 6e 63 6c 75 64 65 20 22 72 cm").(include "r
0310: 75 6e 5f 72 65 63 6f 72 64 73 2e 73 63 6d 22 29 un_records.scm")
0320: 0a 28 69 6e 63 6c 75 64 65 20 22 74 65 73 74 5f .(include "test_
0330: 72 65 63 6f 72 64 73 2e 73 63 6d 22 29 0a 0a 3b records.scm")..;
0340: 3b 20 72 75 6e 73 3a 67 65 74 2d 72 75 6e 73 2d ; runs:get-runs-
0350: 62 79 2d 70 61 74 74 0a 3b 3b 20 67 65 74 20 72 by-patt.;; get r
0360: 75 6e 73 20 62 79 20 6c 69 73 74 20 6f 66 20 63 uns by list of c
0370: 72 69 74 65 72 69 61 0a 3b 3b 20 72 65 67 69 73 riteria.;; regis
0380: 74 65 72 20 61 20 74 65 73 74 20 72 75 6e 20 77 ter a test run w
0390: 69 74 68 20 74 68 65 20 64 62 0a 3b 3b 0a 3b 3b ith the db.;;.;;
03a0: 20 55 73 65 3a 20 28 64 62 2d 67 65 74 2d 76 61 Use: (db-get-va
03b0: 6c 75 65 2d 62 79 2d 68 65 61 64 65 72 20 28 64 lue-by-header (d
03c0: 62 3a 67 65 74 2d 68 65 61 64 65 72 20 72 75 6e b:get-header run
03d0: 69 6e 66 6f 29 28 64 62 3a 67 65 74 2d 72 6f 77 info)(db:get-row
03e0: 20 72 75 6e 69 6e 66 6f 29 29 0a 3b 3b 20 20 74 runinfo)).;; t
03f0: 6f 20 65 78 74 72 61 63 74 20 69 6e 66 6f 20 66 o extract info f
0400: 72 6f 6d 20 74 68 65 20 73 74 72 75 63 74 75 72 rom the structur
0410: 65 20 72 65 74 75 72 6e 65 64 0a 3b 3b 0a 28 64 e returned.;;.(d
0420: 65 66 69 6e 65 20 28 72 75 6e 73 3a 67 65 74 2d efine (runs:get-
0430: 72 75 6e 73 2d 62 79 2d 70 61 74 74 20 64 62 20 runs-by-patt db
0440: 6b 65 79 73 20 72 75 6e 6e 61 6d 65 70 61 74 74 keys runnamepatt
0450: 20 2e 20 70 61 72 61 6d 73 29 20 3b 3b 20 74 65 . params) ;; te
0460: 73 74 2d 6e 61 6d 65 29 0a 20 20 28 6c 65 74 2a st-name). (let*
0470: 20 28 28 6b 65 79 76 61 6c 6c 73 74 20 28 6b 65 ((keyvallst (ke
0480: 79 73 2d 3e 76 61 6c 6c 69 73 74 20 6b 65 79 73 ys->vallist keys
0490: 29 29 0a 09 20 28 74 6d 70 20 20 20 20 20 20 28 )).. (tmp (
04a0: 72 75 6e 73 3a 67 65 74 2d 73 74 64 2d 72 75 6e runs:get-std-run
04b0: 2d 66 69 65 6c 64 73 20 6b 65 79 73 20 27 28 22 -fields keys '("
04c0: 69 64 22 20 22 72 75 6e 6e 61 6d 65 22 20 22 73 id" "runname" "s
04d0: 74 61 74 65 22 20 22 73 74 61 74 75 73 22 20 22 tate" "status" "
04e0: 6f 77 6e 65 72 22 20 22 65 76 65 6e 74 5f 74 69 owner" "event_ti
04f0: 6d 65 22 29 29 29 0a 09 20 28 6b 65 79 73 74 72 me"))).. (keystr
0500: 20 20 20 28 63 61 72 20 74 6d 70 29 29 0a 09 20 (car tmp))..
0510: 28 68 65 61 64 65 72 20 20 20 28 63 61 64 72 20 (header (cadr
0520: 74 6d 70 29 29 0a 09 20 28 72 65 73 20 20 20 20 tmp)).. (res
0530: 20 27 28 29 29 0a 09 20 28 6b 65 79 2d 70 61 74 '()).. (key-pat
0540: 74 20 22 22 29 29 0a 20 20 20 20 28 66 6f 72 2d t "")). (for-
0550: 65 61 63 68 20 28 6c 61 6d 62 64 61 20 28 6b 65 each (lambda (ke
0560: 79 76 61 6c 29 0a 09 09 28 6c 65 74 2a 20 28 28 yval)...(let* ((
0570: 6b 65 79 20 20 20 20 28 76 65 63 74 6f 72 2d 72 key (vector-r
0580: 65 66 20 6b 65 79 76 61 6c 20 30 29 29 0a 09 09 ef keyval 0))...
0590: 20 20 20 20 20 20 20 28 66 75 6c 6b 65 79 20 28 (fulkey (
05a0: 63 6f 6e 63 20 22 3a 22 20 6b 65 79 29 29 0a 09 conc ":" key))..
05b0: 09 20 20 20 20 20 20 20 28 70 61 74 74 20 20 20 . (patt
05c0: 28 61 72 67 73 3a 67 65 74 2d 61 72 67 20 66 75 (args:get-arg fu
05d0: 6c 6b 65 79 29 29 29 0a 09 09 20 20 28 69 66 20 lkey)))... (if
05e0: 70 61 74 74 0a 09 09 20 20 20 20 20 20 28 73 65 patt... (se
05f0: 74 21 20 6b 65 79 2d 70 61 74 74 20 28 63 6f 6e t! key-patt (con
0600: 63 20 6b 65 79 2d 70 61 74 74 20 22 20 41 4e 44 c key-patt " AND
0610: 20 22 20 6b 65 79 20 22 20 6c 69 6b 65 20 27 22 " key " like '"
0620: 20 70 61 74 74 20 22 27 22 29 29 0a 09 09 20 20 patt "'"))...
0630: 20 20 20 20 28 62 65 67 69 6e 0a 09 09 09 28 64 (begin....(d
0640: 65 62 75 67 3a 70 72 69 6e 74 20 30 20 22 45 52 ebug:print 0 "ER
0650: 52 4f 52 3a 20 73 65 61 72 63 68 69 6e 67 20 66 ROR: searching f
0660: 6f 72 20 72 75 6e 73 20 77 69 74 68 20 6e 6f 20 or runs with no
0670: 70 61 74 74 65 72 6e 20 73 65 74 20 66 6f 72 20 pattern set for
0680: 22 20 66 75 6c 6b 65 79 29 0a 09 09 09 28 65 78 " fulkey)....(ex
0690: 69 74 20 36 29 29 29 29 29 0a 09 20 20 20 20 20 it 6)))))..
06a0: 20 6b 65 79 73 29 0a 20 20 20 20 28 73 71 6c 69 keys). (sqli
06b0: 74 65 33 3a 66 6f 72 2d 65 61 63 68 2d 72 6f 77 te3:for-each-row
06c0: 20 0a 20 20 20 20 20 28 6c 61 6d 62 64 61 20 28 . (lambda (
06d0: 61 20 2e 20 72 29 0a 20 20 20 20 20 20 20 28 73 a . r). (s
06e0: 65 74 21 20 72 65 73 20 28 63 6f 6e 73 20 28 6c et! res (cons (l
06f0: 69 73 74 2d 3e 76 65 63 74 6f 72 20 28 63 6f 6e ist->vector (con
0700: 73 20 61 20 72 29 29 20 72 65 73 29 29 29 0a 20 s a r)) res))).
0710: 20 20 20 20 64 62 20 0a 20 20 20 20 20 28 63 6f db . (co
0720: 6e 63 20 22 53 45 4c 45 43 54 20 22 20 6b 65 79 nc "SELECT " key
0730: 73 74 72 20 22 20 46 52 4f 4d 20 72 75 6e 73 20 str " FROM runs
0740: 57 48 45 52 45 20 72 75 6e 6e 61 6d 65 20 6c 69 WHERE runname li
0750: 6b 65 20 3f 20 22 20 6b 65 79 2d 70 61 74 74 20 ke ? " key-patt
0760: 22 3b 22 29 0a 20 20 20 20 20 72 75 6e 6e 61 6d ";"). runnam
0770: 65 70 61 74 74 29 0a 20 20 20 20 28 76 65 63 74 epatt). (vect
0780: 6f 72 20 68 65 61 64 65 72 20 72 65 73 29 29 29 or header res)))
0790: 0a 0a 28 64 65 66 69 6e 65 20 28 72 75 6e 73 3a ..(define (runs:
07a0: 74 65 73 74 2d 67 65 74 2d 66 75 6c 6c 2d 70 61 test-get-full-pa
07b0: 74 68 20 74 65 73 74 29 0a 20 20 28 6c 65 74 2a th test). (let*
07c0: 20 28 28 74 65 73 74 6e 61 6d 65 20 28 64 62 3a ((testname (db:
07d0: 74 65 73 74 2d 67 65 74 2d 74 65 73 74 6e 61 6d test-get-testnam
07e0: 65 20 20 20 74 65 73 74 29 29 0a 09 20 28 69 74 e test)).. (it
07f0: 65 6d 70 61 74 68 20 28 64 62 3a 74 65 73 74 2d empath (db:test-
0800: 67 65 74 2d 69 74 65 6d 2d 70 61 74 68 20 74 65 get-item-path te
0810: 73 74 29 29 29 0a 20 20 20 20 28 63 6f 6e 63 20 st))). (conc
0820: 74 65 73 74 6e 61 6d 65 20 28 69 66 20 28 65 71 testname (if (eq
0830: 75 61 6c 3f 20 69 74 65 6d 70 61 74 68 20 22 22 ual? itempath ""
0840: 29 20 22 22 20 28 63 6f 6e 63 20 22 28 22 20 69 ) "" (conc "(" i
0850: 74 65 6d 70 61 74 68 20 22 29 22 29 29 29 29 29 tempath ")")))))
0860: 0a 0a 28 64 65 66 69 6e 65 20 28 73 65 74 2d 6d ..(define (set-m
0870: 65 67 61 74 65 73 74 2d 65 6e 76 2d 76 61 72 73 egatest-env-vars
0880: 20 64 62 20 72 75 6e 2d 69 64 29 0a 20 20 28 6c db run-id). (l
0890: 65 74 20 28 28 6b 65 79 73 20 28 64 62 3a 67 65 et ((keys (db:ge
08a0: 74 2d 6b 65 79 73 20 64 62 29 29 29 0a 20 20 20 t-keys db))).
08b0: 20 28 66 6f 72 2d 65 61 63 68 20 28 6c 61 6d 62 (for-each (lamb
08c0: 64 61 20 28 6b 65 79 29 0a 09 09 28 73 71 6c 69 da (key)...(sqli
08d0: 74 65 33 3a 66 6f 72 2d 65 61 63 68 2d 72 6f 77 te3:for-each-row
08e0: 0a 09 09 20 28 6c 61 6d 62 64 61 20 28 76 61 6c ... (lambda (val
08f0: 29 0a 09 09 20 20 20 28 64 65 62 75 67 3a 70 72 )... (debug:pr
0900: 69 6e 74 20 32 20 22 73 65 74 65 6e 76 20 22 20 int 2 "setenv "
0910: 28 6b 65 79 3a 67 65 74 2d 66 69 65 6c 64 6e 61 (key:get-fieldna
0920: 6d 65 20 6b 65 79 29 20 22 20 22 20 76 61 6c 29 me key) " " val)
0930: 0a 09 09 20 20 20 28 73 65 74 65 6e 76 20 28 6b ... (setenv (k
0940: 65 79 3a 67 65 74 2d 66 69 65 6c 64 6e 61 6d 65 ey:get-fieldname
0950: 20 6b 65 79 29 20 76 61 6c 29 29 0a 09 09 20 64 key) val))... d
0960: 62 20 0a 09 09 20 28 63 6f 6e 63 20 22 53 45 4c b ... (conc "SEL
0970: 45 43 54 20 22 20 28 6b 65 79 3a 67 65 74 2d 66 ECT " (key:get-f
0980: 69 65 6c 64 6e 61 6d 65 20 6b 65 79 29 20 22 20 ieldname key) "
0990: 46 52 4f 4d 20 72 75 6e 73 20 57 48 45 52 45 20 FROM runs WHERE
09a0: 69 64 3d 3f 3b 22 29 0a 09 09 20 72 75 6e 2d 69 id=?;")... run-i
09b0: 64 29 29 0a 09 20 20 20 20 20 20 6b 65 79 73 29 d)).. keys)
09c0: 0a 20 20 20 20 28 61 6c 69 73 74 2d 3e 65 6e 76 . (alist->env
09d0: 2d 76 61 72 73 20 28 68 61 73 68 2d 74 61 62 6c -vars (hash-tabl
09e0: 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 2a 63 e-ref/default *c
09f0: 6f 6e 66 69 67 64 61 74 2a 20 22 65 6e 76 2d 6f onfigdat* "env-o
0a00: 76 65 72 72 69 64 65 22 20 27 28 29 29 29 0a 20 verride" '())).
0a10: 20 20 20 3b 3b 20 4c 65 74 73 20 75 73 65 20 74 ;; Lets use t
0a20: 68 69 73 20 61 73 20 61 6e 20 6f 70 70 6f 72 74 his as an opport
0a30: 75 6e 69 74 79 20 74 6f 20 70 75 74 20 4d 54 5f unity to put MT_
0a40: 52 55 4e 4e 41 4d 45 20 69 6e 20 74 68 65 20 65 RUNNAME in the e
0a50: 6e 76 69 72 6f 6e 6d 65 6e 74 0a 20 20 20 20 28 nvironment. (
0a60: 73 71 6c 69 74 65 33 3a 66 6f 72 2d 65 61 63 68 sqlite3:for-each
0a70: 2d 72 6f 77 0a 20 20 20 20 20 28 6c 61 6d 62 64 -row. (lambd
0a80: 61 20 28 72 75 6e 6e 61 6d 65 29 0a 20 20 20 20 a (runname).
0a90: 20 20 20 28 73 65 74 65 6e 76 20 22 4d 54 5f 52 (setenv "MT_R
0aa0: 55 4e 4e 41 4d 45 22 20 72 75 6e 6e 61 6d 65 29 UNNAME" runname)
0ab0: 29 0a 20 20 20 20 20 64 62 0a 20 20 20 20 20 22 ). db. "
0ac0: 53 45 4c 45 43 54 20 72 75 6e 6e 61 6d 65 20 46 SELECT runname F
0ad0: 52 4f 4d 20 72 75 6e 73 20 57 48 45 52 45 20 69 ROM runs WHERE i
0ae0: 64 3d 3f 3b 22 0a 20 20 20 20 20 72 75 6e 2d 69 d=?;". run-i
0af0: 64 29 0a 20 20 20 20 29 29 0a 0a 28 64 65 66 69 d). ))..(defi
0b00: 6e 65 20 28 73 65 74 2d 69 74 65 6d 2d 65 6e 76 ne (set-item-env
0b10: 2d 76 61 72 73 20 69 74 65 6d 64 61 74 29 0a 20 -vars itemdat).
0b20: 20 28 66 6f 72 2d 65 61 63 68 20 28 6c 61 6d 62 (for-each (lamb
0b30: 64 61 20 28 69 74 65 6d 29 0a 09 20 20 20 20 20 da (item)..
0b40: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 32 20 (debug:print 2
0b50: 22 73 65 74 65 6e 76 20 22 20 28 63 61 72 20 69 "setenv " (car i
0b60: 74 65 6d 29 20 22 20 22 20 28 63 61 64 72 20 69 tem) " " (cadr i
0b70: 74 65 6d 29 29 0a 09 20 20 20 20 20 20 28 73 65 tem)).. (se
0b80: 74 65 6e 76 20 28 63 61 72 20 69 74 65 6d 29 20 tenv (car item)
0b90: 28 63 61 64 72 20 69 74 65 6d 29 29 29 0a 09 20 (cadr item)))..
0ba0: 20 20 20 69 74 65 6d 64 61 74 29 29 0a 0a 28 64 itemdat))..(d
0bb0: 65 66 69 6e 65 20 2a 6c 61 73 74 2d 6e 75 6d 2d efine *last-num-
0bc0: 72 75 6e 6e 69 6e 67 2d 74 65 73 74 73 2a 20 30 running-tests* 0
0bd0: 29 0a 28 64 65 66 69 6e 65 20 28 72 75 6e 73 3a ).(define (runs:
0be0: 63 61 6e 2d 72 75 6e 2d 6d 6f 72 65 2d 74 65 73 can-run-more-tes
0bf0: 74 73 20 64 62 20 74 65 73 74 2d 72 65 63 6f 72 ts db test-recor
0c00: 64 29 0a 20 20 28 6c 65 74 2a 20 28 28 74 63 6f d). (let* ((tco
0c10: 6e 66 69 67 20 20 20 20 20 20 20 20 20 20 20 20 nfig
0c20: 20 20 20 20 20 28 74 65 73 74 73 3a 74 65 73 74 (tests:test
0c30: 71 75 65 75 65 2d 67 65 74 2d 74 65 73 74 63 6f queue-get-testco
0c40: 6e 66 69 67 20 74 65 73 74 2d 72 65 63 6f 72 64 nfig test-record
0c50: 29 29 0a 09 20 28 6a 6f 62 67 72 6f 75 70 20 20 )).. (jobgroup
0c60: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 63 (c
0c70: 6f 6e 66 69 67 2d 6c 6f 6f 6b 75 70 20 74 63 6f onfig-lookup tco
0c80: 6e 66 69 67 20 22 72 65 71 75 69 72 65 6d 65 6e nfig "requiremen
0c90: 74 73 22 20 22 6a 6f 62 67 72 6f 75 70 22 29 29 ts" "jobgroup"))
0ca0: 0a 09 20 28 6e 75 6d 2d 72 75 6e 6e 69 6e 67 20 .. (num-running
0cb0: 20 20 20 20 20 20 20 20 20 20 20 20 28 64 62 3a (db:
0cc0: 67 65 74 2d 63 6f 75 6e 74 2d 74 65 73 74 73 2d get-count-tests-
0cd0: 72 75 6e 6e 69 6e 67 20 64 62 29 29 0a 09 20 28 running db)).. (
0ce0: 6e 75 6d 2d 72 75 6e 6e 69 6e 67 2d 69 6e 2d 6a num-running-in-j
0cf0: 6f 62 67 72 6f 75 70 20 28 64 62 3a 67 65 74 2d obgroup (db:get-
0d00: 63 6f 75 6e 74 2d 74 65 73 74 73 2d 72 75 6e 6e count-tests-runn
0d10: 69 6e 67 2d 69 6e 2d 6a 6f 62 67 72 6f 75 70 20 ing-in-jobgroup
0d20: 64 62 20 6a 6f 62 67 72 6f 75 70 29 29 0a 09 20 db jobgroup))..
0d30: 28 6d 61 78 2d 63 6f 6e 63 75 72 72 65 6e 74 2d (max-concurrent-
0d40: 6a 6f 62 73 20 20 20 20 20 28 63 6f 6e 66 69 67 jobs (config
0d50: 2d 6c 6f 6f 6b 75 70 20 2a 63 6f 6e 66 69 67 64 -lookup *configd
0d60: 61 74 2a 20 22 73 65 74 75 70 22 20 20 20 20 20 at* "setup"
0d70: 22 6d 61 78 5f 63 6f 6e 63 75 72 72 65 6e 74 5f "max_concurrent_
0d80: 6a 6f 62 73 22 29 29 0a 09 20 28 6a 6f 62 2d 67 jobs")).. (job-g
0d90: 72 6f 75 70 2d 6c 69 6d 69 74 20 20 20 20 20 20 roup-limit
0da0: 20 20 20 28 63 6f 6e 66 69 67 2d 6c 6f 6f 6b 75 (config-looku
0db0: 70 20 2a 63 6f 6e 66 69 67 64 61 74 2a 20 22 6a p *configdat* "j
0dc0: 6f 62 67 72 6f 75 70 73 22 20 6a 6f 62 67 72 6f obgroups" jobgro
0dd0: 75 70 29 29 29 0a 20 20 20 20 28 69 66 20 28 6e up))). (if (n
0de0: 6f 74 20 28 65 71 3f 20 2a 6c 61 73 74 2d 6e 75 ot (eq? *last-nu
0df0: 6d 2d 72 75 6e 6e 69 6e 67 2d 74 65 73 74 73 2a m-running-tests*
0e00: 20 6e 75 6d 2d 72 75 6e 6e 69 6e 67 29 29 0a 09 num-running))..
0e10: 28 62 65 67 69 6e 0a 09 20 20 28 64 65 62 75 67 (begin.. (debug
0e20: 3a 70 72 69 6e 74 20 32 20 22 6d 61 78 2d 63 6f :print 2 "max-co
0e30: 6e 63 75 72 72 65 6e 74 2d 6a 6f 62 73 3a 20 22 ncurrent-jobs: "
0e40: 20 6d 61 78 2d 63 6f 6e 63 75 72 72 65 6e 74 2d max-concurrent-
0e50: 6a 6f 62 73 20 22 2c 20 6e 75 6d 2d 72 75 6e 6e jobs ", num-runn
0e60: 69 6e 67 3a 20 22 20 6e 75 6d 2d 72 75 6e 6e 69 ing: " num-runni
0e70: 6e 67 29 0a 09 20 20 28 73 65 74 21 20 2a 6c 61 ng).. (set! *la
0e80: 73 74 2d 6e 75 6d 2d 72 75 6e 6e 69 6e 67 2d 74 st-num-running-t
0e90: 65 73 74 73 2a 20 6e 75 6d 2d 72 75 6e 6e 69 6e ests* num-runnin
0ea0: 67 29 29 29 0a 20 20 20 20 28 69 66 20 28 6e 6f g))). (if (no
0eb0: 74 20 28 65 71 3f 20 30 20 2a 67 6c 6f 62 61 6c t (eq? 0 *global
0ec0: 65 78 69 74 73 74 61 74 75 73 2a 29 29 0a 09 23 exitstatus*))..#
0ed0: 66 0a 09 28 6c 65 74 20 28 28 63 61 6e 2d 6e 6f f..(let ((can-no
0ee0: 74 2d 72 75 6e 2d 6d 6f 72 65 20 28 63 6f 6e 64 t-run-more (cond
0ef0: 0a 09 09 09 09 20 3b 3b 20 69 66 20 6d 61 78 2d ..... ;; if max-
0f00: 63 6f 6e 63 75 72 72 65 6e 74 2d 6a 6f 62 73 20 concurrent-jobs
0f10: 69 73 20 73 65 74 20 61 6e 64 20 74 68 65 20 6e is set and the n
0f20: 75 6d 62 65 72 20 72 75 6e 6e 69 6e 67 20 69 73 umber running is
0f30: 20 67 72 65 61 74 65 72 20 0a 09 09 09 09 20 3b greater ..... ;
0f40: 3b 20 74 68 61 6e 20 69 74 20 74 68 61 6e 20 63 ; than it than c
0f50: 61 6e 6e 6f 74 20 72 75 6e 20 6d 6f 72 65 20 6a annot run more j
0f60: 6f 62 73 0a 09 09 09 09 20 28 28 61 6e 64 20 6d obs..... ((and m
0f70: 61 78 2d 63 6f 6e 63 75 72 72 65 6e 74 2d 6a 6f ax-concurrent-jo
0f80: 62 73 0a 09 09 09 09 20 20 20 20 20 20 20 28 73 bs..... (s
0f90: 74 72 69 6e 67 2d 3e 6e 75 6d 62 65 72 20 6d 61 tring->number ma
0fa0: 78 2d 63 6f 6e 63 75 72 72 65 6e 74 2d 6a 6f 62 x-concurrent-job
0fb0: 73 29 0a 09 09 09 09 20 20 20 20 20 20 20 28 3e s)..... (>
0fc0: 3d 20 6e 75 6d 2d 72 75 6e 6e 69 6e 67 20 28 73 = num-running (s
0fd0: 74 72 69 6e 67 2d 3e 6e 75 6d 62 65 72 20 6d 61 tring->number ma
0fe0: 78 2d 63 6f 6e 63 75 72 72 65 6e 74 2d 6a 6f 62 x-concurrent-job
0ff0: 73 29 29 29 0a 09 09 09 09 20 20 28 64 65 62 75 s)))..... (debu
1000: 67 3a 70 72 69 6e 74 20 30 20 22 57 41 52 4e 49 g:print 0 "WARNI
1010: 4e 47 3a 20 4d 61 78 20 72 75 6e 6e 69 6e 67 20 NG: Max running
1020: 6a 6f 62 73 20 65 78 63 65 65 64 65 64 2c 20 63 jobs exceeded, c
1030: 75 72 72 65 6e 74 20 6e 75 6d 62 65 72 20 72 75 urrent number ru
1040: 6e 6e 69 6e 67 3a 20 22 20 6e 75 6d 2d 72 75 6e nning: " num-run
1050: 6e 69 6e 67 20 0a 09 09 09 09 09 20 20 20 20 20 ning ......
1060: 20 20 22 2c 20 6d 61 78 5f 63 6f 6e 63 75 72 72 ", max_concurr
1070: 65 6e 74 5f 6a 6f 62 73 3a 20 22 20 6d 61 78 2d ent_jobs: " max-
1080: 63 6f 6e 63 75 72 72 65 6e 74 2d 6a 6f 62 73 29 concurrent-jobs)
1090: 0a 09 09 09 09 20 20 23 74 29 0a 09 09 09 09 20 ..... #t).....
10a0: 3b 3b 20 69 66 20 6a 6f 62 2d 67 72 6f 75 70 2d ;; if job-group-
10b0: 6c 69 6d 69 74 20 69 73 20 73 65 74 20 61 6e 64 limit is set and
10c0: 20 6e 75 6d 62 65 72 20 6f 66 20 6a 6f 62 73 20 number of jobs
10d0: 69 6e 20 74 68 65 20 67 72 6f 75 70 20 69 73 20 in the group is
10e0: 67 72 65 61 74 65 72 0a 09 09 09 09 20 3b 3b 20 greater..... ;;
10f0: 74 68 61 6e 20 74 68 65 20 6c 69 6d 69 74 20 74 than the limit t
1100: 68 65 6e 20 63 61 6e 6e 6f 74 20 72 75 6e 20 6d hen cannot run m
1110: 6f 72 65 20 6a 6f 62 73 20 6f 66 20 74 68 69 73 ore jobs of this
1120: 20 6b 69 6e 64 0a 09 09 09 09 20 28 28 61 6e 64 kind..... ((and
1130: 20 6a 6f 62 2d 67 72 6f 75 70 2d 6c 69 6d 69 74 job-group-limit
1140: 0a 09 09 09 09 20 20 20 20 20 20 20 28 3e 3d 20 ..... (>=
1150: 6e 75 6d 2d 72 75 6e 6e 69 6e 67 2d 69 6e 2d 6a num-running-in-j
1160: 6f 62 67 72 6f 75 70 20 6a 6f 62 2d 67 72 6f 75 obgroup job-grou
1170: 70 2d 6c 69 6d 69 74 29 29 0a 09 09 09 09 20 20 p-limit)).....
1180: 28 64 65 62 75 67 3a 70 72 69 6e 74 20 31 20 22 (debug:print 1 "
1190: 57 41 52 4e 49 4e 47 3a 20 6e 75 6d 62 65 72 20 WARNING: number
11a0: 6f 66 20 6a 6f 62 73 20 22 20 6e 75 6d 2d 72 75 of jobs " num-ru
11b0: 6e 6e 69 6e 67 2d 69 6e 2d 6a 6f 62 67 72 6f 75 nning-in-jobgrou
11c0: 70 20 0a 09 09 09 09 09 20 20 20 20 20 20 20 22 p ...... "
11d0: 20 69 6e 20 22 20 6a 6f 62 67 72 6f 75 70 20 22 in " jobgroup "
11e0: 20 65 78 63 65 65 64 65 64 2c 20 77 69 6c 6c 20 exceeded, will
11f0: 6e 6f 74 20 72 75 6e 20 22 20 28 74 65 73 74 73 not run " (tests
1200: 3a 74 65 73 74 71 75 65 75 65 2d 67 65 74 2d 74 :testqueue-get-t
1210: 65 73 74 6e 61 6d 65 20 74 65 73 74 2d 72 65 63 estname test-rec
1220: 6f 72 64 29 29 0a 09 09 09 09 20 20 23 74 29 0a ord))..... #t).
1230: 09 09 09 09 20 28 65 6c 73 65 20 23 66 29 29 29 .... (else #f)))
1240: 29 0a 09 20 20 28 6e 6f 74 20 63 61 6e 2d 6e 6f ).. (not can-no
1250: 74 2d 72 75 6e 2d 6d 6f 72 65 29 29 29 29 29 0a t-run-more))))).
1260: 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d .;;=============
1270: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1280: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 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 0a 3b 3b 20 4e 65 77 =========.;; New
12b0: 20 6d 65 74 68 6f 64 6f 6c 6f 67 79 2e 20 54 68 methodology. Th
12c0: 65 73 65 20 72 6f 75 74 69 6e 65 73 20 77 69 6c ese routines wil
12d0: 6c 20 72 65 70 6c 61 63 65 20 74 68 65 20 61 62 l replace the ab
12e0: 6f 76 65 20 69 6e 20 74 69 6d 65 2e 20 46 6f 72 ove in time. For
12f0: 0a 3b 3b 20 6e 6f 77 20 74 68 65 20 63 6f 64 65 .;; now the code
1300: 20 69 73 20 64 75 70 6c 69 63 61 74 65 64 2e 20 is duplicated.
1310: 54 68 69 73 20 73 74 75 66 66 20 69 73 20 69 6e This stuff is in
1320: 69 74 69 61 6c 6c 79 20 75 73 65 64 20 69 6e 20 itially used in
1330: 74 68 65 20 6d 6f 6e 69 74 6f 72 0a 3b 3b 20 62 the monitor.;; b
1340: 61 73 65 64 20 63 6f 64 65 2e 0a 3b 3b 3d 3d 3d ased code..;;===
1350: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1360: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1370: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1380: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1390: 3d 3d 3d 0a 0a 3b 3b 20 72 65 67 69 73 74 65 72 ===..;; register
13a0: 20 61 20 74 65 73 74 20 72 75 6e 20 77 69 74 68 a test run with
13b0: 20 74 68 65 20 64 62 0a 28 64 65 66 69 6e 65 20 the db.(define
13c0: 28 72 75 6e 73 3a 72 65 67 69 73 74 65 72 2d 72 (runs:register-r
13d0: 75 6e 20 64 62 20 6b 65 79 73 20 6b 65 79 76 61 un db keys keyva
13e0: 6c 6c 73 74 20 72 75 6e 6e 61 6d 65 20 73 74 61 llst runname sta
13f0: 74 65 20 73 74 61 74 75 73 20 75 73 65 72 29 0a te status user).
1400: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 33 (debug:print 3
1410: 20 22 72 75 6e 73 3a 72 65 67 69 73 74 65 72 2d "runs:register-
1420: 72 75 6e 2c 20 6b 65 79 73 3a 20 22 20 6b 65 79 run, keys: " key
1430: 73 20 22 20 6b 65 79 76 61 6c 6c 73 74 3a 20 22 s " keyvallst: "
1440: 20 6b 65 79 76 61 6c 6c 73 74 20 22 20 72 75 6e keyvallst " run
1450: 6e 61 6d 65 3a 20 22 20 72 75 6e 6e 61 6d 65 20 name: " runname
1460: 22 20 73 74 61 74 65 3a 20 22 20 73 74 61 74 65 " state: " state
1470: 20 22 20 73 74 61 74 75 73 3a 20 22 20 73 74 61 " status: " sta
1480: 74 75 73 20 22 20 75 73 65 72 3a 20 22 20 75 73 tus " user: " us
1490: 65 72 29 0a 20 20 28 6c 65 74 2a 20 28 28 6b 65 er). (let* ((ke
14a0: 79 73 74 72 20 20 20 20 28 6b 65 79 73 2d 3e 6b ystr (keys->k
14b0: 65 79 73 74 72 20 6b 65 79 73 29 29 0a 09 20 28 eystr keys)).. (
14c0: 63 6f 6d 6d 61 20 20 20 20 20 28 69 66 20 28 3e comma (if (>
14d0: 20 28 6c 65 6e 67 74 68 20 6b 65 79 73 29 20 30 (length keys) 0
14e0: 29 20 22 2c 22 20 22 22 29 29 0a 09 20 28 61 6e ) "," "")).. (an
14f0: 64 73 74 72 20 20 20 20 28 69 66 20 28 3e 20 28 dstr (if (> (
1500: 6c 65 6e 67 74 68 20 6b 65 79 73 29 20 30 29 20 length keys) 0)
1510: 22 20 41 4e 44 20 22 20 22 22 29 29 0a 09 20 28 " AND " "")).. (
1520: 76 61 6c 73 6c 6f 74 73 20 20 28 6b 65 79 73 2d valslots (keys-
1530: 3e 76 61 6c 73 6c 6f 74 73 20 6b 65 79 73 29 29 >valslots keys))
1540: 20 3b 3b 20 3f 2c 3f 2c 3f 20 2e 2e 2e 0a 09 20 ;; ?,?,? .....
1550: 28 6b 65 79 76 61 6c 73 20 20 20 28 6d 61 70 20 (keyvals (map
1560: 63 61 64 72 20 6b 65 79 76 61 6c 6c 73 74 29 29 cadr keyvallst))
1570: 0a 09 20 28 61 6c 6c 76 61 6c 73 20 20 20 28 61 .. (allvals (a
1580: 70 70 65 6e 64 20 28 6c 69 73 74 20 72 75 6e 6e ppend (list runn
1590: 61 6d 65 20 73 74 61 74 65 20 73 74 61 74 75 73 ame state status
15a0: 20 75 73 65 72 29 20 6b 65 79 76 61 6c 73 29 29 user) keyvals))
15b0: 0a 09 20 28 71 72 79 76 61 6c 73 20 20 20 28 61 .. (qryvals (a
15c0: 70 70 65 6e 64 20 28 6c 69 73 74 20 72 75 6e 6e ppend (list runn
15d0: 61 6d 65 29 20 6b 65 79 76 61 6c 73 29 29 0a 09 ame) keyvals))..
15e0: 20 28 6b 65 79 3d 3f 73 74 72 20 20 28 73 74 72 (key=?str (str
15f0: 69 6e 67 2d 69 6e 74 65 72 73 70 65 72 73 65 20 ing-intersperse
1600: 28 6d 61 70 20 28 6c 61 6d 62 64 61 20 28 6b 29 (map (lambda (k)
1610: 28 63 6f 6e 63 20 28 6b 65 79 3a 67 65 74 2d 66 (conc (key:get-f
1620: 69 65 6c 64 6e 61 6d 65 20 6b 29 20 22 3d 3f 22 ieldname k) "=?"
1630: 29 29 20 6b 65 79 73 29 20 22 20 41 4e 44 20 22 )) keys) " AND "
1640: 29 29 29 0a 20 20 20 20 28 64 65 62 75 67 3a 70 ))). (debug:p
1650: 72 69 6e 74 20 33 20 22 6b 65 79 73 3a 20 22 20 rint 3 "keys: "
1660: 6b 65 79 73 20 22 20 61 6c 6c 76 61 6c 73 3a 20 keys " allvals:
1670: 22 20 61 6c 6c 76 61 6c 73 20 22 20 6b 65 79 76 " allvals " keyv
1680: 61 6c 73 3a 20 22 20 6b 65 79 76 61 6c 73 29 0a als: " keyvals).
1690: 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 (debug:print
16a0: 20 32 20 22 4e 4f 54 45 3a 20 75 73 69 6e 67 20 2 "NOTE: using
16b0: 74 61 72 67 65 74 20 22 20 28 73 74 72 69 6e 67 target " (string
16c0: 2d 69 6e 74 65 72 73 70 65 72 73 65 20 6b 65 79 -intersperse key
16d0: 76 61 6c 73 20 22 2f 22 29 20 22 20 66 6f 72 20 vals "/") " for
16e0: 74 68 69 73 20 72 75 6e 22 29 0a 20 20 20 20 28 this run"). (
16f0: 69 66 20 28 61 6e 64 20 72 75 6e 6e 61 6d 65 20 if (and runname
1700: 28 6e 75 6c 6c 3f 20 28 66 69 6c 74 65 72 20 28 (null? (filter (
1710: 6c 61 6d 62 64 61 20 28 78 29 28 6e 6f 74 20 78 lambda (x)(not x
1720: 29 29 20 6b 65 79 76 61 6c 73 29 29 29 20 3b 3b )) keyvals))) ;;
1730: 20 74 68 65 72 65 20 6d 75 73 74 20 62 65 20 61 there must be a
1740: 20 62 65 74 74 65 72 20 77 61 79 20 74 6f 20 22 better way to "
1750: 61 70 70 6c 79 20 61 6e 64 22 0a 09 28 6c 65 74 apply and"..(let
1760: 20 28 28 72 65 73 20 23 66 29 29 0a 09 20 20 28 ((res #f)).. (
1770: 61 70 70 6c 79 20 73 71 6c 69 74 65 33 3a 65 78 apply sqlite3:ex
1780: 65 63 75 74 65 20 64 62 20 28 63 6f 6e 63 20 22 ecute db (conc "
1790: 49 4e 53 45 52 54 20 4f 52 20 49 47 4e 4f 52 45 INSERT OR IGNORE
17a0: 20 49 4e 54 4f 20 72 75 6e 73 20 28 72 75 6e 6e INTO runs (runn
17b0: 61 6d 65 2c 73 74 61 74 65 2c 73 74 61 74 75 73 ame,state,status
17c0: 2c 6f 77 6e 65 72 2c 65 76 65 6e 74 5f 74 69 6d ,owner,event_tim
17d0: 65 22 20 63 6f 6d 6d 61 20 6b 65 79 73 74 72 20 e" comma keystr
17e0: 22 29 20 56 41 4c 55 45 53 20 28 3f 2c 3f 2c 3f ") VALUES (?,?,?
17f0: 2c 3f 2c 73 74 72 66 74 69 6d 65 28 27 25 73 27 ,?,strftime('%s'
1800: 2c 27 6e 6f 77 27 29 22 20 63 6f 6d 6d 61 20 76 ,'now')" comma v
1810: 61 6c 73 6c 6f 74 73 20 22 29 3b 22 29 0a 09 09 alslots ");")...
1820: 20 61 6c 6c 76 61 6c 73 29 0a 09 20 20 28 61 70 allvals).. (ap
1830: 70 6c 79 20 73 71 6c 69 74 65 33 3a 66 6f 72 2d ply sqlite3:for-
1840: 65 61 63 68 2d 72 6f 77 20 0a 09 20 20 20 28 6c each-row .. (l
1850: 61 6d 62 64 61 20 28 69 64 29 0a 09 20 20 20 20 ambda (id)..
1860: 20 28 73 65 74 21 20 72 65 73 20 69 64 29 29 0a (set! res id)).
1870: 09 20 20 20 64 62 0a 09 20 20 20 28 6c 65 74 20 . db.. (let
1880: 28 28 71 72 79 20 28 63 6f 6e 63 20 22 53 45 4c ((qry (conc "SEL
1890: 45 43 54 20 69 64 20 46 52 4f 4d 20 72 75 6e 73 ECT id FROM runs
18a0: 20 57 48 45 52 45 20 28 72 75 6e 6e 61 6d 65 3d WHERE (runname=
18b0: 3f 20 22 20 61 6e 64 73 74 72 20 6b 65 79 3d 3f ? " andstr key=?
18c0: 73 74 72 20 22 29 3b 22 29 29 29 0a 09 20 20 20 str ");")))..
18d0: 20 20 3b 28 64 65 62 75 67 3a 70 72 69 6e 74 20 ;(debug:print
18e0: 34 20 22 71 72 79 3a 20 22 20 71 72 79 29 20 0a 4 "qry: " qry) .
18f0: 09 20 20 20 20 20 71 72 79 29 0a 09 20 20 20 71 . qry).. q
1900: 72 79 76 61 6c 73 29 0a 09 20 20 28 73 71 6c 69 ryvals).. (sqli
1910: 74 65 33 3a 65 78 65 63 75 74 65 20 64 62 20 22 te3:execute db "
1920: 55 50 44 41 54 45 20 72 75 6e 73 20 53 45 54 20 UPDATE runs SET
1930: 73 74 61 74 65 3d 3f 2c 73 74 61 74 75 73 3d 3f state=?,status=?
1940: 20 57 48 45 52 45 20 69 64 3d 3f 3b 22 20 73 74 WHERE id=?;" st
1950: 61 74 65 20 73 74 61 74 75 73 20 72 65 73 29 0a ate status res).
1960: 09 20 20 72 65 73 29 20 0a 09 28 62 65 67 69 6e . res) ..(begin
1970: 0a 09 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 .. (debug:print
1980: 20 30 20 22 45 52 52 4f 52 3a 20 43 61 6c 6c 65 0 "ERROR: Calle
1990: 64 20 77 69 74 68 6f 75 74 20 61 6c 6c 20 6e 65 d without all ne
19a0: 63 65 73 73 61 72 79 20 6b 65 79 73 22 29 0a 09 cessary keys")..
19b0: 20 20 23 66 29 29 29 29 0a 0a 3b 3b 20 54 68 69 #f))))..;; Thi
19c0: 73 20 69 73 20 61 20 64 75 70 6c 69 63 61 74 65 s is a duplicate
19d0: 20 6f 66 20 72 75 6e 2d 74 65 73 74 73 20 28 77 of run-tests (w
19e0: 68 69 63 68 20 68 61 73 20 62 65 65 6e 20 64 65 hich has been de
19f0: 70 72 65 63 61 74 65 64 29 2e 20 55 73 65 20 74 precated). Use t
1a00: 68 69 73 20 6f 6e 65 20 69 6e 73 74 65 61 64 20 his one instead
1a10: 6f 66 20 72 75 6e 20 74 65 73 74 73 2e 0a 3b 3b of run tests..;;
1a20: 20 6b 65 79 76 61 6c 73 0a 28 64 65 66 69 6e 65 keyvals.(define
1a30: 20 28 72 75 6e 73 3a 72 75 6e 2d 74 65 73 74 73 (runs:run-tests
1a40: 20 64 62 20 74 61 72 67 65 74 20 72 75 6e 6e 61 db target runna
1a50: 6d 65 20 74 65 73 74 2d 70 61 74 74 73 20 75 73 me test-patts us
1a60: 65 72 20 66 6c 61 67 73 29 0a 20 20 28 6c 65 74 er flags). (let
1a70: 2a 20 28 28 6b 65 79 73 20 20 20 20 20 20 20 20 * ((keys
1a80: 28 72 64 62 3a 67 65 74 2d 6b 65 79 73 20 64 62 (rdb:get-keys db
1a90: 29 29 0a 09 20 28 6b 65 79 76 61 6c 6c 73 74 20 )).. (keyvallst
1aa0: 20 20 28 6b 65 79 73 3a 74 61 72 67 65 74 2d 3e (keys:target->
1ab0: 6b 65 79 76 61 6c 20 6b 65 79 73 20 74 61 72 67 keyval keys targ
1ac0: 65 74 29 29 0a 09 20 28 72 75 6e 2d 69 64 20 20 et)).. (run-id
1ad0: 20 20 20 20 28 72 75 6e 73 3a 72 65 67 69 73 74 (runs:regist
1ae0: 65 72 2d 72 75 6e 20 64 62 20 6b 65 79 73 20 6b er-run db keys k
1af0: 65 79 76 61 6c 6c 73 74 20 72 75 6e 6e 61 6d 65 eyvallst runname
1b00: 20 22 6e 65 77 22 20 22 6e 2f 61 22 20 75 73 65 "new" "n/a" use
1b10: 72 29 29 20 20 3b 3b 20 20 74 65 73 74 2d 6e 61 r)) ;; test-na
1b20: 6d 65 29 29 29 0a 09 20 28 64 65 66 65 72 72 65 me))).. (deferre
1b30: 64 20 20 20 20 27 28 29 29 20 3b 3b 20 64 65 6c d '()) ;; del
1b40: 61 79 20 72 75 6e 6e 69 6e 67 20 74 68 65 73 65 ay running these
1b50: 20 73 69 6e 63 65 20 74 68 65 79 20 68 61 76 65 since they have
1b60: 20 61 20 77 61 69 74 6f 6e 20 63 6c 61 75 73 65 a waiton clause
1b70: 0a 09 20 3b 3b 20 6b 65 65 70 67 6f 69 6e 67 20 .. ;; keepgoing
1b80: 69 73 20 74 68 65 20 64 65 66 61 63 74 6f 20 6d is the defacto m
1b90: 6f 64 61 6c 69 74 79 20 6e 6f 77 2c 20 77 69 6c odality now, wil
1ba0: 6c 20 61 64 64 20 68 69 74 2d 6e 2d 72 75 6e 20 l add hit-n-run
1bb0: 61 20 62 69 74 20 6c 61 74 65 72 0a 09 20 3b 3b a bit later.. ;;
1bc0: 20 28 6b 65 65 70 67 6f 69 6e 67 20 20 20 28 68 (keepgoing (h
1bd0: 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 ash-table-ref/de
1be0: 66 61 75 6c 74 20 66 6c 61 67 73 20 22 2d 6b 65 fault flags "-ke
1bf0: 65 70 67 6f 69 6e 67 22 20 23 66 29 29 0a 09 20 epgoing" #f))..
1c00: 28 74 65 73 74 2d 6e 61 6d 65 73 20 20 27 28 29 (test-names '()
1c10: 29 0a 09 20 28 72 75 6e 63 6f 6e 66 69 67 66 20 ).. (runconfigf
1c20: 20 20 28 63 6f 6e 63 20 20 2a 74 6f 70 70 61 74 (conc *toppat
1c30: 68 2a 20 22 2f 72 75 6e 63 6f 6e 66 69 67 73 2e h* "/runconfigs.
1c40: 63 6f 6e 66 69 67 22 29 29 0a 09 20 28 72 65 71 config")).. (req
1c50: 75 69 72 65 64 2d 74 65 73 74 73 20 27 28 29 29 uired-tests '())
1c60: 0a 09 20 28 74 65 73 74 2d 72 65 63 6f 72 64 73 .. (test-records
1c70: 20 28 6d 61 6b 65 2d 68 61 73 68 2d 74 61 62 6c (make-hash-tabl
1c80: 65 29 29 29 0a 0a 20 20 20 20 28 73 65 74 2d 6d e))).. (set-m
1c90: 65 67 61 74 65 73 74 2d 65 6e 76 2d 76 61 72 73 egatest-env-vars
1ca0: 20 64 62 20 72 75 6e 2d 69 64 29 20 3b 3b 20 74 db run-id) ;; t
1cb0: 68 65 73 65 20 6d 61 79 20 62 65 20 6e 65 65 64 hese may be need
1cc0: 65 64 20 62 79 20 74 68 65 20 6c 61 75 6e 63 68 ed by the launch
1cd0: 69 6e 67 20 70 72 6f 63 65 73 73 0a 0a 20 20 20 ing process..
1ce0: 20 28 69 66 20 28 66 69 6c 65 2d 65 78 69 73 74 (if (file-exist
1cf0: 73 3f 20 72 75 6e 63 6f 6e 66 69 67 66 29 0a 09 s? runconfigf)..
1d00: 28 73 65 74 75 70 2d 65 6e 76 2d 64 65 66 61 75 (setup-env-defau
1d10: 6c 74 73 20 64 62 20 72 75 6e 63 6f 6e 66 69 67 lts db runconfig
1d20: 66 20 72 75 6e 2d 69 64 20 2a 61 6c 72 65 61 64 f run-id *alread
1d30: 79 2d 73 65 65 6e 2d 72 75 6e 63 6f 6e 66 69 67 y-seen-runconfig
1d40: 2d 69 6e 66 6f 2a 20 22 70 72 65 2d 6c 61 75 6e -info* "pre-laun
1d50: 63 68 2d 65 6e 76 2d 76 61 72 73 22 29 0a 09 28 ch-env-vars")..(
1d60: 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 22 57 debug:print 0 "W
1d70: 41 52 4e 49 4e 47 3a 20 59 6f 75 20 64 6f 20 6e ARNING: You do n
1d80: 6f 74 20 68 61 76 65 20 61 20 72 75 6e 20 63 6f ot have a run co
1d90: 6e 66 69 67 20 66 69 6c 65 3a 20 22 20 72 75 6e nfig file: " run
1da0: 63 6f 6e 66 69 67 66 29 29 0a 20 20 20 20 0a 20 configf)). .
1db0: 20 20 20 3b 3b 20 6c 6f 6f 6b 20 75 70 20 61 6c ;; look up al
1dc0: 6c 20 74 65 73 74 73 20 6d 61 74 63 68 69 6e 67 l tests matching
1dd0: 20 74 68 65 20 63 6f 6d 6d 61 20 73 65 70 61 72 the comma separ
1de0: 61 74 65 64 20 6c 69 73 74 20 6f 66 20 67 6c 6f ated list of glo
1df0: 62 73 20 69 6e 0a 20 20 20 20 3b 3b 20 74 65 73 bs in. ;; tes
1e00: 74 2d 70 61 74 74 73 20 28 75 73 69 6e 67 20 25 t-patts (using %
1e10: 20 61 73 20 77 69 6c 64 63 61 72 64 29 0a 20 20 as wildcard).
1e20: 20 20 28 66 6f 72 2d 65 61 63 68 20 0a 20 20 20 (for-each .
1e30: 20 20 28 6c 61 6d 62 64 61 20 28 70 61 74 74 29 (lambda (patt)
1e40: 0a 20 20 20 20 20 20 20 28 6c 65 74 20 28 28 74 . (let ((t
1e50: 65 73 74 73 20 28 67 6c 6f 62 20 28 63 6f 6e 63 ests (glob (conc
1e60: 20 2a 74 6f 70 70 61 74 68 2a 20 22 2f 74 65 73 *toppath* "/tes
1e70: 74 73 2f 22 20 28 73 74 72 69 6e 67 2d 74 72 61 ts/" (string-tra
1e80: 6e 73 6c 61 74 65 20 70 61 74 74 20 22 25 22 20 nslate patt "%"
1e90: 22 2a 22 29 29 29 29 29 0a 09 20 28 73 65 74 21 "*"))))).. (set!
1ea0: 20 74 65 73 74 73 20 28 66 69 6c 74 65 72 20 28 tests (filter (
1eb0: 6c 61 6d 62 64 61 20 28 74 65 73 74 29 28 66 69 lambda (test)(fi
1ec0: 6c 65 2d 65 78 69 73 74 73 3f 20 28 63 6f 6e 63 le-exists? (conc
1ed0: 20 74 65 73 74 20 22 2f 74 65 73 74 63 6f 6e 66 test "/testconf
1ee0: 69 67 22 29 29 29 20 74 65 73 74 73 29 29 0a 09 ig"))) tests))..
1ef0: 20 28 73 65 74 21 20 74 65 73 74 2d 6e 61 6d 65 (set! test-name
1f00: 73 20 28 61 70 70 65 6e 64 20 74 65 73 74 2d 6e s (append test-n
1f10: 61 6d 65 73 20 0a 09 09 09 09 20 20 28 6d 61 70 ames ..... (map
1f20: 20 28 6c 61 6d 62 64 61 20 28 74 65 73 74 70 29 (lambda (testp)
1f30: 0a 09 09 09 09 09 20 28 6c 61 73 74 20 28 73 74 ...... (last (st
1f40: 72 69 6e 67 2d 73 70 6c 69 74 20 74 65 73 74 70 ring-split testp
1f50: 20 22 2f 22 29 29 29 0a 09 09 09 09 20 20 20 20 "/"))).....
1f60: 20 20 20 74 65 73 74 73 29 29 29 29 29 0a 20 20 tests))))).
1f70: 20 20 20 28 69 66 20 74 65 73 74 2d 70 61 74 74 (if test-patt
1f80: 73 20 28 73 74 72 69 6e 67 2d 73 70 6c 69 74 20 s (string-split
1f90: 74 65 73 74 2d 70 61 74 74 73 20 22 2c 22 29 28 test-patts ",")(
1fa0: 6c 69 73 74 20 22 25 22 29 29 29 0a 0a 20 20 20 list "%")))..
1fb0: 20 20 3b 3b 20 6e 6f 77 20 72 65 6d 6f 76 65 20 ;; now remove
1fc0: 64 75 70 6c 69 63 61 74 65 73 0a 20 20 20 20 28 duplicates. (
1fd0: 73 65 74 21 20 74 65 73 74 2d 6e 61 6d 65 73 20 set! test-names
1fe0: 28 64 65 6c 65 74 65 2d 64 75 70 6c 69 63 61 74 (delete-duplicat
1ff0: 65 73 20 74 65 73 74 2d 6e 61 6d 65 73 29 29 0a es test-names)).
2000: 0a 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e . (debug:prin
2010: 74 20 30 20 22 49 4e 46 4f 3a 20 74 65 73 74 20 t 0 "INFO: test
2020: 6e 61 6d 65 73 20 22 20 74 65 73 74 2d 6e 61 6d names " test-nam
2030: 65 73 29 0a 0a 20 20 20 20 3b 3b 20 6f 6e 20 74 es).. ;; on t
2040: 68 65 20 66 69 72 73 74 20 70 61 73 73 20 6f 72 he first pass or
2050: 20 63 61 6c 6c 20 74 6f 20 72 75 6e 2d 74 65 73 call to run-tes
2060: 74 73 20 73 65 74 20 46 41 49 4c 53 20 74 6f 20 ts set FAILS to
2070: 4e 4f 54 5f 53 54 41 52 54 45 44 20 69 66 0a 20 NOT_STARTED if.
2080: 20 20 20 3b 3b 20 2d 6b 65 65 70 67 6f 69 6e 67 ;; -keepgoing
2090: 20 69 73 20 73 70 65 63 69 66 69 65 64 0a 20 20 is specified.
20a0: 20 20 28 69 66 20 28 65 71 3f 20 2a 70 61 73 73 (if (eq? *pass
20b0: 6e 75 6d 2a 20 30 29 0a 09 28 62 65 67 69 6e 0a num* 0)..(begin.
20c0: 09 20 20 3b 3b 20 68 61 76 65 20 74 6f 20 64 65 . ;; have to de
20d0: 6c 65 74 65 20 74 65 73 74 20 72 65 63 6f 72 64 lete test record
20e0: 73 20 77 68 65 72 65 20 4e 4f 54 5f 53 54 41 52 s where NOT_STAR
20f0: 54 45 44 20 73 69 6e 63 65 20 74 68 65 79 20 63 TED since they c
2100: 61 6e 20 63 61 75 73 65 20 2d 6b 65 65 70 67 6f an cause -keepgo
2110: 69 6e 67 20 74 6f 20 0a 09 20 20 3b 3b 20 67 65 ing to .. ;; ge
2120: 74 20 73 74 75 63 6b 20 64 75 65 20 74 6f 20 62 t stuck due to b
2130: 65 63 6f 6d 69 6e 67 20 69 6e 61 63 63 65 73 73 ecoming inaccess
2140: 69 62 6c 65 20 66 72 6f 6d 20 61 20 66 61 69 6c ible from a fail
2150: 65 64 20 74 65 73 74 2e 20 49 2e 65 2e 20 69 66 ed test. I.e. if
2160: 20 74 65 73 74 20 42 20 64 65 70 65 6e 64 73 20 test B depends
2170: 0a 09 20 20 3b 3b 20 6f 6e 20 74 65 73 74 20 41 .. ;; on test A
2180: 20 62 75 74 20 74 65 73 74 20 42 20 72 65 61 63 but test B reac
2190: 68 65 64 20 74 68 65 20 70 6f 69 6e 74 20 6f 6e hed the point on
21a0: 20 62 65 69 6e 67 20 72 65 67 69 73 74 65 72 65 being registere
21b0: 64 20 61 73 20 4e 4f 54 5f 53 54 41 52 54 45 44 d as NOT_STARTED
21c0: 20 61 6e 64 20 74 65 73 74 0a 09 20 20 3b 3b 20 and test.. ;;
21d0: 41 20 66 61 69 6c 65 64 20 66 6f 72 20 73 6f 6d A failed for som
21e0: 65 20 72 65 61 73 6f 6e 20 74 68 65 6e 20 6f 6e e reason then on
21f0: 20 72 65 2d 72 75 6e 20 75 73 69 6e 67 20 2d 6b re-run using -k
2200: 65 65 70 67 6f 69 6e 67 20 74 68 65 20 72 75 6e eepgoing the run
2210: 20 63 61 6e 20 6e 65 76 65 72 20 63 6f 6d 70 6c can never compl
2220: 65 74 65 2e 0a 09 20 20 28 64 62 3a 64 65 6c 65 ete... (db:dele
2230: 74 65 2d 74 65 73 74 73 2d 69 6e 2d 73 74 61 74 te-tests-in-stat
2240: 65 20 64 62 20 72 75 6e 2d 69 64 20 22 4e 4f 54 e db run-id "NOT
2250: 5f 53 54 41 52 54 45 44 22 29 0a 09 20 20 28 72 _STARTED").. (r
2260: 64 62 3a 73 65 74 2d 74 65 73 74 73 2d 73 74 61 db:set-tests-sta
2270: 74 65 2d 73 74 61 74 75 73 20 64 62 20 72 75 6e te-status db run
2280: 2d 69 64 20 74 65 73 74 2d 6e 61 6d 65 73 20 23 -id test-names #
2290: 66 20 22 46 41 49 4c 22 20 22 4e 4f 54 5f 53 54 f "FAIL" "NOT_ST
22a0: 41 52 54 45 44 22 20 22 46 41 49 4c 22 29 29 29 ARTED" "FAIL")))
22b0: 0a 0a 20 20 20 20 3b 3b 20 66 72 6f 6d 20 68 65 .. ;; from he
22c0: 72 65 20 6f 6e 20 6f 75 74 20 74 68 65 20 64 62 re on out the db
22d0: 20 77 69 6c 6c 20 62 65 20 6f 70 65 6e 65 64 20 will be opened
22e0: 61 6e 64 20 63 6c 6f 73 65 64 20 6f 6e 20 65 76 and closed on ev
22f0: 65 72 79 20 63 61 6c 6c 20 72 75 6e 73 3a 72 75 ery call runs:ru
2300: 6e 2d 74 65 73 74 73 2d 71 75 65 75 65 0a 20 20 n-tests-queue.
2310: 20 20 28 73 71 6c 69 74 65 33 3a 66 69 6e 61 6c (sqlite3:final
2320: 69 7a 65 21 20 64 62 29 20 0a 20 20 20 20 3b 3b ize! db) . ;;
2330: 20 6e 6f 77 20 61 64 64 20 6e 6f 6e 2d 64 69 72 now add non-dir
2340: 65 63 74 6c 79 20 72 65 66 65 72 65 6e 63 65 64 ectly referenced
2350: 20 64 65 70 65 6e 64 65 6e 63 69 65 73 20 28 69 dependencies (i
2360: 2e 65 2e 20 77 61 69 74 6f 6e 29 0a 20 20 20 20 .e. waiton).
2370: 28 69 66 20 28 6e 6f 74 20 28 6e 75 6c 6c 3f 20 (if (not (null?
2380: 74 65 73 74 2d 6e 61 6d 65 73 29 29 0a 09 28 6c test-names))..(l
2390: 65 74 20 6c 6f 6f 70 20 28 28 68 65 64 20 28 63 et loop ((hed (c
23a0: 61 72 20 74 65 73 74 2d 6e 61 6d 65 73 29 29 0a ar test-names)).
23b0: 09 09 20 20 20 28 74 61 6c 20 28 63 64 72 20 74 .. (tal (cdr t
23c0: 65 73 74 2d 6e 61 6d 65 73 29 29 29 20 20 20 20 est-names)))
23d0: 20 20 20 20 20 3b 3b 20 27 72 65 74 75 72 6e 2d ;; 'return-
23e0: 70 72 6f 63 73 20 74 65 6c 6c 73 20 74 68 65 20 procs tells the
23f0: 63 6f 6e 66 69 67 20 72 65 61 64 65 72 20 74 6f config reader to
2400: 20 70 72 65 70 20 72 75 6e 6e 69 6e 67 20 73 79 prep running sy
2410: 73 74 65 6d 20 62 75 74 20 72 65 74 75 72 6e 20 stem but return
2420: 61 20 70 72 6f 63 0a 09 20 20 28 64 65 62 75 67 a proc.. (debug
2430: 3a 70 72 69 6e 74 20 34 20 22 49 4e 46 4f 3a 20 :print 4 "INFO:
2440: 68 65 64 3d 22 20 68 65 64 20 22 20 61 74 20 74 hed=" hed " at t
2450: 6f 70 20 6f 66 20 6c 6f 6f 70 22 29 0a 09 20 20 op of loop")..
2460: 28 6c 65 74 2a 20 28 28 63 6f 6e 66 69 67 20 20 (let* ((config
2470: 28 74 65 73 74 73 3a 67 65 74 2d 74 65 73 74 63 (tests:get-testc
2480: 6f 6e 66 69 67 20 68 65 64 20 27 72 65 74 75 72 onfig hed 'retur
2490: 6e 2d 70 72 6f 63 73 29 29 0a 09 09 20 28 77 61 n-procs))... (wa
24a0: 69 74 6f 6e 73 20 28 69 66 20 63 6f 6e 66 69 67 itons (if config
24b0: 20 28 73 74 72 69 6e 67 2d 73 70 6c 69 74 20 28 (string-split (
24c0: 6c 65 74 20 28 28 77 20 28 63 6f 6e 66 69 67 2d let ((w (config-
24d0: 6c 6f 6f 6b 75 70 20 63 6f 6e 66 69 67 20 22 72 lookup config "r
24e0: 65 71 75 69 72 65 6d 65 6e 74 73 22 20 22 77 61 equirements" "wa
24f0: 69 74 6f 6e 22 29 29 29 0a 09 09 09 09 09 09 20 iton"))).......
2500: 20 20 20 20 28 69 66 20 77 20 77 20 22 22 29 29 (if w w ""))
2510: 29 0a 09 09 09 20 20 20 20 20 20 28 62 65 67 69 ).... (begi
2520: 6e 0a 09 09 09 09 28 64 65 62 75 67 3a 70 72 69 n.....(debug:pri
2530: 6e 74 20 30 20 22 45 52 52 4f 52 3a 20 6e 6f 6e nt 0 "ERROR: non
2540: 2d 65 78 69 73 74 65 6e 74 20 72 65 71 75 69 72 -existent requir
2550: 65 64 20 74 65 73 74 20 5c 22 22 20 68 65 64 20 ed test \"" hed
2560: 22 5c 22 22 29 0a 20 20 20 20 20 20 20 20 20 20 "\"").
2570: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2580: 20 20 20 20 20 20 28 73 71 6c 69 74 65 33 3a 66 (sqlite3:f
2590: 69 6e 61 6c 69 7a 65 21 20 64 62 29 0a 09 09 09 inalize! db)....
25a0: 09 28 65 78 69 74 20 31 29 29 29 29 29 0a 09 20 .(exit 1)))))..
25b0: 20 20 20 3b 3b 20 63 68 65 63 6b 20 66 6f 72 20 ;; check for
25c0: 68 65 64 20 69 6e 20 77 61 69 74 6f 6e 73 20 3d hed in waitons =
25d0: 3e 20 74 68 69 73 20 77 6f 75 6c 64 20 62 65 20 > this would be
25e0: 63 69 72 63 75 6c 61 72 2c 20 72 65 6d 6f 76 65 circular, remove
25f0: 20 69 74 20 61 6e 64 20 69 73 73 75 65 20 61 6e it and issue an
2600: 0a 09 20 20 20 20 3b 3b 20 65 72 72 6f 72 0a 09 .. ;; error..
2610: 20 20 20 20 28 69 66 20 28 6d 65 6d 62 65 72 20 (if (member
2620: 68 65 64 20 77 61 69 74 6f 6e 73 29 0a 09 09 28 hed waitons)...(
2630: 62 65 67 69 6e 0a 09 09 20 20 28 64 65 62 75 67 begin... (debug
2640: 3a 70 72 69 6e 74 20 30 20 22 45 52 52 4f 52 3a :print 0 "ERROR:
2650: 20 74 65 73 74 20 22 20 68 65 64 20 22 20 68 61 test " hed " ha
2660: 73 20 6c 69 73 74 65 64 20 69 74 73 65 6c 66 20 s listed itself
2670: 61 73 20 61 20 77 61 69 74 6f 6e 2c 20 70 6c 65 as a waiton, ple
2680: 61 73 65 20 63 6f 72 72 65 63 74 20 74 68 69 73 ase correct this
2690: 21 22 29 0a 09 09 20 20 28 73 65 74 21 20 77 61 !")... (set! wa
26a0: 69 74 6f 6e 73 20 28 66 69 6c 74 65 72 20 28 6c itons (filter (l
26b0: 61 6d 62 64 61 20 28 78 29 28 6e 6f 74 20 28 65 ambda (x)(not (e
26c0: 71 75 61 6c 3f 20 78 20 68 65 64 29 29 29 20 77 qual? x hed))) w
26d0: 61 69 74 6f 6e 73 29 29 29 29 0a 09 20 20 20 20 aitons))))..
26e0: 0a 09 20 20 20 20 3b 3b 20 28 69 74 65 6d 73 20 .. ;; (items
26f0: 20 20 28 69 74 65 6d 73 3a 67 65 74 2d 69 74 65 (items:get-ite
2700: 6d 73 2d 66 72 6f 6d 2d 63 6f 6e 66 69 67 20 63 ms-from-config c
2710: 6f 6e 66 69 67 29 29 29 0a 09 20 20 20 20 28 69 onfig))).. (i
2720: 66 20 28 6e 6f 74 20 28 68 61 73 68 2d 74 61 62 f (not (hash-tab
2730: 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 74 le-ref/default t
2740: 65 73 74 2d 72 65 63 6f 72 64 73 20 68 65 64 20 est-records hed
2750: 23 66 29 29 0a 09 09 28 68 61 73 68 2d 74 61 62 #f))...(hash-tab
2760: 6c 65 2d 73 65 74 21 20 74 65 73 74 2d 72 65 63 le-set! test-rec
2770: 6f 72 64 73 0a 09 09 09 09 20 68 65 64 20 28 76 ords..... hed (v
2780: 65 63 74 6f 72 20 68 65 64 20 20 20 20 20 3b 3b ector hed ;;
2790: 20 30 0a 09 09 09 09 09 20 20 20 20 20 63 6f 6e 0...... con
27a0: 66 69 67 20 20 3b 3b 20 31 0a 09 09 09 09 09 20 fig ;; 1......
27b0: 20 20 20 20 77 61 69 74 6f 6e 73 20 3b 3b 20 32 waitons ;; 2
27c0: 0a 09 09 09 09 09 20 20 20 20 20 28 63 6f 6e 66 ...... (conf
27d0: 69 67 2d 6c 6f 6f 6b 75 70 20 63 6f 6e 66 69 67 ig-lookup config
27e0: 20 22 72 65 71 75 69 72 65 6d 65 6e 74 73 22 20 "requirements"
27f0: 22 70 72 69 6f 72 69 74 79 22 29 20 20 20 20 20 "priority")
2800: 3b 3b 20 70 72 69 6f 72 69 74 79 20 33 0a 09 09 ;; priority 3...
2810: 09 09 09 20 20 20 20 20 28 6c 65 74 20 28 28 69 ... (let ((i
2820: 74 65 6d 73 20 20 20 20 20 20 28 68 61 73 68 2d tems (hash-
2830: 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c table-ref/defaul
2840: 74 20 63 6f 6e 66 69 67 20 22 69 74 65 6d 73 22 t config "items"
2850: 20 23 66 29 29 20 3b 3b 20 69 74 65 6d 73 20 34 #f)) ;; items 4
2860: 0a 09 09 09 09 09 09 20 20 20 28 69 74 65 6d 73 ....... (items
2870: 74 61 62 6c 65 20 28 68 61 73 68 2d 74 61 62 6c table (hash-tabl
2880: 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 63 6f e-ref/default co
2890: 6e 66 69 67 20 22 69 74 65 6d 73 74 61 62 6c 65 nfig "itemstable
28a0: 22 20 23 66 29 29 29 20 0a 09 09 09 09 09 20 20 " #f))) ......
28b0: 20 20 20 20 20 3b 3b 20 69 66 20 65 69 74 68 65 ;; if eithe
28c0: 72 20 69 74 65 6d 73 20 6f 72 20 69 74 65 6d 73 r items or items
28d0: 20 74 61 62 6c 65 20 69 73 20 61 20 70 72 6f 63 table is a proc
28e0: 20 72 65 74 75 72 6e 20 69 74 20 73 6f 20 74 65 return it so te
28f0: 73 74 20 72 75 6e 6e 69 6e 67 0a 09 09 09 09 09 st running......
2900: 20 20 20 20 20 20 20 3b 3b 20 70 72 6f 63 65 73 ;; proces
2910: 73 20 63 61 6e 20 6b 6e 6f 77 20 74 6f 20 63 61 s can know to ca
2920: 6c 6c 20 69 74 65 6d 73 3a 67 65 74 2d 69 74 65 ll items:get-ite
2930: 6d 73 2d 66 72 6f 6d 2d 63 6f 6e 66 69 67 0a 09 ms-from-config..
2940: 09 09 09 09 20 20 20 20 20 20 20 3b 3b 20 69 66 .... ;; if
2950: 20 65 69 74 68 65 72 20 69 73 20 61 20 6c 69 73 either is a lis
2960: 74 20 61 6e 64 20 6e 6f 6e 65 20 69 73 20 61 20 t and none is a
2970: 70 72 6f 63 20 67 6f 20 61 68 65 61 64 20 61 6e proc go ahead an
2980: 64 20 63 61 6c 6c 20 67 65 74 2d 69 74 65 6d 73 d call get-items
2990: 0a 09 09 09 09 09 20 20 20 20 20 20 20 3b 3b 20 ...... ;;
29a0: 6f 74 68 65 72 77 69 73 65 20 72 65 74 75 72 6e otherwise return
29b0: 20 23 66 20 2d 20 74 68 69 73 20 69 73 20 6e 6f #f - this is no
29c0: 74 20 61 6e 20 69 74 65 72 61 74 65 64 20 74 65 t an iterated te
29d0: 73 74 0a 09 09 09 09 09 20 20 20 20 20 20 20 28 st...... (
29e0: 63 6f 6e 64 0a 09 09 09 09 09 09 28 28 70 72 6f cond.......((pro
29f0: 63 65 64 75 72 65 3f 20 69 74 65 6d 73 29 20 20 cedure? items)
2a00: 20 20 20 20 0a 09 09 09 09 09 09 20 28 64 65 62 ....... (deb
2a10: 75 67 3a 70 72 69 6e 74 20 34 20 22 49 4e 46 4f ug:print 4 "INFO
2a20: 3a 20 69 74 65 6d 73 20 69 73 20 61 20 70 72 6f : items is a pro
2a30: 63 65 64 75 72 65 2c 20 77 69 6c 6c 20 63 61 6c cedure, will cal
2a40: 63 20 6c 61 74 65 72 22 29 0a 09 09 09 09 09 09 c later").......
2a50: 20 69 74 65 6d 73 29 20 20 20 20 20 20 20 20 20 items)
2a60: 20 20 20 3b 3b 20 63 61 6c 63 20 6c 61 74 65 72 ;; calc later
2a70: 0a 09 09 09 09 09 09 28 28 70 72 6f 63 65 64 75 .......((procedu
2a80: 72 65 3f 20 69 74 65 6d 73 74 61 62 6c 65 29 0a re? itemstable).
2a90: 09 09 09 09 09 09 20 28 64 65 62 75 67 3a 70 72 ...... (debug:pr
2aa0: 69 6e 74 20 34 20 22 49 4e 46 4f 3a 20 69 74 65 int 4 "INFO: ite
2ab0: 6d 73 74 61 62 6c 65 20 69 73 20 61 20 70 72 6f mstable is a pro
2ac0: 63 65 64 75 72 65 2c 20 77 69 6c 6c 20 63 61 6c cedure, will cal
2ad0: 63 20 6c 61 74 65 72 22 29 0a 09 09 09 09 09 09 c later").......
2ae0: 20 69 74 65 6d 73 74 61 62 6c 65 29 20 20 20 20 itemstable)
2af0: 20 20 20 3b 3b 20 63 61 6c 63 20 6c 61 74 65 72 ;; calc later
2b00: 0a 09 09 09 09 09 09 28 28 66 69 6c 74 65 72 20 .......((filter
2b10: 28 6c 61 6d 62 64 61 20 28 78 29 0a 09 09 09 09 (lambda (x).....
2b20: 09 09 09 20 20 20 28 6c 65 74 20 28 28 76 61 6c ... (let ((val
2b30: 20 28 63 61 72 20 78 29 29 29 0a 09 09 09 09 09 (car x)))......
2b40: 09 09 20 20 20 20 20 28 69 66 20 28 70 72 6f 63 .. (if (proc
2b50: 65 64 75 72 65 3f 20 76 61 6c 29 20 76 61 6c 20 edure? val) val
2b60: 23 66 29 29 29 0a 09 09 09 09 09 09 09 20 28 61 #f)))........ (a
2b70: 70 70 65 6e 64 20 28 69 66 20 28 6c 69 73 74 3f ppend (if (list?
2b80: 20 69 74 65 6d 73 29 20 69 74 65 6d 73 20 27 28 items) items '(
2b90: 29 29 0a 09 09 09 09 09 09 09 09 20 28 69 66 20 ))......... (if
2ba0: 28 6c 69 73 74 3f 20 69 74 65 6d 73 74 61 62 6c (list? itemstabl
2bb0: 65 29 20 69 74 65 6d 73 74 61 62 6c 65 20 27 28 e) itemstable '(
2bc0: 29 29 29 29 0a 09 09 09 09 09 09 20 27 68 61 76 ))))....... 'hav
2bd0: 65 2d 70 72 6f 63 65 64 75 72 65 29 0a 09 09 09 e-procedure)....
2be0: 09 09 09 28 28 6f 72 20 28 6c 69 73 74 3f 20 69 ...((or (list? i
2bf0: 74 65 6d 73 29 28 6c 69 73 74 3f 20 69 74 65 6d tems)(list? item
2c00: 73 74 61 62 6c 65 29 29 20 3b 3b 20 63 61 6c 63 stable)) ;; calc
2c10: 20 6e 6f 77 0a 09 09 09 09 09 09 20 28 64 65 62 now....... (deb
2c20: 75 67 3a 70 72 69 6e 74 20 34 20 22 49 4e 46 4f ug:print 4 "INFO
2c30: 3a 20 69 74 65 6d 73 20 61 6e 64 20 69 74 65 6d : items and item
2c40: 73 74 61 62 6c 65 20 61 72 65 20 6c 69 73 74 73 stable are lists
2c50: 2c 20 63 61 6c 63 20 6e 6f 77 5c 6e 22 0a 09 09 , calc now\n"...
2c60: 09 09 09 09 09 20 20 20 20 20 20 22 20 20 20 20 ..... "
2c70: 69 74 65 6d 73 3a 20 22 20 69 74 65 6d 73 20 22 items: " items "
2c80: 20 69 74 65 6d 73 74 61 62 6c 65 3a 20 22 20 69 itemstable: " i
2c90: 74 65 6d 73 74 61 62 6c 65 29 0a 09 09 09 09 09 temstable)......
2ca0: 09 20 28 69 74 65 6d 73 3a 67 65 74 2d 69 74 65 . (items:get-ite
2cb0: 6d 73 2d 66 72 6f 6d 2d 63 6f 6e 66 69 67 20 63 ms-from-config c
2cc0: 6f 6e 66 69 67 29 29 0a 09 09 09 09 09 09 28 65 onfig)).......(e
2cd0: 6c 73 65 20 23 66 29 29 29 20 20 20 20 20 20 20 lse #f)))
2ce0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2cf0: 20 20 20 20 3b 3b 20 6e 6f 74 20 69 74 65 72 61 ;; not itera
2d00: 74 65 64 0a 09 09 09 09 09 20 20 20 20 20 23 66 ted...... #f
2d10: 20 20 20 20 20 20 3b 3b 20 69 74 65 6d 73 64 61 ;; itemsda
2d20: 74 20 35 0a 09 09 09 09 09 20 20 20 20 20 23 66 t 5...... #f
2d30: 20 20 20 20 20 20 3b 3b 20 73 70 61 72 65 20 2d ;; spare -
2d40: 20 75 73 65 64 20 66 6f 72 20 69 74 65 6d 2d 70 used for item-p
2d50: 61 74 68 0a 09 09 09 09 09 20 20 20 20 20 29 29 ath...... ))
2d60: 29 0a 09 20 20 20 20 28 66 6f 72 2d 65 61 63 68 ).. (for-each
2d70: 20 0a 09 20 20 20 20 20 28 6c 61 6d 62 64 61 20 .. (lambda
2d80: 28 77 61 69 74 6f 6e 29 0a 09 20 20 20 20 20 20 (waiton)..
2d90: 20 28 69 66 20 28 61 6e 64 20 77 61 69 74 6f 6e (if (and waiton
2da0: 20 28 6e 6f 74 20 28 6d 65 6d 62 65 72 20 77 61 (not (member wa
2db0: 69 74 6f 6e 20 74 65 73 74 2d 6e 61 6d 65 73 29 iton test-names)
2dc0: 29 29 0a 09 09 20 20 20 28 62 65 67 69 6e 0a 09 ))... (begin..
2dd0: 09 20 20 20 20 20 28 73 65 74 21 20 72 65 71 75 . (set! requ
2de0: 69 72 65 64 2d 74 65 73 74 73 20 28 63 6f 6e 73 ired-tests (cons
2df0: 20 77 61 69 74 6f 6e 20 72 65 71 75 69 72 65 64 waiton required
2e00: 2d 74 65 73 74 73 29 29 0a 09 09 20 20 20 20 20 -tests))...
2e10: 28 73 65 74 21 20 74 65 73 74 2d 6e 61 6d 65 73 (set! test-names
2e20: 20 28 63 6f 6e 73 20 77 61 69 74 6f 6e 20 74 65 (cons waiton te
2e30: 73 74 2d 6e 61 6d 65 73 29 29 29 29 29 20 3b 3b st-names))))) ;;
2e40: 20 77 61 73 20 61 6e 20 61 70 70 65 6e 64 2c 20 was an append,
2e50: 6e 6f 77 20 61 20 63 6f 6e 73 0a 09 20 20 20 20 now a cons..
2e60: 20 77 61 69 74 6f 6e 73 29 0a 09 20 20 20 20 28 waitons).. (
2e70: 6c 65 74 20 28 28 72 65 6d 74 65 73 74 73 20 28 let ((remtests (
2e80: 64 65 6c 65 74 65 2d 64 75 70 6c 69 63 61 74 65 delete-duplicate
2e90: 73 20 28 61 70 70 65 6e 64 20 77 61 69 74 6f 6e s (append waiton
2ea0: 73 20 74 61 6c 29 29 29 29 0a 09 20 20 20 20 20 s tal))))..
2eb0: 20 28 69 66 20 28 6e 6f 74 20 28 6e 75 6c 6c 3f (if (not (null?
2ec0: 20 72 65 6d 74 65 73 74 73 29 29 0a 09 09 20 20 remtests))...
2ed0: 28 6c 6f 6f 70 20 28 63 61 72 20 72 65 6d 74 65 (loop (car remte
2ee0: 73 74 73 29 28 63 64 72 20 72 65 6d 74 65 73 74 sts)(cdr remtest
2ef0: 73 29 29 29 29 29 29 29 0a 0a 20 20 20 20 28 69 s))))))).. (i
2f00: 66 20 28 6e 6f 74 20 28 6e 75 6c 6c 3f 20 72 65 f (not (null? re
2f10: 71 75 69 72 65 64 2d 74 65 73 74 73 29 29 0a 09 quired-tests))..
2f20: 28 64 65 62 75 67 3a 70 72 69 6e 74 20 31 20 22 (debug:print 1 "
2f30: 49 4e 46 4f 3a 20 41 64 64 69 6e 67 20 22 20 72 INFO: Adding " r
2f40: 65 71 75 69 72 65 64 2d 74 65 73 74 73 20 22 20 equired-tests "
2f50: 74 6f 20 74 68 65 20 72 75 6e 20 71 75 65 75 65 to the run queue
2f60: 22 29 29 0a 20 20 20 20 3b 3b 20 4e 4f 54 45 3a ")). ;; NOTE:
2f70: 20 74 68 65 73 65 20 61 72 65 20 61 6c 6c 20 70 these are all p
2f80: 61 72 65 6e 74 20 74 65 73 74 73 2c 20 69 74 65 arent tests, ite
2f90: 6d 73 20 61 72 65 20 6e 6f 74 20 65 78 70 61 6e ms are not expan
2fa0: 64 65 64 20 79 65 74 2e 0a 20 20 20 20 28 64 65 ded yet.. (de
2fb0: 62 75 67 3a 70 72 69 6e 74 20 34 20 22 49 4e 46 bug:print 4 "INF
2fc0: 4f 3a 20 74 65 73 74 2d 72 65 63 6f 72 64 73 3d O: test-records=
2fd0: 22 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 3e 61 " (hash-table->a
2fe0: 6c 69 73 74 20 74 65 73 74 2d 72 65 63 6f 72 64 list test-record
2ff0: 73 29 29 0a 20 20 20 20 28 72 75 6e 73 3a 72 75 s)). (runs:ru
3000: 6e 2d 74 65 73 74 73 2d 71 75 65 75 65 20 72 75 n-tests-queue ru
3010: 6e 2d 69 64 20 72 75 6e 6e 61 6d 65 20 74 65 73 n-id runname tes
3020: 74 2d 72 65 63 6f 72 64 73 20 6b 65 79 76 61 6c t-records keyval
3030: 6c 73 74 20 66 6c 61 67 73 29 0a 20 20 20 20 28 lst flags). (
3040: 72 75 6e 73 3a 72 75 6e 2d 74 65 73 74 73 2d 71 runs:run-tests-q
3050: 75 65 75 65 20 72 75 6e 2d 69 64 20 72 75 6e 6e ueue run-id runn
3060: 61 6d 65 20 74 65 73 74 2d 72 65 63 6f 72 64 73 ame test-records
3070: 20 6b 65 79 76 61 6c 6c 73 74 20 66 6c 61 67 73 keyvallst flags
3080: 29 0a 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 ). (debug:pri
3090: 6e 74 20 34 20 22 49 4e 46 4f 3a 20 41 6c 6c 20 nt 4 "INFO: All
30a0: 64 6f 6e 65 20 62 79 20 68 65 72 65 22 29 29 29 done by here")))
30b0: 0a 0a 3b 3b 20 74 65 73 74 2d 72 65 63 6f 72 64 ..;; test-record
30c0: 73 20 69 73 20 61 20 68 61 73 68 20 74 61 62 6c s is a hash tabl
30d0: 65 20 74 65 73 74 6e 61 6d 65 3a 69 74 65 6d 5f e testname:item_
30e0: 70 61 74 68 20 3d 3e 20 76 65 63 74 6f 72 20 3c path => vector <
30f0: 20 74 65 73 74 6e 61 6d 65 20 74 65 73 74 63 6f testname testco
3100: 6e 66 69 67 20 77 61 69 74 6f 6e 73 20 70 72 69 nfig waitons pri
3110: 6f 72 69 74 79 20 69 74 65 6d 73 2d 69 6e 66 6f ority items-info
3120: 20 2e 2e 2e 20 3e 0a 28 64 65 66 69 6e 65 20 28 ... >.(define (
3130: 72 75 6e 73 3a 72 75 6e 2d 74 65 73 74 73 2d 71 runs:run-tests-q
3140: 75 65 75 65 20 72 75 6e 2d 69 64 20 72 75 6e 6e ueue run-id runn
3150: 61 6d 65 20 74 65 73 74 2d 72 65 63 6f 72 64 73 ame test-records
3160: 20 6b 65 79 76 61 6c 6c 73 74 20 66 6c 61 67 73 keyvallst flags
3170: 29 0a 20 20 20 20 3b 3b 20 41 74 20 74 68 69 73 ). ;; At this
3180: 20 70 6f 69 6e 74 20 74 68 65 20 6c 69 73 74 20 point the list
3190: 6f 66 20 70 61 72 65 6e 74 20 74 65 73 74 73 20 of parent tests
31a0: 69 73 20 65 78 70 61 6e 64 65 64 20 0a 20 20 20 is expanded .
31b0: 20 3b 3b 20 4e 42 2f 2f 20 53 68 6f 75 6c 64 20 ;; NB// Should
31c0: 65 78 70 61 6e 64 20 69 74 65 6d 73 20 68 65 72 expand items her
31d0: 65 20 61 6e 64 20 74 68 65 6e 20 69 6e 73 65 72 e and then inser
31e0: 74 20 69 6e 74 6f 20 74 68 65 20 72 75 6e 20 71 t into the run q
31f0: 75 65 75 65 2e 0a 20 20 28 64 65 62 75 67 3a 70 ueue.. (debug:p
3200: 72 69 6e 74 20 35 20 22 74 65 73 74 2d 72 65 63 rint 5 "test-rec
3210: 6f 72 64 73 3a 20 22 20 74 65 73 74 2d 72 65 63 ords: " test-rec
3220: 6f 72 64 73 20 22 2c 20 6b 65 79 76 61 6c 6c 73 ords ", keyvalls
3230: 74 3a 20 22 20 6b 65 79 76 61 6c 6c 73 74 20 22 t: " keyvallst "
3240: 20 66 6c 61 67 73 3a 20 22 20 28 68 61 73 68 2d flags: " (hash-
3250: 74 61 62 6c 65 2d 3e 61 6c 69 73 74 20 66 6c 61 table->alist fla
3260: 67 73 29 29 0a 20 20 28 6c 65 74 20 28 28 73 6f gs)). (let ((so
3270: 72 74 65 64 2d 74 65 73 74 2d 6e 61 6d 65 73 20 rted-test-names
3280: 28 74 65 73 74 73 3a 73 6f 72 74 2d 62 79 2d 70 (tests:sort-by-p
3290: 72 69 6f 72 69 74 79 2d 61 6e 64 2d 77 61 69 74 riority-and-wait
32a0: 6f 6e 20 74 65 73 74 2d 72 65 63 6f 72 64 73 29 on test-records)
32b0: 29 0a 09 28 69 74 65 6d 2d 70 61 74 74 73 20 20 )..(item-patts
32c0: 20 20 20 20 20 20 28 68 61 73 68 2d 74 61 62 6c (hash-tabl
32d0: 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 66 6c e-ref/default fl
32e0: 61 67 73 20 22 2d 69 74 65 6d 70 61 74 74 22 20 ags "-itempatt"
32f0: 23 66 29 29 0a 09 28 74 65 73 74 2d 72 65 67 69 #f))..(test-regi
3300: 73 74 65 72 79 20 20 20 20 28 6d 61 6b 65 2d 68 stery (make-h
3310: 61 73 68 2d 74 61 62 6c 65 29 29 29 0a 20 20 20 ash-table))).
3320: 20 28 69 66 20 28 6e 6f 74 20 28 6e 75 6c 6c 3f (if (not (null?
3330: 20 73 6f 72 74 65 64 2d 74 65 73 74 2d 6e 61 6d sorted-test-nam
3340: 65 73 29 29 0a 09 28 6c 65 74 20 6c 6f 6f 70 20 es))..(let loop
3350: 28 28 68 65 64 20 20 20 20 20 20 20 20 20 28 63 ((hed (c
3360: 61 72 20 73 6f 72 74 65 64 2d 74 65 73 74 2d 6e ar sorted-test-n
3370: 61 6d 65 73 29 29 0a 09 09 20 20 20 28 74 61 6c ames))... (tal
3380: 20 20 20 20 20 20 20 20 20 28 63 64 72 20 73 6f (cdr so
3390: 72 74 65 64 2d 74 65 73 74 2d 6e 61 6d 65 73 29 rted-test-names)
33a0: 29 29 0a 09 20 20 28 6c 65 74 2a 20 28 28 74 65 )).. (let* ((te
33b0: 73 74 2d 72 65 63 6f 72 64 20 28 68 61 73 68 2d st-record (hash-
33c0: 74 61 62 6c 65 2d 72 65 66 20 74 65 73 74 2d 72 table-ref test-r
33d0: 65 63 6f 72 64 73 20 68 65 64 29 29 0a 09 09 20 ecords hed))...
33e0: 28 74 65 73 74 2d 6e 61 6d 65 20 20 20 28 74 65 (test-name (te
33f0: 73 74 73 3a 74 65 73 74 71 75 65 75 65 2d 67 65 sts:testqueue-ge
3400: 74 2d 74 65 73 74 6e 61 6d 65 20 74 65 73 74 2d t-testname test-
3410: 72 65 63 6f 72 64 29 29 0a 09 09 20 28 74 63 6f record))... (tco
3420: 6e 66 69 67 20 20 20 20 20 28 74 65 73 74 73 3a nfig (tests:
3430: 74 65 73 74 71 75 65 75 65 2d 67 65 74 2d 74 65 testqueue-get-te
3440: 73 74 63 6f 6e 66 69 67 20 74 65 73 74 2d 72 65 stconfig test-re
3450: 63 6f 72 64 29 29 0a 09 09 20 28 74 65 73 74 6d cord))... (testm
3460: 6f 64 65 20 20 20 20 28 6c 65 74 20 28 28 6d 20 ode (let ((m
3470: 28 63 6f 6e 66 69 67 2d 6c 6f 6f 6b 75 70 20 74 (config-lookup t
3480: 63 6f 6e 66 69 67 20 22 72 65 71 75 69 72 65 6d config "requirem
3490: 65 6e 74 73 22 20 22 6d 6f 64 65 22 29 29 29 0a ents" "mode"))).
34a0: 09 09 09 09 28 69 66 20 6d 20 28 73 74 72 69 6e ....(if m (strin
34b0: 67 2d 3e 73 79 6d 62 6f 6c 20 6d 29 20 27 6e 6f g->symbol m) 'no
34c0: 72 6d 61 6c 29 29 29 0a 09 09 20 28 77 61 69 74 rmal)))... (wait
34d0: 6f 6e 73 20 20 20 20 20 28 74 65 73 74 73 3a 74 ons (tests:t
34e0: 65 73 74 71 75 65 75 65 2d 67 65 74 2d 77 61 69 estqueue-get-wai
34f0: 74 6f 6e 73 20 20 20 20 74 65 73 74 2d 72 65 63 tons test-rec
3500: 6f 72 64 29 29 0a 09 09 20 28 70 72 69 6f 72 69 ord))... (priori
3510: 74 79 20 20 20 20 28 74 65 73 74 73 3a 74 65 73 ty (tests:tes
3520: 74 71 75 65 75 65 2d 67 65 74 2d 70 72 69 6f 72 tqueue-get-prior
3530: 69 74 79 20 20 20 74 65 73 74 2d 72 65 63 6f 72 ity test-recor
3540: 64 29 29 0a 09 09 20 28 69 74 65 6d 64 61 74 20 d))... (itemdat
3550: 20 20 20 20 28 74 65 73 74 73 3a 74 65 73 74 71 (tests:testq
3560: 75 65 75 65 2d 67 65 74 2d 69 74 65 6d 64 61 74 ueue-get-itemdat
3570: 20 20 20 20 74 65 73 74 2d 72 65 63 6f 72 64 29 test-record)
3580: 29 20 3b 3b 20 69 74 65 6d 64 61 74 20 63 61 6e ) ;; itemdat can
3590: 20 62 65 20 61 20 73 74 72 69 6e 67 2c 20 6c 69 be a string, li
35a0: 73 74 20 6f 72 20 23 66 0a 09 09 20 28 69 74 65 st or #f... (ite
35b0: 6d 73 20 20 20 20 20 20 20 28 74 65 73 74 73 3a ms (tests:
35c0: 74 65 73 74 71 75 65 75 65 2d 67 65 74 2d 69 74 testqueue-get-it
35d0: 65 6d 73 20 20 20 20 20 20 74 65 73 74 2d 72 65 ems test-re
35e0: 63 6f 72 64 29 29 0a 09 09 20 28 69 74 65 6d 2d cord))... (item-
35f0: 70 61 74 68 20 20 20 28 69 74 65 6d 2d 6c 69 73 path (item-lis
3600: 74 2d 3e 70 61 74 68 20 69 74 65 6d 64 61 74 29 t->path itemdat)
3610: 29 0a 09 09 20 28 6e 65 77 74 61 6c 20 20 20 20 )... (newtal
3620: 20 20 28 61 70 70 65 6e 64 20 74 61 6c 20 28 6c (append tal (l
3630: 69 73 74 20 68 65 64 29 29 29 0a 09 09 20 28 63 ist hed)))... (c
3640: 61 6c 63 2d 66 61 69 6c 73 20 20 28 6c 61 6d 62 alc-fails (lamb
3650: 64 61 20 28 70 72 65 72 65 71 73 2d 6e 6f 74 2d da (prereqs-not-
3660: 6d 65 74 29 0a 09 09 09 09 28 66 69 6c 74 65 72 met).....(filter
3670: 20 28 6c 61 6d 62 64 61 20 28 74 65 73 74 29 0a (lambda (test).
3680: 09 09 09 09 09 20 20 28 64 65 62 75 67 3a 70 72 ..... (debug:pr
3690: 69 6e 74 20 39 20 22 74 65 73 74 3a 20 22 20 74 int 9 "test: " t
36a0: 65 73 74 29 0a 09 09 09 09 09 20 20 28 61 6e 64 est)...... (and
36b0: 20 28 76 65 63 74 6f 72 3f 20 74 65 73 74 29 20 (vector? test)
36c0: 3b 3b 20 6e 6f 74 20 28 73 74 72 69 6e 67 3f 20 ;; not (string?
36d0: 74 65 73 74 29 29 0a 09 09 09 09 09 20 20 20 20 test))......
36e0: 20 20 20 28 65 71 75 61 6c 3f 20 28 64 62 3a 74 (equal? (db:t
36f0: 65 73 74 2d 67 65 74 2d 73 74 61 74 65 20 74 65 est-get-state te
3700: 73 74 29 20 22 43 4f 4d 50 4c 45 54 45 44 22 29 st) "COMPLETED")
3710: 0a 09 09 09 09 09 20 20 20 20 20 20 20 28 6e 6f ...... (no
3720: 74 20 28 6d 65 6d 62 65 72 20 28 64 62 3a 74 65 t (member (db:te
3730: 73 74 2d 67 65 74 2d 73 74 61 74 75 73 20 74 65 st-get-status te
3740: 73 74 29 0a 09 09 09 09 09 09 09 20 20 20 20 27 st)........ '
3750: 28 22 50 41 53 53 22 20 22 57 41 52 4e 22 20 22 ("PASS" "WARN" "
3760: 43 48 45 43 4b 22 20 22 57 41 49 56 45 44 22 29 CHECK" "WAIVED")
3770: 29 29 29 29 0a 09 09 09 09 09 70 72 65 72 65 71 ))))......prereq
3780: 73 2d 6e 6f 74 2d 6d 65 74 29 29 29 0a 09 09 20 s-not-met)))...
3790: 28 63 61 6c 63 2d 6e 6f 74 2d 63 6f 6d 70 6c 65 (calc-not-comple
37a0: 74 65 64 20 28 6c 61 6d 62 64 61 20 28 70 72 65 ted (lambda (pre
37b0: 72 65 71 73 2d 6e 6f 74 2d 6d 65 74 29 0a 09 09 reqs-not-met)...
37c0: 09 09 20 20 20 20 20 20 20 28 66 69 6c 74 65 72 .. (filter
37d0: 0a 09 09 09 09 09 28 6c 61 6d 62 64 61 20 28 74 ......(lambda (t
37e0: 29 0a 09 09 09 09 09 20 20 28 6f 72 20 28 6e 6f )...... (or (no
37f0: 74 20 28 76 65 63 74 6f 72 3f 20 74 29 29 0a 09 t (vector? t))..
3800: 09 09 09 09 20 20 20 20 20 20 28 6e 6f 74 20 28 .... (not (
3810: 65 71 75 61 6c 3f 20 22 43 4f 4d 50 4c 45 54 45 equal? "COMPLETE
3820: 44 22 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d D" (db:test-get-
3830: 73 74 61 74 65 20 74 29 29 29 29 29 0a 09 09 09 state t)))))....
3840: 09 09 70 72 65 72 65 71 73 2d 6e 6f 74 2d 6d 65 ..prereqs-not-me
3850: 74 29 29 29 0a 09 09 20 28 70 72 65 74 74 79 2d t)))... (pretty-
3860: 73 74 72 69 6e 67 20 28 6c 61 6d 62 64 61 20 28 string (lambda (
3870: 6c 73 74 29 0a 09 09 09 09 20 20 28 6d 61 70 20 lst)..... (map
3880: 28 6c 61 6d 62 64 61 20 28 74 29 0a 09 09 09 09 (lambda (t).....
3890: 09 20 28 69 66 20 28 6e 6f 74 20 28 76 65 63 74 . (if (not (vect
38a0: 6f 72 3f 20 74 29 29 0a 09 09 09 09 09 20 20 20 or? t))......
38b0: 20 20 28 63 6f 6e 63 20 74 29 0a 09 09 09 09 09 (conc t)......
38c0: 20 20 20 20 20 28 63 6f 6e 63 20 28 64 62 3a 74 (conc (db:t
38d0: 65 73 74 2d 67 65 74 2d 74 65 73 74 6e 61 6d 65 est-get-testname
38e0: 20 74 29 20 22 3a 22 20 28 64 62 3a 74 65 73 74 t) ":" (db:test
38f0: 2d 67 65 74 2d 73 74 61 74 65 20 74 29 20 22 2f -get-state t) "/
3900: 22 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 73 " (db:test-get-s
3910: 74 61 74 75 73 20 74 29 29 29 29 0a 09 09 09 09 tatus t)))).....
3920: 20 20 20 20 20 20 20 6c 73 74 29 29 29 29 0a 09 lst))))..
3930: 20 20 20 20 0a 09 20 20 20 20 28 64 65 62 75 67 .. (debug
3940: 3a 70 72 69 6e 74 20 36 0a 09 09 09 20 22 74 65 :print 6.... "te
3950: 73 74 2d 6e 61 6d 65 3a 20 22 20 74 65 73 74 2d st-name: " test-
3960: 6e 61 6d 65 0a 09 09 09 20 22 5c 6e 20 20 68 65 name.... "\n he
3970: 64 3a 20 22 20 68 65 64 0a 09 09 09 20 22 5c 6e d: " hed.... "\n
3980: 20 20 69 74 65 6d 64 61 74 3a 20 20 20 20 20 22 itemdat: "
3990: 20 69 74 65 6d 64 61 74 0a 09 09 09 20 22 5c 6e itemdat.... "\n
39a0: 20 20 69 74 65 6d 73 3a 20 20 20 20 20 22 20 69 items: " i
39b0: 74 65 6d 73 0a 09 09 09 20 22 5c 6e 20 20 69 74 tems.... "\n it
39c0: 65 6d 2d 70 61 74 68 3a 20 22 20 69 74 65 6d 2d em-path: " item-
39d0: 70 61 74 68 0a 09 09 09 20 22 5c 6e 20 20 77 61 path.... "\n wa
39e0: 69 74 6f 6e 73 3a 20 20 20 22 20 77 61 69 74 6f itons: " waito
39f0: 6e 73 29 0a 0a 09 20 20 20 20 3b 3b 20 63 68 65 ns)... ;; che
3a00: 63 6b 20 66 6f 72 20 68 65 64 20 69 6e 20 77 61 ck for hed in wa
3a10: 69 74 6f 6e 73 20 3d 3e 20 74 68 69 73 20 77 6f itons => this wo
3a20: 75 6c 64 20 62 65 20 63 69 72 63 75 6c 61 72 2c uld be circular,
3a30: 20 72 65 6d 6f 76 65 20 69 74 20 61 6e 64 20 69 remove it and i
3a40: 73 73 75 65 20 61 6e 0a 09 20 20 20 20 3b 3b 20 ssue an.. ;;
3a50: 65 72 72 6f 72 0a 09 20 20 20 20 28 69 66 20 28 error.. (if (
3a60: 6d 65 6d 62 65 72 20 74 65 73 74 2d 6e 61 6d 65 member test-name
3a70: 20 77 61 69 74 6f 6e 73 29 0a 09 09 28 62 65 67 waitons)...(beg
3a80: 69 6e 0a 09 09 20 20 28 64 65 62 75 67 3a 70 72 in... (debug:pr
3a90: 69 6e 74 20 30 20 22 45 52 52 4f 52 3a 20 74 65 int 0 "ERROR: te
3aa0: 73 74 20 22 20 74 65 73 74 2d 6e 61 6d 65 20 22 st " test-name "
3ab0: 20 68 61 73 20 6c 69 73 74 65 64 20 69 74 73 65 has listed itse
3ac0: 6c 66 20 61 73 20 61 20 77 61 69 74 6f 6e 2c 20 lf as a waiton,
3ad0: 70 6c 65 61 73 65 20 63 6f 72 72 65 63 74 20 74 please correct t
3ae0: 68 69 73 21 22 29 0a 09 09 20 20 28 73 65 74 21 his!")... (set!
3af0: 20 77 61 69 74 6f 6e 20 28 66 69 6c 74 65 72 20 waiton (filter
3b00: 28 6c 61 6d 62 64 61 20 28 78 29 28 6e 6f 74 20 (lambda (x)(not
3b10: 28 65 71 75 61 6c 3f 20 78 20 68 65 64 29 29 29 (equal? x hed)))
3b20: 20 77 61 69 74 6f 6e 73 29 29 29 29 0a 0a 09 20 waitons))))...
3b30: 20 20 20 28 63 6f 6e 64 0a 09 20 20 20 20 20 28 (cond.. (
3b40: 28 6e 6f 74 20 69 74 65 6d 73 29 20 3b 3b 20 77 (not items) ;; w
3b50: 68 65 6e 20 66 61 6c 73 65 20 74 68 65 20 74 65 hen false the te
3b60: 73 74 20 69 73 20 6f 6b 20 74 6f 20 62 65 20 68 st is ok to be h
3b70: 61 6e 64 65 64 20 6f 66 66 20 74 6f 20 6c 61 75 anded off to lau
3b80: 6e 63 68 20 28 62 75 74 20 6e 6f 74 20 62 65 66 nch (but not bef
3b90: 6f 72 65 29 0a 09 20 20 20 20 20 20 28 6c 65 74 ore).. (let
3ba0: 2a 20 28 28 68 61 76 65 2d 72 65 73 6f 75 72 63 * ((have-resourc
3bb0: 65 73 20 20 28 6f 70 65 6e 2d 72 75 6e 2d 63 6c es (open-run-cl
3bc0: 6f 73 65 20 72 75 6e 73 3a 63 61 6e 2d 72 75 6e ose runs:can-run
3bd0: 2d 6d 6f 72 65 2d 74 65 73 74 73 20 23 66 20 74 -more-tests #f t
3be0: 65 73 74 2d 72 65 63 6f 72 64 29 29 20 3b 3b 20 est-record)) ;;
3bf0: 6c 6f 6f 6b 20 61 74 20 74 68 65 20 74 65 73 74 look at the test
3c00: 20 6a 6f 62 67 72 6f 75 70 20 61 6e 64 20 74 6f jobgroup and to
3c10: 74 20 6a 6f 62 73 20 72 75 6e 6e 69 6e 67 0a 09 t jobs running..
3c20: 09 20 20 20 20 20 28 70 72 65 72 65 71 73 2d 6e . (prereqs-n
3c30: 6f 74 2d 6d 65 74 20 28 6f 70 65 6e 2d 72 75 6e ot-met (open-run
3c40: 2d 63 6c 6f 73 65 20 64 62 3a 67 65 74 2d 70 72 -close db:get-pr
3c50: 65 72 65 71 73 2d 6e 6f 74 2d 6d 65 74 20 23 66 ereqs-not-met #f
3c60: 20 72 75 6e 2d 69 64 20 77 61 69 74 6f 6e 73 20 run-id waitons
3c70: 69 74 65 6d 2d 70 61 74 68 20 6d 6f 64 65 3a 20 item-path mode:
3c80: 74 65 73 74 6d 6f 64 65 29 29 0a 09 09 20 20 20 testmode))...
3c90: 20 20 28 66 61 69 6c 73 20 20 20 20 20 20 20 20 (fails
3ca0: 20 20 20 28 63 61 6c 63 2d 66 61 69 6c 73 20 70 (calc-fails p
3cb0: 72 65 72 65 71 73 2d 6e 6f 74 2d 6d 65 74 29 29 rereqs-not-met))
3cc0: 0a 09 09 20 20 20 20 20 28 6e 6f 6e 2d 63 6f 6d ... (non-com
3cd0: 70 6c 65 74 65 64 20 20 20 28 63 61 6c 63 2d 6e pleted (calc-n
3ce0: 6f 74 2d 63 6f 6d 70 6c 65 74 65 64 20 70 72 65 ot-completed pre
3cf0: 72 65 71 73 2d 6e 6f 74 2d 6d 65 74 29 29 29 0a reqs-not-met))).
3d00: 09 09 28 64 65 62 75 67 3a 70 72 69 6e 74 20 38 ..(debug:print 8
3d10: 20 22 49 4e 46 4f 3a 20 68 61 76 65 2d 72 65 73 "INFO: have-res
3d20: 6f 75 72 63 65 73 3a 20 22 20 68 61 76 65 2d 72 ources: " have-r
3d30: 65 73 6f 75 72 63 65 73 20 22 20 70 72 65 72 65 esources " prere
3d40: 71 73 2d 6e 6f 74 2d 6d 65 74 3a 20 22 20 0a 09 qs-not-met: " ..
3d50: 09 09 20 20 20 20 20 28 73 74 72 69 6e 67 2d 69 .. (string-i
3d60: 6e 74 65 72 73 70 65 72 73 65 20 0a 09 09 09 20 ntersperse ....
3d70: 20 20 20 20 20 28 6d 61 70 20 28 6c 61 6d 62 64 (map (lambd
3d80: 61 20 28 74 29 0a 09 09 09 09 20 20 20 20 20 28 a (t)..... (
3d90: 69 66 20 28 76 65 63 74 6f 72 3f 20 74 29 0a 09 if (vector? t)..
3da0: 09 09 09 09 20 28 63 6f 6e 63 20 28 64 62 3a 74 .... (conc (db:t
3db0: 65 73 74 2d 67 65 74 2d 73 74 61 74 65 20 74 29 est-get-state t)
3dc0: 20 22 2f 22 20 28 64 62 3a 74 65 73 74 2d 67 65 "/" (db:test-ge
3dd0: 74 2d 73 74 61 74 75 73 20 74 29 29 0a 09 09 09 t-status t))....
3de0: 09 09 20 28 63 6f 6e 63 20 22 20 57 41 52 4e 49 .. (conc " WARNI
3df0: 4e 47 3a 20 74 20 69 73 20 6e 6f 74 20 61 20 76 NG: t is not a v
3e00: 65 63 74 6f 72 3d 22 20 74 20 29 29 29 0a 09 09 ector=" t )))...
3e10: 09 09 20 20 20 70 72 65 72 65 71 73 2d 6e 6f 74 .. prereqs-not
3e20: 2d 6d 65 74 29 20 22 2c 20 22 29 20 22 20 66 61 -met) ", ") " fa
3e30: 69 6c 73 3a 20 22 20 66 61 69 6c 73 29 0a 09 09 ils: " fails)...
3e40: 28 64 65 62 75 67 3a 70 72 69 6e 74 20 34 20 22 (debug:print 4 "
3e50: 49 4e 46 4f 3a 20 68 65 64 3d 22 20 68 65 64 29 INFO: hed=" hed)
3e60: 0a 09 09 3b 3b 20 44 6f 6e 27 74 20 6b 6e 6f 77 ...;; Don't know
3e70: 20 61 74 20 74 68 69 73 20 74 69 6d 65 20 69 66 at this time if
3e80: 20 74 68 65 20 74 65 73 74 20 68 61 76 65 20 62 the test have b
3e90: 65 65 6e 20 6c 61 75 6e 63 68 65 64 20 61 74 20 een launched at
3ea0: 73 6f 6d 65 20 74 69 6d 65 20 69 6e 20 74 68 65 some time in the
3eb0: 20 70 61 73 74 0a 09 09 3b 3b 20 69 2e 65 2e 20 past...;; i.e.
3ec0: 69 73 20 74 68 69 73 20 61 20 72 65 2d 6c 61 75 is this a re-lau
3ed0: 6e 63 68 3f 0a 09 09 28 63 6f 6e 64 0a 09 09 20 nch?...(cond...
3ee0: 28 28 6e 6f 74 20 28 70 61 74 74 2d 6c 69 73 74 ((not (patt-list
3ef0: 2d 6d 61 74 63 68 20 69 74 65 6d 2d 70 61 74 68 -match item-path
3f00: 20 69 74 65 6d 2d 70 61 74 74 73 29 29 0a 09 09 item-patts))...
3f10: 20 20 3b 3b 20 65 6c 73 65 20 74 68 65 20 72 75 ;; else the ru
3f20: 6e 20 69 73 20 73 74 75 63 6b 2c 20 74 65 6d 70 n is stuck, temp
3f30: 6f 72 61 72 69 6c 79 20 6f 72 20 70 65 72 6d 61 orarily or perma
3f40: 6e 65 6e 74 6c 79 0a 09 09 20 20 3b 3b 20 62 75 nently... ;; bu
3f50: 74 20 73 68 6f 75 6c 64 20 63 68 65 63 6b 20 69 t should check i
3f60: 66 20 69 74 20 69 73 20 64 75 65 20 74 6f 20 6c f it is due to l
3f70: 61 63 6b 20 6f 66 20 72 65 73 6f 75 72 63 65 73 ack of resources
3f80: 20 76 73 2e 20 70 72 65 72 65 71 75 69 73 69 74 vs. prerequisit
3f90: 65 73 0a 09 09 20 20 28 64 65 62 75 67 3a 70 72 es... (debug:pr
3fa0: 69 6e 74 20 31 20 22 49 4e 46 4f 3a 20 53 6b 69 int 1 "INFO: Ski
3fb0: 70 70 69 6e 67 20 22 20 28 74 65 73 74 73 3a 74 pping " (tests:t
3fc0: 65 73 74 71 75 65 75 65 2d 67 65 74 2d 74 65 73 estqueue-get-tes
3fd0: 74 6e 61 6d 65 20 74 65 73 74 2d 72 65 63 6f 72 tname test-recor
3fe0: 64 29 20 22 20 22 20 69 74 65 6d 2d 70 61 74 68 d) " " item-path
3ff0: 20 22 20 61 73 20 69 74 20 64 6f 65 73 6e 27 74 " as it doesn't
4000: 20 6d 61 74 63 68 20 22 20 69 74 65 6d 2d 70 61 match " item-pa
4010: 74 74 73 29 0a 09 09 20 20 28 69 66 20 28 6e 6f tts)... (if (no
4020: 74 20 28 6e 75 6c 6c 3f 20 74 61 6c 29 29 0a 09 t (null? tal))..
4030: 09 20 20 20 20 20 20 28 6c 6f 6f 70 20 28 63 61 . (loop (ca
4040: 72 20 74 61 6c 29 28 63 64 72 20 74 61 6c 29 29 r tal)(cdr tal))
4050: 29 29 0a 09 09 20 28 28 6e 6f 74 20 28 68 61 73 ))... ((not (has
4060: 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 h-table-ref/defa
4070: 75 6c 74 20 74 65 73 74 2d 72 65 67 69 73 74 65 ult test-registe
4080: 72 79 20 28 63 6f 6e 63 20 74 65 73 74 2d 6e 61 ry (conc test-na
4090: 6d 65 20 22 2f 22 20 69 74 65 6d 2d 70 61 74 68 me "/" item-path
40a0: 29 20 23 66 29 29 0a 09 09 20 20 28 6f 70 65 6e ) #f))... (open
40b0: 2d 72 75 6e 2d 63 6c 6f 73 65 20 64 62 3a 74 65 -run-close db:te
40c0: 73 74 73 2d 72 65 67 69 73 74 65 72 2d 74 65 73 sts-register-tes
40d0: 74 20 23 66 20 72 75 6e 2d 69 64 20 74 65 73 74 t #f run-id test
40e0: 2d 6e 61 6d 65 20 69 74 65 6d 2d 70 61 74 68 29 -name item-path)
40f0: 0a 09 09 20 20 28 68 61 73 68 2d 74 61 62 6c 65 ... (hash-table
4100: 2d 73 65 74 21 20 74 65 73 74 2d 72 65 67 69 73 -set! test-regis
4110: 74 65 72 79 20 28 63 6f 6e 63 20 74 65 73 74 2d tery (conc test-
4120: 6e 61 6d 65 20 22 2f 22 20 69 74 65 6d 2d 70 61 name "/" item-pa
4130: 74 68 29 20 23 74 29 0a 09 09 20 20 28 6c 6f 6f th) #t)... (loo
4140: 70 20 28 63 61 72 20 6e 65 77 74 61 6c 29 28 63 p (car newtal)(c
4150: 64 72 20 6e 65 77 74 61 6c 29 29 29 0a 09 09 20 dr newtal)))...
4160: 28 28 6e 6f 74 20 68 61 76 65 2d 72 65 73 6f 75 ((not have-resou
4170: 72 63 65 73 29 20 3b 3b 20 73 69 6d 70 6c 79 20 rces) ;; simply
4180: 74 72 79 20 61 67 61 69 6e 20 61 66 74 65 72 20 try again after
4190: 77 61 69 74 69 6e 67 20 61 20 73 65 63 6f 6e 64 waiting a second
41a0: 0a 09 09 20 20 28 74 68 72 65 61 64 2d 73 6c 65 ... (thread-sle
41b0: 65 70 21 20 28 2b 20 31 20 2a 67 6c 6f 62 61 6c ep! (+ 1 *global
41c0: 2d 64 65 6c 74 61 2a 29 29 0a 09 09 20 20 28 64 -delta*))... (d
41d0: 65 62 75 67 3a 70 72 69 6e 74 20 31 20 22 49 4e ebug:print 1 "IN
41e0: 46 4f 3a 20 6e 6f 20 72 65 73 6f 75 72 63 65 73 FO: no resources
41f0: 20 74 6f 20 72 75 6e 20 6e 65 77 20 74 65 73 74 to run new test
4200: 73 2c 20 77 61 69 74 69 6e 67 20 2e 2e 2e 22 29 s, waiting ...")
4210: 0a 09 09 20 20 3b 3b 20 63 6f 75 6c 64 20 68 61 ... ;; could ha
4220: 76 65 20 64 6f 6e 65 20 68 65 64 20 74 61 6c 20 ve done hed tal
4230: 68 65 72 65 20 62 75 74 20 64 6f 69 6e 67 20 63 here but doing c
4240: 61 72 2f 63 64 72 20 6f 66 20 6e 65 77 74 61 6c ar/cdr of newtal
4250: 20 74 6f 20 72 6f 74 61 74 65 20 74 65 73 74 73 to rotate tests
4260: 0a 09 09 20 20 28 6c 6f 6f 70 20 28 63 61 72 20 ... (loop (car
4270: 6e 65 77 74 61 6c 29 28 63 64 72 20 6e 65 77 74 newtal)(cdr newt
4280: 61 6c 29 29 29 0a 09 09 20 28 28 61 6e 64 20 68 al)))... ((and h
4290: 61 76 65 2d 72 65 73 6f 75 72 63 65 73 0a 09 09 ave-resources...
42a0: 20 20 20 20 20 20 20 28 6f 72 20 28 6e 75 6c 6c (or (null
42b0: 3f 20 70 72 65 72 65 71 73 2d 6e 6f 74 2d 6d 65 ? prereqs-not-me
42c0: 74 29 0a 09 09 09 20 20 20 28 61 6e 64 20 28 65 t).... (and (e
42d0: 71 3f 20 74 65 73 74 6d 6f 64 65 20 27 74 6f 70 q? testmode 'top
42e0: 6c 65 76 65 6c 29 0a 09 09 09 09 28 6e 75 6c 6c level).....(null
42f0: 3f 20 6e 6f 6e 2d 63 6f 6d 70 6c 65 74 65 64 29 ? non-completed)
4300: 29 29 29 0a 09 09 20 20 3b 3b 20 6e 6f 20 6c 6f )))... ;; no lo
4310: 6f 70 20 68 65 72 65 2c 20 6a 75 73 74 20 64 72 op here, just dr
4320: 6f 70 20 74 68 6f 75 67 68 20 61 6e 64 20 75 73 op though and us
4330: 65 20 74 68 65 20 6c 6f 6f 70 20 61 74 20 74 68 e the loop at th
4340: 65 20 62 6f 74 74 6f 6d 20 0a 09 09 20 20 28 72 e bottom ... (r
4350: 75 6e 3a 74 65 73 74 20 72 75 6e 2d 69 64 20 72 un:test run-id r
4360: 75 6e 6e 61 6d 65 20 6b 65 79 76 61 6c 6c 73 74 unname keyvallst
4370: 20 74 65 73 74 2d 72 65 63 6f 72 64 20 66 6c 61 test-record fla
4380: 67 73 20 23 66 29 29 0a 09 09 20 28 65 6c 73 65 gs #f))... (else
4390: 20 3b 3b 20 6d 75 73 74 20 62 65 20 77 65 20 68 ;; must be we h
43a0: 61 76 65 20 75 6e 6d 65 74 20 70 72 65 72 65 71 ave unmet prereq
43b0: 75 69 73 69 74 65 73 0a 09 09 20 20 20 20 28 64 uisites... (d
43c0: 65 62 75 67 3a 70 72 69 6e 74 20 34 20 22 46 41 ebug:print 4 "FA
43d0: 49 4c 53 3a 20 22 20 66 61 69 6c 73 29 0a 09 09 ILS: " fails)...
43e0: 20 20 20 20 3b 3b 20 49 66 20 6f 6e 65 20 6f 72 ;; If one or
43f0: 20 6d 6f 72 65 20 6f 66 20 74 68 65 20 70 72 65 more of the pre
4400: 72 65 71 73 2d 6e 6f 74 2d 6d 65 74 20 61 72 65 reqs-not-met are
4410: 20 46 41 49 4c 20 74 68 65 6e 20 77 65 20 63 61 FAIL then we ca
4420: 6e 20 69 73 73 75 65 0a 09 09 20 20 20 20 3b 3b n issue... ;;
4430: 20 61 20 6d 65 73 73 61 67 65 20 61 6e 64 20 64 a message and d
4440: 72 6f 70 20 68 65 64 20 66 72 6f 6d 20 74 68 65 rop hed from the
4450: 20 69 74 65 6d 73 20 74 6f 20 62 65 20 70 72 6f items to be pro
4460: 63 65 73 73 65 64 2e 0a 09 09 20 20 20 20 28 69 cessed.... (i
4470: 66 20 28 6e 75 6c 6c 3f 20 66 61 69 6c 73 29 0a f (null? fails).
4480: 09 09 09 28 62 65 67 69 6e 0a 09 09 09 20 20 3b ...(begin.... ;
4490: 3b 20 63 6f 75 6c 64 6e 27 74 20 72 75 6e 2c 20 ; couldn't run,
44a0: 74 61 6b 65 20 61 20 62 72 65 61 74 68 65 72 0a take a breather.
44b0: 09 09 09 20 20 28 64 65 62 75 67 3a 70 72 69 6e ... (debug:prin
44c0: 74 20 34 20 22 49 4e 46 4f 3a 20 53 68 6f 75 6c t 4 "INFO: Shoul
44d0: 64 6e 27 74 20 72 65 61 6c 6c 79 20 67 65 74 20 dn't really get
44e0: 68 65 72 65 2c 20 72 61 63 65 20 63 6f 6e 64 69 here, race condi
44f0: 74 69 6f 6e 3f 20 55 6e 61 62 6c 65 20 74 6f 20 tion? Unable to
4500: 6c 61 75 6e 63 68 20 6d 6f 72 65 20 74 65 73 74 launch more test
4510: 73 20 61 74 20 74 68 69 73 20 6d 6f 6d 65 6e 74 s at this moment
4520: 2c 20 6b 69 6c 6c 69 6e 67 20 74 69 6d 65 20 2e , killing time .
4530: 2e 2e 22 29 0a 09 09 09 20 20 28 74 68 72 65 61 ..").... (threa
4540: 64 2d 73 6c 65 65 70 21 20 28 2b 20 31 20 2a 67 d-sleep! (+ 1 *g
4550: 6c 6f 62 61 6c 2d 64 65 6c 74 61 2a 29 29 20 3b lobal-delta*)) ;
4560: 3b 20 6c 6f 6e 67 20 73 6c 65 65 70 20 68 65 72 ; long sleep her
4570: 65 20 2d 20 6e 6f 20 72 65 73 6f 75 72 63 65 73 e - no resources
4580: 2c 20 6d 61 79 20 61 73 20 77 65 6c 6c 20 62 65 , may as well be
4590: 20 70 61 74 69 65 6e 74 0a 09 09 09 20 20 3b 3b patient.... ;;
45a0: 20 77 65 20 6d 61 64 65 20 6e 65 77 20 74 61 6c we made new tal
45b0: 20 62 79 20 73 74 69 63 6b 69 6e 67 20 68 65 64 by sticking hed
45c0: 20 61 74 20 74 68 65 20 62 61 63 6b 20 6f 66 20 at the back of
45d0: 74 68 65 20 6c 69 73 74 0a 09 09 09 20 20 28 6c the list.... (l
45e0: 6f 6f 70 20 28 63 61 72 20 6e 65 77 74 61 6c 29 oop (car newtal)
45f0: 28 63 64 72 20 6e 65 77 74 61 6c 29 29 29 0a 09 (cdr newtal)))..
4600: 09 09 3b 3b 20 74 68 65 20 77 61 69 74 6f 6e 20 ..;; the waiton
4610: 69 73 20 46 41 49 4c 20 73 6f 20 6e 6f 20 70 6f is FAIL so no po
4620: 69 6e 74 20 69 6e 20 74 72 79 69 6e 67 20 74 6f int in trying to
4630: 20 72 75 6e 20 68 65 64 20 65 76 65 72 20 61 67 run hed ever ag
4640: 61 69 6e 0a 09 09 09 28 69 66 20 28 6e 6f 74 20 ain....(if (not
4650: 28 6e 75 6c 6c 3f 20 74 61 6c 29 29 0a 09 09 09 (null? tal))....
4660: 20 20 20 20 28 69 66 20 28 76 65 63 74 6f 72 3f (if (vector?
4670: 20 68 65 64 29 0a 09 09 09 09 28 62 65 67 69 6e hed).....(begin
4680: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 31 20 (debug:print 1
4690: 22 57 41 52 4e 3a 20 44 72 6f 70 70 69 6e 67 20 "WARN: Dropping
46a0: 74 65 73 74 20 22 20 28 64 62 3a 74 65 73 74 2d test " (db:test-
46b0: 67 65 74 2d 74 65 73 74 6e 61 6d 65 20 68 65 64 get-testname hed
46c0: 29 20 22 2f 22 20 28 64 62 3a 74 65 73 74 2d 67 ) "/" (db:test-g
46d0: 65 74 2d 69 74 65 6d 2d 70 61 74 68 20 68 65 64 et-item-path hed
46e0: 29 0a 09 09 09 09 09 09 20 20 20 20 22 20 66 72 )....... " fr
46f0: 6f 6d 20 74 68 65 20 6c 61 75 6e 63 68 20 6c 69 om the launch li
4700: 73 74 20 61 73 20 69 74 20 68 61 73 20 70 72 65 st as it has pre
4710: 72 65 71 75 69 73 74 65 73 20 74 68 61 74 20 61 requistes that a
4720: 72 65 20 46 41 49 4c 22 29 0a 09 09 09 09 20 20 re FAIL").....
4730: 20 20 20 20 20 28 6c 6f 6f 70 20 28 63 61 72 20 (loop (car
4740: 74 61 6c 29 28 63 64 72 20 74 61 6c 29 29 29 0a tal)(cdr tal))).
4750: 09 09 09 09 28 62 65 67 69 6e 0a 09 09 09 09 20 ....(begin.....
4760: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 31 20 (debug:print 1
4770: 22 57 41 52 4e 3a 20 54 65 73 74 20 6e 6f 74 20 "WARN: Test not
4780: 70 72 6f 63 65 73 73 65 64 20 63 6f 72 72 65 63 processed correc
4790: 74 6c 79 2e 20 43 6f 75 6c 64 20 62 65 20 61 20 tly. Could be a
47a0: 72 61 63 65 20 63 6f 6e 64 69 74 69 6f 6e 20 69 race condition i
47b0: 6e 20 79 6f 75 72 20 74 65 73 74 20 69 6d 70 6c n your test impl
47c0: 65 6d 65 6e 74 61 74 69 6f 6e 3f 20 22 20 68 65 ementation? " he
47d0: 64 29 20 3b 3b 20 20 22 20 61 73 20 69 74 20 68 d) ;; " as it h
47e0: 61 73 20 70 72 65 72 65 71 75 69 73 74 65 73 20 as prerequistes
47f0: 74 68 61 74 20 61 72 65 20 46 41 49 4c 2e 20 28 that are FAIL. (
4800: 4e 4f 54 45 3a 20 68 65 64 20 69 73 20 6e 6f 74 NOTE: hed is not
4810: 20 61 20 76 65 63 74 6f 72 29 22 29 0a 09 09 09 a vector)")....
4820: 09 20 20 28 6c 6f 6f 70 20 68 65 64 20 74 61 6c . (loop hed tal
4830: 29 29 29 29 29 29 29 29 29 0a 09 20 20 20 20 20 )))))))))..
4840: 0a 09 20 20 20 20 20 3b 3b 20 63 61 73 65 20 77 .. ;; case w
4850: 68 65 72 65 20 61 6e 20 69 74 65 6d 73 20 63 61 here an items ca
4860: 6d 65 20 69 6e 20 61 73 20 61 20 6c 69 73 74 20 me in as a list
4870: 62 65 65 6e 20 70 72 6f 63 65 73 73 65 64 0a 09 been processed..
4880: 20 20 20 20 20 28 28 61 6e 64 20 28 6c 69 73 74 ((and (list
4890: 3f 20 69 74 65 6d 73 29 20 20 20 20 20 3b 3b 20 ? items) ;;
48a0: 74 68 75 73 20 77 65 20 6b 6e 6f 77 20 6f 75 72 thus we know our
48b0: 20 69 74 65 6d 73 20 61 72 65 20 61 6c 72 65 61 items are alrea
48c0: 64 79 20 63 61 6c 63 75 6c 61 74 65 64 0a 09 09 dy calculated...
48d0: 20 20 20 28 6e 6f 74 20 20 20 69 74 65 6d 64 61 (not itemda
48e0: 74 29 29 20 3b 3b 20 61 6e 64 20 6e 6f 74 20 79 t)) ;; and not y
48f0: 65 74 20 65 78 70 61 6e 64 65 64 20 69 6e 74 6f et expanded into
4900: 20 74 68 65 20 6c 69 73 74 20 6f 66 20 74 68 69 the list of thi
4910: 6e 67 73 20 74 6f 20 62 65 20 64 6f 6e 65 0a 09 ngs to be done..
4920: 20 20 20 20 20 20 28 69 66 20 28 61 6e 64 20 28 (if (and (
4930: 3e 3d 20 2a 76 65 72 62 6f 73 69 74 79 2a 20 31 >= *verbosity* 1
4940: 29 0a 09 09 20 20 20 20 20 20 20 28 3e 20 28 6c )... (> (l
4950: 65 6e 67 74 68 20 69 74 65 6d 73 29 20 30 29 0a ength items) 0).
4960: 09 09 20 20 20 20 20 20 20 28 3e 20 28 6c 65 6e .. (> (len
4970: 67 74 68 20 28 63 61 72 20 69 74 65 6d 73 29 29 gth (car items))
4980: 20 30 29 29 0a 09 09 20 20 28 70 70 20 69 74 65 0))... (pp ite
4990: 6d 73 29 29 0a 09 20 20 20 20 20 20 3b 3b 20 28 ms)).. ;; (
49a0: 69 66 20 28 3e 3d 20 2a 76 65 72 62 6f 73 69 74 if (>= *verbosit
49b0: 79 2a 20 35 29 0a 09 20 20 20 20 20 20 3b 3b 20 y* 5).. ;;
49c0: 20 20 20 20 28 62 65 67 69 6e 0a 09 20 20 20 20 (begin..
49d0: 20 20 3b 3b 20 20 20 20 20 20 20 28 70 72 69 6e ;; (prin
49e0: 74 20 22 69 74 65 6d 73 3a 20 22 29 20 20 20 20 t "items: ")
49f0: 20 28 70 70 20 28 69 74 65 6d 2d 61 73 73 6f 63 (pp (item-assoc
4a00: 2d 3e 69 74 65 6d 2d 6c 69 73 74 20 69 74 65 6d ->item-list item
4a10: 73 29 29 0a 09 20 20 20 20 20 20 3b 3b 20 20 20 s)).. ;;
4a20: 20 20 20 20 28 70 72 69 6e 74 20 22 69 74 65 6d (print "item
4a30: 73 74 61 62 6c 65 3a 20 22 29 28 70 70 20 28 69 stable: ")(pp (i
4a40: 74 65 6d 2d 74 61 62 6c 65 2d 3e 69 74 65 6d 2d tem-table->item-
4a50: 6c 69 73 74 20 69 74 65 6d 73 74 61 62 6c 65 29 list itemstable)
4a60: 29 29 29 0a 09 20 20 20 20 20 20 28 66 6f 72 2d ))).. (for-
4a70: 65 61 63 68 0a 09 20 20 20 20 20 20 20 28 6c 61 each.. (la
4a80: 6d 62 64 61 20 28 6d 79 2d 69 74 65 6d 64 61 74 mbda (my-itemdat
4a90: 29 0a 09 09 20 28 6c 65 74 2a 20 28 28 6e 65 77 )... (let* ((new
4aa0: 2d 74 65 73 74 2d 72 65 63 6f 72 64 20 28 6c 65 -test-record (le
4ab0: 74 20 28 28 6e 65 77 72 65 63 20 28 6d 61 6b 65 t ((newrec (make
4ac0: 2d 74 65 73 74 73 3a 74 65 73 74 71 75 65 75 65 -tests:testqueue
4ad0: 29 29 29 0a 09 09 09 09 09 20 20 20 28 76 65 63 )))...... (vec
4ae0: 74 6f 72 2d 63 6f 70 79 21 20 74 65 73 74 2d 72 tor-copy! test-r
4af0: 65 63 6f 72 64 20 6e 65 77 72 65 63 29 0a 09 09 ecord newrec)...
4b00: 09 09 09 20 20 20 6e 65 77 72 65 63 29 29 0a 09 ... newrec))..
4b10: 09 09 28 6d 79 2d 69 74 65 6d 2d 70 61 74 68 20 ..(my-item-path
4b20: 28 69 74 65 6d 2d 6c 69 73 74 2d 3e 70 61 74 68 (item-list->path
4b30: 20 6d 79 2d 69 74 65 6d 64 61 74 29 29 29 0a 09 my-itemdat)))..
4b40: 09 20 20 20 28 69 66 20 28 70 61 74 74 2d 6c 69 . (if (patt-li
4b50: 73 74 2d 6d 61 74 63 68 20 6d 79 2d 69 74 65 6d st-match my-item
4b60: 2d 70 61 74 68 20 69 74 65 6d 2d 70 61 74 74 73 -path item-patts
4b70: 29 20 20 20 20 20 20 20 20 20 20 20 3b 3b 20 79 ) ;; y
4b80: 65 73 2c 20 77 65 20 77 61 6e 74 20 74 6f 20 70 es, we want to p
4b90: 72 6f 63 65 73 73 20 74 68 69 73 20 69 74 65 6d rocess this item
4ba0: 2c 20 4e 4f 54 45 3a 20 53 68 6f 75 6c 64 20 6e , NOTE: Should n
4bb0: 6f 74 20 6e 65 65 64 20 74 68 69 73 20 63 68 65 ot need this che
4bc0: 63 6b 20 68 65 72 65 21 0a 09 09 20 20 20 20 20 ck here!...
4bd0: 20 20 28 6c 65 74 20 28 28 6e 65 77 74 65 73 74 (let ((newtest
4be0: 6e 61 6d 65 20 28 63 6f 6e 63 20 68 65 64 20 22 name (conc hed "
4bf0: 2f 22 20 6d 79 2d 69 74 65 6d 2d 70 61 74 68 29 /" my-item-path)
4c00: 29 29 20 20 20 20 3b 3b 20 74 65 73 74 20 6e 61 )) ;; test na
4c10: 6d 65 73 20 61 72 65 20 75 6e 69 71 75 65 20 6f mes are unique o
4c20: 6e 20 74 65 73 74 6e 61 6d 65 2f 69 74 65 6d 2d n testname/item-
4c30: 70 61 74 68 0a 09 09 09 20 28 74 65 73 74 73 3a path.... (tests:
4c40: 74 65 73 74 71 75 65 75 65 2d 73 65 74 2d 69 74 testqueue-set-it
4c50: 65 6d 73 21 20 20 20 20 20 6e 65 77 2d 74 65 73 ems! new-tes
4c60: 74 2d 72 65 63 6f 72 64 20 23 66 29 0a 09 09 09 t-record #f)....
4c70: 20 28 74 65 73 74 73 3a 74 65 73 74 71 75 65 75 (tests:testqueu
4c80: 65 2d 73 65 74 2d 69 74 65 6d 64 61 74 21 20 20 e-set-itemdat!
4c90: 20 6e 65 77 2d 74 65 73 74 2d 72 65 63 6f 72 64 new-test-record
4ca0: 20 6d 79 2d 69 74 65 6d 64 61 74 29 0a 09 09 09 my-itemdat)....
4cb0: 20 28 74 65 73 74 73 3a 74 65 73 74 71 75 65 75 (tests:testqueu
4cc0: 65 2d 73 65 74 2d 69 74 65 6d 5f 70 61 74 68 21 e-set-item_path!
4cd0: 20 6e 65 77 2d 74 65 73 74 2d 72 65 63 6f 72 64 new-test-record
4ce0: 20 6d 79 2d 69 74 65 6d 2d 70 61 74 68 29 0a 09 my-item-path)..
4cf0: 09 09 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 73 .. (hash-table-s
4d00: 65 74 21 20 74 65 73 74 2d 72 65 63 6f 72 64 73 et! test-records
4d10: 20 6e 65 77 74 65 73 74 6e 61 6d 65 20 6e 65 77 newtestname new
4d20: 2d 74 65 73 74 2d 72 65 63 6f 72 64 29 0a 09 09 -test-record)...
4d30: 09 20 28 73 65 74 21 20 74 61 6c 20 28 63 6f 6e . (set! tal (con
4d40: 73 20 6e 65 77 74 65 73 74 6e 61 6d 65 20 74 61 s newtestname ta
4d50: 6c 29 29 29 29 29 29 20 3b 3b 20 73 69 6e 63 65 l)))))) ;; since
4d60: 20 74 68 65 73 65 20 61 72 65 20 69 74 65 6d 69 these are itemi
4d70: 7a 65 64 20 63 72 65 61 74 65 20 6e 65 77 20 74 zed create new t
4d80: 65 73 74 20 6e 61 6d 65 73 20 74 65 73 74 6e 61 est names testna
4d90: 6d 65 2f 69 74 65 6d 70 61 74 68 0a 09 20 20 20 me/itempath..
4da0: 20 20 20 20 69 74 65 6d 73 29 0a 09 20 20 20 20 items)..
4db0: 20 20 28 69 66 20 28 6e 6f 74 20 28 6e 75 6c 6c (if (not (null
4dc0: 3f 20 74 61 6c 29 29 0a 09 09 20 20 28 6c 6f 6f ? tal))... (loo
4dd0: 70 20 28 63 61 72 20 74 61 6c 29 28 63 64 72 20 p (car tal)(cdr
4de0: 74 61 6c 29 29 29 29 0a 0a 09 20 20 20 20 20 3b tal))))... ;
4df0: 3b 20 69 66 20 69 74 65 6d 73 20 69 73 20 61 20 ; if items is a
4e00: 70 72 6f 63 20 74 68 65 6e 20 6e 65 65 64 20 74 proc then need t
4e10: 6f 20 72 75 6e 20 69 74 65 6d 73 3a 67 65 74 2d o run items:get-
4e20: 69 74 65 6d 73 2d 66 72 6f 6d 2d 63 6f 6e 66 69 items-from-confi
4e30: 67 2c 20 67 65 74 20 74 68 65 20 6c 69 73 74 20 g, get the list
4e40: 61 6e 64 20 6c 6f 6f 70 20 0a 09 20 20 20 20 20 and loop ..
4e50: 3b 3b 20 20 20 20 2d 20 62 75 74 20 6f 6e 6c 79 ;; - but only
4e60: 20 64 6f 20 74 68 61 74 20 69 66 20 72 65 73 6f do that if reso
4e70: 75 72 63 65 73 20 65 78 69 73 74 20 74 6f 20 6b urces exist to k
4e80: 69 63 6b 20 6f 66 66 20 74 68 65 20 6a 6f 62 0a ick off the job.
4e90: 09 20 20 20 20 20 28 28 6f 72 20 28 70 72 6f 63 . ((or (proc
4ea0: 65 64 75 72 65 3f 20 69 74 65 6d 73 29 28 65 71 edure? items)(eq
4eb0: 3f 20 69 74 65 6d 73 20 27 68 61 76 65 2d 70 72 ? items 'have-pr
4ec0: 6f 63 65 64 75 72 65 29 29 0a 09 20 20 20 20 20 ocedure))..
4ed0: 20 28 6c 65 74 20 28 28 63 61 6e 2d 72 75 6e 2d (let ((can-run-
4ee0: 6d 6f 72 65 20 20 20 20 28 6f 70 65 6e 2d 72 75 more (open-ru
4ef0: 6e 2d 63 6c 6f 73 65 20 72 75 6e 73 3a 63 61 6e n-close runs:can
4f00: 2d 72 75 6e 2d 6d 6f 72 65 2d 74 65 73 74 73 20 -run-more-tests
4f10: 23 66 20 74 65 73 74 2d 72 65 63 6f 72 64 29 29 #f test-record))
4f20: 29 0a 09 09 28 69 66 20 63 61 6e 2d 72 75 6e 2d )...(if can-run-
4f30: 6d 6f 72 65 0a 09 09 20 20 20 20 28 6c 65 74 2a more... (let*
4f40: 20 28 28 70 72 65 72 65 71 73 2d 6e 6f 74 2d 6d ((prereqs-not-m
4f50: 65 74 20 28 6f 70 65 6e 2d 72 75 6e 2d 63 6c 6f et (open-run-clo
4f60: 73 65 20 64 62 3a 67 65 74 2d 70 72 65 72 65 71 se db:get-prereq
4f70: 73 2d 6e 6f 74 2d 6d 65 74 20 23 66 20 72 75 6e s-not-met #f run
4f80: 2d 69 64 20 77 61 69 74 6f 6e 73 20 69 74 65 6d -id waitons item
4f90: 2d 70 61 74 68 20 6d 6f 64 65 3a 20 74 65 73 74 -path mode: test
4fa0: 6d 6f 64 65 29 29 0a 09 09 09 20 20 20 28 66 61 mode)).... (fa
4fb0: 69 6c 73 20 20 20 20 20 20 20 20 20 20 20 28 63 ils (c
4fc0: 61 6c 63 2d 66 61 69 6c 73 20 70 72 65 72 65 71 alc-fails prereq
4fd0: 73 2d 6e 6f 74 2d 6d 65 74 29 29 0a 09 09 09 20 s-not-met))....
4fe0: 20 20 28 6e 6f 6e 2d 63 6f 6d 70 6c 65 74 65 64 (non-completed
4ff0: 20 20 20 28 63 61 6c 63 2d 6e 6f 74 2d 63 6f 6d (calc-not-com
5000: 70 6c 65 74 65 64 20 70 72 65 72 65 71 73 2d 6e pleted prereqs-n
5010: 6f 74 2d 6d 65 74 29 29 29 0a 09 09 20 20 20 20 ot-met)))...
5020: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 38 (debug:print 8
5030: 20 22 49 4e 46 4f 3a 20 63 61 6e 2d 72 75 6e 2d "INFO: can-run-
5040: 6d 6f 72 65 3a 20 22 20 63 61 6e 2d 72 75 6e 2d more: " can-run-
5050: 6d 6f 72 65 0a 09 09 09 09 20 20 20 22 5c 6e 20 more..... "\n
5060: 70 72 65 72 65 71 73 2d 6e 6f 74 2d 6d 65 74 3a prereqs-not-met:
5070: 20 22 20 28 70 72 65 74 74 79 2d 73 74 72 69 6e " (pretty-strin
5080: 67 20 70 72 65 72 65 71 73 2d 6e 6f 74 2d 6d 65 g prereqs-not-me
5090: 74 29 0a 09 09 09 09 20 20 20 22 5c 6e 20 6e 6f t)..... "\n no
50a0: 6e 2d 63 6f 6d 70 6c 65 74 65 64 3a 20 20 20 22 n-completed: "
50b0: 20 28 70 72 65 74 74 79 2d 73 74 72 69 6e 67 20 (pretty-string
50c0: 6e 6f 6e 2d 63 6f 6d 70 6c 65 74 65 64 29 20 0a non-completed) .
50d0: 09 09 09 09 20 20 20 22 5c 6e 20 66 61 69 6c 73 .... "\n fails
50e0: 3a 20 20 20 20 20 20 20 20 20 20 20 22 20 28 70 : " (p
50f0: 72 65 74 74 79 2d 73 74 72 69 6e 67 20 66 61 69 retty-string fai
5100: 6c 73 29 0a 09 09 09 09 20 20 20 22 5c 6e 20 74 ls)..... "\n t
5110: 65 73 74 6d 6f 64 65 3a 20 20 20 20 20 20 20 20 estmode:
5120: 22 20 74 65 73 74 6d 6f 64 65 0a 09 09 09 09 20 " testmode.....
5130: 20 20 22 5c 6e 20 28 65 71 3f 20 74 65 73 74 6d "\n (eq? testm
5140: 6f 64 65 20 27 74 6f 70 6c 65 76 65 6c 29 20 22 ode 'toplevel) "
5150: 20 28 65 71 3f 20 74 65 73 74 6d 6f 64 65 20 27 (eq? testmode '
5160: 74 6f 70 6c 65 76 65 6c 29 0a 09 09 09 09 20 20 toplevel).....
5170: 20 22 5c 6e 20 28 6e 75 6c 6c 3f 20 6e 6f 6e 2d "\n (null? non-
5180: 63 6f 6d 70 6c 65 74 65 64 29 20 20 20 20 22 20 completed) "
5190: 28 6e 75 6c 6c 3f 20 6e 6f 6e 2d 63 6f 6d 70 6c (null? non-compl
51a0: 65 74 65 64 29 29 0a 09 09 20 20 20 20 20 20 28 eted))... (
51b0: 63 6f 6e 64 20 0a 09 09 20 20 20 20 20 20 20 28 cond ... (
51c0: 28 6f 72 20 28 6e 75 6c 6c 3f 20 70 72 65 72 65 (or (null? prere
51d0: 71 73 2d 6e 6f 74 2d 6d 65 74 29 20 3b 3b 20 61 qs-not-met) ;; a
51e0: 6c 6c 20 70 72 65 72 65 71 73 20 6d 65 74 2c 20 ll prereqs met,
51f0: 66 69 72 65 20 6f 66 66 20 74 68 65 20 74 65 73 fire off the tes
5200: 74 0a 09 09 09 20 20 20 20 3b 3b 20 6f 72 2c 20 t.... ;; or,
5210: 69 66 20 69 74 20 69 73 20 61 20 27 74 6f 70 6c if it is a 'topl
5220: 65 76 65 6c 20 74 65 73 74 20 61 6e 64 20 61 6c evel test and al
5230: 6c 20 70 72 65 72 65 71 73 20 6e 6f 74 20 6d 65 l prereqs not me
5240: 74 20 61 72 65 20 43 4f 4d 50 4c 45 54 45 44 20 t are COMPLETED
5250: 74 68 65 6e 20 6c 61 75 6e 63 68 0a 09 09 09 20 then launch....
5260: 20 20 20 28 61 6e 64 20 28 65 71 3f 20 74 65 73 (and (eq? tes
5270: 74 6d 6f 64 65 20 27 74 6f 70 6c 65 76 65 6c 29 tmode 'toplevel)
5280: 0a 09 09 09 09 20 28 6e 75 6c 6c 3f 20 6e 6f 6e ..... (null? non
5290: 2d 63 6f 6d 70 6c 65 74 65 64 29 29 29 0a 09 09 -completed)))...
52a0: 09 28 6c 65 74 20 28 28 74 65 73 74 2d 6e 61 6d .(let ((test-nam
52b0: 65 20 28 74 65 73 74 73 3a 74 65 73 74 71 75 65 e (tests:testque
52c0: 75 65 2d 67 65 74 2d 74 65 73 74 6e 61 6d 65 20 ue-get-testname
52d0: 74 65 73 74 2d 72 65 63 6f 72 64 29 29 29 0a 09 test-record)))..
52e0: 09 09 20 20 28 73 65 74 65 6e 76 20 22 4d 54 5f .. (setenv "MT_
52f0: 54 45 53 54 5f 4e 41 4d 45 22 20 74 65 73 74 2d TEST_NAME" test-
5300: 6e 61 6d 65 29 20 3b 3b 20 0a 09 09 09 20 20 28 name) ;; .... (
5310: 73 65 74 65 6e 76 20 22 4d 54 5f 52 55 4e 4e 41 setenv "MT_RUNNA
5320: 4d 45 22 20 20 20 72 75 6e 6e 61 6d 65 29 0a 09 ME" runname)..
5330: 09 09 20 20 28 6f 70 65 6e 2d 72 75 6e 2d 63 6c .. (open-run-cl
5340: 6f 73 65 2d 6d 65 61 73 75 72 65 20 73 65 74 2d ose-measure set-
5350: 6d 65 67 61 74 65 73 74 2d 65 6e 76 2d 76 61 72 megatest-env-var
5360: 73 20 23 66 20 72 75 6e 2d 69 64 29 20 3b 3b 20 s #f run-id) ;;
5370: 74 68 65 73 65 20 6d 61 79 20 62 65 20 6e 65 65 these may be nee
5380: 64 65 64 20 62 79 20 74 68 65 20 6c 61 75 6e 63 ded by the launc
5390: 68 69 6e 67 20 70 72 6f 63 65 73 73 0a 09 09 09 hing process....
53a0: 20 20 28 6c 65 74 20 28 28 69 74 65 6d 73 2d 6c (let ((items-l
53b0: 69 73 74 20 28 69 74 65 6d 73 3a 67 65 74 2d 69 ist (items:get-i
53c0: 74 65 6d 73 2d 66 72 6f 6d 2d 63 6f 6e 66 69 67 tems-from-config
53d0: 20 74 63 6f 6e 66 69 67 29 29 29 0a 09 09 09 20 tconfig)))....
53e0: 20 20 20 28 69 66 20 28 6c 69 73 74 3f 20 69 74 (if (list? it
53f0: 65 6d 73 2d 6c 69 73 74 29 0a 09 09 09 09 28 62 ems-list).....(b
5400: 65 67 69 6e 0a 09 09 09 09 20 20 28 74 65 73 74 egin..... (test
5410: 73 3a 74 65 73 74 71 75 65 75 65 2d 73 65 74 2d s:testqueue-set-
5420: 69 74 65 6d 73 21 20 74 65 73 74 2d 72 65 63 6f items! test-reco
5430: 72 64 20 69 74 65 6d 73 2d 6c 69 73 74 29 0a 09 rd items-list)..
5440: 09 09 09 20 20 28 6c 6f 6f 70 20 68 65 64 20 74 ... (loop hed t
5450: 61 6c 29 29 0a 09 09 09 09 28 62 65 67 69 6e 0a al)).....(begin.
5460: 09 09 09 09 20 20 28 64 65 62 75 67 3a 70 72 69 .... (debug:pri
5470: 6e 74 20 30 20 22 45 52 52 4f 52 3a 20 54 68 65 nt 0 "ERROR: The
5480: 20 70 72 6f 63 20 66 72 6f 6d 20 72 65 61 64 69 proc from readi
5490: 6e 67 20 74 68 65 20 73 65 74 75 70 20 64 69 64 ng the setup did
54a0: 20 6e 6f 74 20 79 69 65 6c 64 20 61 20 6c 69 73 not yield a lis
54b0: 74 20 2d 20 70 6c 65 61 73 65 20 72 65 70 6f 72 t - please repor
54c0: 74 20 74 68 69 73 22 29 0a 09 09 09 09 20 20 28 t this")..... (
54d0: 65 78 69 74 20 31 29 29 29 29 29 29 0a 09 09 20 exit 1))))))...
54e0: 20 20 20 20 20 20 28 28 6e 75 6c 6c 3f 20 66 61 ((null? fa
54f0: 69 6c 73 29 0a 09 09 09 28 6c 6f 6f 70 20 28 63 ils)....(loop (c
5500: 61 72 20 6e 65 77 74 61 6c 29 28 63 64 72 20 6e ar newtal)(cdr n
5510: 65 77 74 61 6c 29 29 29 20 3b 3b 20 61 6e 20 69 ewtal))) ;; an i
5520: 73 73 75 65 20 77 69 74 68 20 70 72 65 72 65 71 ssue with prereq
5530: 73 20 6e 6f 74 20 79 65 74 20 6d 65 74 3f 0a 09 s not yet met?..
5540: 09 20 20 20 20 20 20 20 28 28 61 6e 64 20 28 6e . ((and (n
5550: 6f 74 20 28 6e 75 6c 6c 3f 20 66 61 69 6c 73 29 ot (null? fails)
5560: 29 28 65 71 3f 20 74 65 73 74 6d 6f 64 65 20 27 )(eq? testmode '
5570: 6e 6f 72 6d 61 6c 29 29 0a 09 09 09 28 64 65 62 normal))....(deb
5580: 75 67 3a 70 72 69 6e 74 20 31 20 22 49 4e 46 4f ug:print 1 "INFO
5590: 3a 20 74 65 73 74 20 22 20 20 68 65 64 20 22 20 : test " hed "
55a0: 28 6d 6f 64 65 3d 22 20 74 65 73 74 6d 6f 64 65 (mode=" testmode
55b0: 20 22 29 20 68 61 73 20 66 61 69 6c 65 64 20 70 ") has failed p
55c0: 72 65 72 65 71 75 69 73 69 74 65 28 73 29 3b 20 rerequisite(s);
55d0: 22 0a 09 09 09 09 20 20 20 20 20 28 73 74 72 69 "..... (stri
55e0: 6e 67 2d 69 6e 74 65 72 73 70 65 72 73 65 20 28 ng-intersperse (
55f0: 6d 61 70 20 28 6c 61 6d 62 64 61 20 28 74 29 28 map (lambda (t)(
5600: 63 6f 6e 63 20 28 64 62 3a 74 65 73 74 2d 67 65 conc (db:test-ge
5610: 74 2d 74 65 73 74 6e 61 6d 65 20 74 29 20 22 3a t-testname t) ":
5620: 22 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 73 " (db:test-get-s
5630: 74 61 74 65 20 74 29 22 2f 22 28 64 62 3a 74 65 tate t)"/"(db:te
5640: 73 74 2d 67 65 74 2d 73 74 61 74 75 73 20 74 29 st-get-status t)
5650: 29 29 20 66 61 69 6c 73 29 20 22 2c 20 22 29 0a )) fails) ", ").
5660: 09 09 09 09 20 20 20 20 20 22 2c 20 72 65 6d 6f .... ", remo
5670: 76 69 6e 67 20 69 74 20 66 72 6f 6d 20 74 6f 2d ving it from to-
5680: 64 6f 20 6c 69 73 74 22 29 0a 09 09 09 28 69 66 do list")....(if
5690: 20 28 6e 6f 74 20 28 6e 75 6c 6c 3f 20 74 61 6c (not (null? tal
56a0: 29 29 0a 09 09 09 20 20 20 20 28 6c 6f 6f 70 20 )).... (loop
56b0: 28 63 61 72 20 74 61 6c 29 28 63 64 72 20 74 61 (car tal)(cdr ta
56c0: 6c 29 29 29 29 0a 09 09 20 20 20 20 20 20 20 28 l))))... (
56d0: 65 6c 73 65 0a 09 09 09 28 64 65 62 75 67 3a 70 else....(debug:p
56e0: 72 69 6e 74 20 38 20 22 45 52 52 4f 52 3a 20 4e rint 8 "ERROR: N
56f0: 6f 20 68 61 6e 64 6c 65 72 20 66 6f 72 20 74 68 o handler for th
5700: 69 73 20 63 6f 6e 64 69 74 69 6f 6e 2e 22 29 0a is condition.").
5710: 09 09 09 3b 3b 20 09 20 20 20 20 20 22 5c 6e 20 ...;; . "\n
5720: 20 68 65 64 3a 20 20 20 20 20 20 20 20 20 20 20 hed:
5730: 20 22 20 68 65 64 20 0a 09 09 09 3b 3b 20 09 20 " hed ....;; .
5740: 20 20 20 20 22 5c 6e 20 66 61 69 6c 73 3a 20 20 "\n fails:
5750: 20 20 20 20 20 20 20 20 20 22 20 28 73 74 72 69 " (stri
5760: 6e 67 2d 69 6e 74 65 72 73 70 65 72 73 65 20 28 ng-intersperse (
5770: 6d 61 70 20 64 62 3a 74 65 73 74 2d 67 65 74 2d map db:test-get-
5780: 74 65 73 74 6e 61 6d 65 20 66 61 69 6c 73 29 20 testname fails)
5790: 22 2c 22 29 0a 09 09 09 3b 3b 20 09 20 20 20 20 ",")....;; .
57a0: 20 22 5c 6e 20 74 65 73 74 6d 6f 64 65 3a 20 20 "\n testmode:
57b0: 20 20 20 20 20 20 22 20 74 65 73 74 6d 6f 64 65 " testmode
57c0: 0a 09 09 09 3b 3b 20 09 20 20 20 20 20 22 5c 6e ....;; . "\n
57d0: 20 70 72 65 72 65 71 73 2d 6e 6f 74 2d 6d 65 74 prereqs-not-met
57e0: 3a 20 22 20 28 70 72 65 74 74 79 2d 73 74 72 69 : " (pretty-stri
57f0: 6e 67 20 70 72 65 72 65 71 73 2d 6e 6f 74 2d 6d ng prereqs-not-m
5800: 65 74 29 0a 09 09 09 3b 3b 20 09 20 20 20 20 20 et)....;; .
5810: 22 5c 6e 20 69 74 65 6d 73 3a 20 20 20 20 20 20 "\n items:
5820: 20 20 20 20 20 22 20 69 74 65 6d 73 29 0a 09 09 " items)...
5830: 09 28 6c 6f 6f 70 20 28 63 61 72 20 6e 65 77 74 .(loop (car newt
5840: 61 6c 29 28 63 64 72 20 6e 65 77 74 61 6c 29 29 al)(cdr newtal))
5850: 29 29 29 0a 09 09 20 20 20 20 3b 3b 20 69 66 20 )))... ;; if
5860: 63 61 6e 27 74 20 72 75 6e 20 6d 6f 72 65 20 6a can't run more j
5870: 75 73 74 20 6c 6f 6f 70 20 77 69 74 68 20 6e 65 ust loop with ne
5880: 78 74 20 70 6f 73 73 69 62 6c 65 20 74 65 73 74 xt possible test
5890: 0a 09 09 20 20 20 20 28 62 65 67 69 6e 0a 09 09 ... (begin...
58a0: 20 20 20 20 20 20 28 74 68 72 65 61 64 2d 73 6c (thread-sl
58b0: 65 65 70 21 20 28 2b 20 31 20 2a 67 6c 6f 62 61 eep! (+ 1 *globa
58c0: 6c 2d 64 65 6c 74 61 2a 29 29 0a 09 09 20 20 20 l-delta*))...
58d0: 20 20 20 28 6c 6f 6f 70 20 28 63 61 72 20 6e 65 (loop (car ne
58e0: 77 74 61 6c 29 28 63 64 72 20 6e 65 77 74 61 6c wtal)(cdr newtal
58f0: 29 29 29 29 29 29 0a 09 20 20 20 20 20 0a 09 20 )))))).. ..
5900: 20 20 20 20 3b 3b 20 74 68 69 73 20 63 61 73 65 ;; this case
5910: 20 73 68 6f 75 6c 64 20 6e 6f 74 20 68 61 70 70 should not happ
5920: 65 6e 2c 20 61 64 64 65 64 20 74 6f 20 68 65 6c en, added to hel
5930: 70 20 63 61 74 63 68 20 61 6e 79 20 62 75 67 73 p catch any bugs
5940: 0a 09 20 20 20 20 20 28 28 61 6e 64 20 28 6c 69 .. ((and (li
5950: 73 74 3f 20 69 74 65 6d 73 29 20 69 74 65 6d 64 st? items) itemd
5960: 61 74 29 0a 09 20 20 20 20 20 20 28 64 65 62 75 at).. (debu
5970: 67 3a 70 72 69 6e 74 20 30 20 22 45 52 52 4f 52 g:print 0 "ERROR
5980: 3a 20 53 68 6f 75 6c 64 20 6e 6f 74 20 68 61 76 : Should not hav
5990: 65 20 61 20 6c 69 73 74 20 6f 66 20 69 74 65 6d e a list of item
59a0: 73 20 69 6e 20 61 20 74 65 73 74 20 61 6e 64 20 s in a test and
59b0: 74 68 65 20 69 74 65 6d 73 70 61 74 68 20 73 65 the itemspath se
59c0: 74 20 2d 20 70 6c 65 61 73 65 20 72 65 70 6f 72 t - please repor
59d0: 74 20 74 68 69 73 22 29 0a 09 20 20 20 20 20 20 t this")..
59e0: 28 65 78 69 74 20 31 29 29 29 29 0a 09 20 20 0a (exit 1)))).. .
59f0: 09 20 20 3b 3b 20 77 65 20 67 65 74 20 68 65 72 . ;; we get her
5a00: 65 20 6f 6e 20 22 64 72 6f 70 20 74 68 72 6f 75 e on "drop throu
5a10: 67 68 22 20 2d 20 6c 6f 6f 70 20 66 6f 72 20 6e gh" - loop for n
5a20: 65 78 74 20 74 65 73 74 20 69 6e 20 71 75 65 75 ext test in queu
5a30: 65 0a 09 20 20 28 69 66 20 28 6e 75 6c 6c 3f 20 e.. (if (null?
5a40: 74 61 6c 29 0a 09 20 20 20 20 20 20 28 62 65 67 tal).. (beg
5a50: 69 6e 0a 09 09 3b 3b 20 46 49 58 4d 45 21 21 21 in...;; FIXME!!!
5a60: 21 20 54 48 49 53 20 53 48 4f 55 4c 44 20 4e 4f ! THIS SHOULD NO
5a70: 54 20 52 45 51 55 49 52 45 20 41 4e 20 45 58 49 T REQUIRE AN EXI
5a80: 54 21 21 21 21 21 21 21 0a 09 09 28 64 65 62 75 T!!!!!!!...(debu
5a90: 67 3a 70 72 69 6e 74 20 31 20 22 49 4e 46 4f 3a g:print 1 "INFO:
5aa0: 20 41 6c 6c 20 74 65 73 74 73 20 6c 61 75 6e 63 All tests launc
5ab0: 68 65 64 22 29 0a 09 09 28 74 68 72 65 61 64 2d hed")...(thread-
5ac0: 73 6c 65 65 70 21 20 30 2e 35 29 0a 09 09 3b 3b sleep! 0.5)...;;
5ad0: 20 46 49 58 4d 45 21 20 54 68 69 73 20 68 61 72 FIXME! This har
5ae0: 73 68 20 65 78 69 74 20 73 68 6f 75 6c 64 20 6e sh exit should n
5af0: 6f 74 20 62 65 20 6e 65 63 65 73 73 61 72 79 2e ot be necessary.
5b00: 2e 2e 2e 0a 09 09 28 69 66 20 28 6e 6f 74 20 2a ......(if (not *
5b10: 72 75 6e 72 65 6d 6f 74 65 2a 29 28 65 78 69 74 runremote*)(exit
5b20: 29 29 20 3b 3b 20 0a 09 09 23 66 29 20 3b 3b 20 )) ;; ...#f) ;;
5b30: 72 65 74 75 72 6e 20 61 20 23 66 20 61 73 20 61 return a #f as a
5b40: 20 68 69 6e 74 20 74 68 61 74 20 77 65 20 61 72 hint that we ar
5b50: 65 20 64 6f 6e 65 0a 09 20 20 20 20 20 20 3b 3b e done.. ;;
5b60: 20 48 65 72 65 20 77 65 20 6e 65 65 64 20 74 6f Here we need to
5b70: 20 63 68 65 63 6b 20 74 68 61 74 20 61 6c 6c 20 check that all
5b80: 74 68 65 20 74 65 73 74 73 20 72 65 6d 61 69 6e the tests remain
5b90: 69 6e 67 20 74 6f 20 62 65 20 72 75 6e 20 61 72 ing to be run ar
5ba0: 65 20 65 6c 69 67 69 62 6c 65 20 74 6f 20 72 75 e eligible to ru
5bb0: 6e 0a 09 20 20 20 20 20 20 3b 3b 20 61 6e 64 20 n.. ;; and
5bc0: 61 72 65 20 6e 6f 74 20 62 6c 6f 63 6b 65 64 20 are not blocked
5bd0: 62 79 20 66 61 69 6c 65 64 0a 09 20 20 20 20 20 by failed..
5be0: 20 28 6c 65 74 20 28 28 6e 65 77 6c 73 74 20 28 (let ((newlst (
5bf0: 6f 70 65 6e 2d 72 75 6e 2d 63 6c 6f 73 65 20 74 open-run-close t
5c00: 65 73 74 73 3a 66 69 6c 74 65 72 2d 6e 6f 6e 2d ests:filter-non-
5c10: 72 75 6e 6e 61 62 6c 65 20 23 66 20 72 75 6e 2d runnable #f run-
5c20: 69 64 20 74 61 6c 20 74 65 73 74 2d 72 65 63 6f id tal test-reco
5c30: 72 64 73 29 29 29 20 3b 3b 20 69 2e 65 2e 20 6e rds))) ;; i.e. n
5c40: 6f 74 20 46 41 49 4c 2c 20 57 41 49 56 45 44 2c ot FAIL, WAIVED,
5c50: 20 49 4e 43 4f 4d 50 4c 45 54 45 2c 20 50 41 53 INCOMPLETE, PAS
5c60: 53 2c 20 4b 49 4c 4c 45 44 2c 0a 09 09 28 74 68 S, KILLED,...(th
5c70: 72 65 61 64 2d 73 6c 65 65 70 21 20 2a 67 6c 6f read-sleep! *glo
5c80: 62 61 6c 2d 64 65 6c 74 61 2a 29 0a 09 09 28 69 bal-delta*)...(i
5c90: 66 20 28 6e 6f 74 20 28 6e 75 6c 6c 3f 20 6e 65 f (not (null? ne
5ca0: 77 6c 73 74 29 29 0a 09 09 20 20 20 20 28 6c 6f wlst))... (lo
5cb0: 6f 70 20 28 63 61 72 20 6e 65 77 6c 73 74 29 28 op (car newlst)(
5cc0: 63 64 72 20 6e 65 77 6c 73 74 29 29 29 29 29 29 cdr newlst))))))
5cd0: 29 29 29 0a 0a 3b 3b 20 70 61 72 65 6e 74 2d 74 )))..;; parent-t
5ce0: 65 73 74 20 69 73 20 74 68 65 72 65 20 61 73 20 est is there as
5cf0: 61 20 70 6c 61 63 65 68 6f 6c 64 65 72 20 66 6f a placeholder fo
5d00: 72 20 77 68 65 6e 20 70 61 72 65 6e 74 2d 74 65 r when parent-te
5d10: 73 74 73 20 63 61 6e 20 62 65 20 72 75 6e 20 61 sts can be run a
5d20: 73 20 61 20 73 65 74 75 70 20 73 74 65 70 0a 28 s a setup step.(
5d30: 64 65 66 69 6e 65 20 28 72 75 6e 3a 74 65 73 74 define (run:test
5d40: 20 72 75 6e 2d 69 64 20 72 75 6e 6e 61 6d 65 20 run-id runname
5d50: 6b 65 79 76 61 6c 6c 73 74 20 74 65 73 74 2d 72 keyvallst test-r
5d60: 65 63 6f 72 64 20 66 6c 61 67 73 20 70 61 72 65 ecord flags pare
5d70: 6e 74 2d 74 65 73 74 29 0a 20 20 3b 3b 20 41 6c nt-test). ;; Al
5d80: 6c 20 74 68 65 73 65 20 76 61 72 73 20 6d 69 67 l these vars mig
5d90: 68 74 20 62 65 20 72 65 66 65 72 65 6e 63 65 64 ht be referenced
5da0: 20 62 79 20 74 68 65 20 74 65 73 74 63 6f 6e 66 by the testconf
5db0: 69 67 20 66 69 6c 65 20 72 65 61 64 65 72 0a 20 ig file reader.
5dc0: 20 28 6c 65 74 2a 20 28 28 74 65 73 74 2d 6e 61 (let* ((test-na
5dd0: 6d 65 20 20 20 20 28 74 65 73 74 73 3a 74 65 73 me (tests:tes
5de0: 74 71 75 65 75 65 2d 67 65 74 2d 74 65 73 74 6e tqueue-get-testn
5df0: 61 6d 65 20 20 20 74 65 73 74 2d 72 65 63 6f 72 ame test-recor
5e00: 64 29 29 0a 09 20 28 74 65 73 74 2d 77 61 69 74 d)).. (test-wait
5e10: 6f 6e 73 20 28 74 65 73 74 73 3a 74 65 73 74 71 ons (tests:testq
5e20: 75 65 75 65 2d 67 65 74 2d 77 61 69 74 6f 6e 73 ueue-get-waitons
5e30: 20 20 20 20 74 65 73 74 2d 72 65 63 6f 72 64 29 test-record)
5e40: 29 0a 09 20 28 74 65 73 74 2d 63 6f 6e 66 20 20 ).. (test-conf
5e50: 20 20 28 74 65 73 74 73 3a 74 65 73 74 71 75 65 (tests:testque
5e60: 75 65 2d 67 65 74 2d 74 65 73 74 63 6f 6e 66 69 ue-get-testconfi
5e70: 67 20 74 65 73 74 2d 72 65 63 6f 72 64 29 29 0a g test-record)).
5e80: 09 20 28 69 74 65 6d 64 61 74 20 20 20 20 20 20 . (itemdat
5e90: 28 74 65 73 74 73 3a 74 65 73 74 71 75 65 75 65 (tests:testqueue
5ea0: 2d 67 65 74 2d 69 74 65 6d 64 61 74 20 20 20 20 -get-itemdat
5eb0: 74 65 73 74 2d 72 65 63 6f 72 64 29 29 0a 09 20 test-record))..
5ec0: 28 74 65 73 74 2d 70 61 74 68 20 20 20 20 28 63 (test-path (c
5ed0: 6f 6e 63 20 2a 74 6f 70 70 61 74 68 2a 20 22 2f onc *toppath* "/
5ee0: 74 65 73 74 73 2f 22 20 74 65 73 74 2d 6e 61 6d tests/" test-nam
5ef0: 65 29 29 20 3b 3b 20 63 6f 75 6c 64 20 75 73 65 e)) ;; could use
5f00: 20 74 65 73 74 73 3a 67 65 74 2d 74 65 73 74 63 tests:get-testc
5f10: 6f 6e 66 69 67 20 68 65 72 65 20 2e 2e 2e 0a 09 onfig here .....
5f20: 20 28 66 6f 72 63 65 20 20 20 20 20 20 20 20 28 (force (
5f30: 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 hash-table-ref/d
5f40: 65 66 61 75 6c 74 20 66 6c 61 67 73 20 22 2d 66 efault flags "-f
5f50: 6f 72 63 65 22 20 23 66 29 29 0a 09 20 28 72 65 orce" #f)).. (re
5f60: 72 75 6e 20 20 20 20 20 20 20 20 28 68 61 73 68 run (hash
5f70: 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 -table-ref/defau
5f80: 6c 74 20 66 6c 61 67 73 20 22 2d 72 65 72 75 6e lt flags "-rerun
5f90: 22 20 23 66 29 29 0a 09 20 28 6b 65 65 70 67 6f " #f)).. (keepgo
5fa0: 69 6e 67 20 20 20 20 28 68 61 73 68 2d 74 61 62 ing (hash-tab
5fb0: 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 66 le-ref/default f
5fc0: 6c 61 67 73 20 22 2d 6b 65 65 70 67 6f 69 6e 67 lags "-keepgoing
5fd0: 22 20 23 66 29 29 0a 09 20 28 69 74 65 6d 2d 70 " #f)).. (item-p
5fe0: 61 74 68 20 20 20 20 20 22 22 29 0a 09 20 28 64 ath "").. (d
5ff0: 62 20 20 20 20 20 20 20 20 20 20 20 23 66 29 29 b #f))
6000: 0a 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e . (debug:prin
6010: 74 20 34 0a 09 09 20 22 74 65 73 74 2d 63 6f 6e t 4... "test-con
6020: 66 69 67 3a 20 22 20 28 68 61 73 68 2d 74 61 62 fig: " (hash-tab
6030: 6c 65 2d 3e 61 6c 69 73 74 20 74 65 73 74 2d 63 le->alist test-c
6040: 6f 6e 66 29 0a 09 09 20 22 5c 6e 20 20 20 69 74 onf)... "\n it
6050: 65 6d 64 61 74 3a 20 22 20 69 74 65 6d 64 61 74 emdat: " itemdat
6060: 0a 09 09 20 29 0a 20 20 20 20 3b 3b 20 73 65 74 ... ). ;; set
6070: 74 69 6e 67 20 69 74 65 6d 64 61 74 20 74 6f 20 ting itemdat to
6080: 61 20 6c 69 73 74 20 69 66 20 69 74 20 69 73 20 a list if it is
6090: 23 66 0a 20 20 20 20 28 69 66 20 28 6e 6f 74 20 #f. (if (not
60a0: 69 74 65 6d 64 61 74 29 28 73 65 74 21 20 69 74 itemdat)(set! it
60b0: 65 6d 64 61 74 20 27 28 29 29 29 0a 20 20 20 20 emdat '())).
60c0: 28 73 65 74 21 20 69 74 65 6d 2d 70 61 74 68 20 (set! item-path
60d0: 28 69 74 65 6d 2d 6c 69 73 74 2d 3e 70 61 74 68 (item-list->path
60e0: 20 69 74 65 6d 64 61 74 29 29 0a 20 20 20 20 28 itemdat)). (
60f0: 64 65 62 75 67 3a 70 72 69 6e 74 20 32 20 22 41 debug:print 2 "A
6100: 74 74 65 6d 70 74 69 6e 67 20 74 6f 20 6c 61 75 ttempting to lau
6110: 6e 63 68 20 74 65 73 74 20 22 20 74 65 73 74 2d nch test " test-
6120: 6e 61 6d 65 20 28 69 66 20 28 65 71 75 61 6c 3f name (if (equal?
6130: 20 69 74 65 6d 2d 70 61 74 68 20 22 2f 22 29 20 item-path "/")
6140: 22 2f 22 20 69 74 65 6d 2d 70 61 74 68 29 29 0a "/" item-path)).
6150: 20 20 20 20 28 73 65 74 65 6e 76 20 22 4d 54 5f (setenv "MT_
6160: 54 45 53 54 5f 4e 41 4d 45 22 20 74 65 73 74 2d TEST_NAME" test-
6170: 6e 61 6d 65 29 20 3b 3b 20 0a 20 20 20 20 28 73 name) ;; . (s
6180: 65 74 65 6e 76 20 22 4d 54 5f 52 55 4e 4e 41 4d etenv "MT_RUNNAM
6190: 45 22 20 20 20 72 75 6e 6e 61 6d 65 29 0a 20 20 E" runname).
61a0: 20 20 28 6f 70 65 6e 2d 72 75 6e 2d 63 6c 6f 73 (open-run-clos
61b0: 65 2d 6d 65 61 73 75 72 65 20 73 65 74 2d 6d 65 e-measure set-me
61c0: 67 61 74 65 73 74 2d 65 6e 76 2d 76 61 72 73 20 gatest-env-vars
61d0: 64 62 20 72 75 6e 2d 69 64 29 20 3b 3b 20 74 68 db run-id) ;; th
61e0: 65 73 65 20 6d 61 79 20 62 65 20 6e 65 65 64 65 ese may be neede
61f0: 64 20 62 79 20 74 68 65 20 6c 61 75 6e 63 68 69 d by the launchi
6200: 6e 67 20 70 72 6f 63 65 73 73 0a 20 20 20 20 28 ng process. (
6210: 63 68 61 6e 67 65 2d 64 69 72 65 63 74 6f 72 79 change-directory
6220: 20 2a 74 6f 70 70 61 74 68 2a 29 0a 0a 20 20 20 *toppath*)..
6230: 20 3b 3b 20 48 65 72 65 20 69 73 20 77 68 65 72 ;; Here is wher
6240: 65 20 74 68 65 20 74 65 73 74 5f 6d 65 74 61 20 e the test_meta
6250: 74 61 62 6c 65 20 69 73 20 62 65 73 74 20 75 70 table is best up
6260: 64 61 74 65 64 0a 20 20 20 20 3b 3b 20 59 65 73 dated. ;; Yes
6270: 2c 20 61 6e 6f 74 68 65 72 20 75 73 65 20 6f 66 , another use of
6280: 20 61 20 67 6c 6f 62 61 6c 20 66 6f 72 20 63 61 a global for ca
6290: 63 68 69 6e 67 2e 20 4e 65 65 64 20 61 20 62 65 ching. Need a be
62a0: 74 74 65 72 20 77 61 79 3f 0a 20 20 20 20 28 69 tter way?. (i
62b0: 66 20 28 6e 6f 74 20 28 68 61 73 68 2d 74 61 62 f (not (hash-tab
62c0: 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 2a le-ref/default *
62d0: 74 65 73 74 2d 6d 65 74 61 2d 75 70 64 61 74 65 test-meta-update
62e0: 64 2a 20 74 65 73 74 2d 6e 61 6d 65 20 23 66 29 d* test-name #f)
62f0: 29 0a 20 20 20 20 20 20 20 20 28 62 65 67 69 6e ). (begin
6300: 0a 09 20 20 20 28 68 61 73 68 2d 74 61 62 6c 65 .. (hash-table
6310: 2d 73 65 74 21 20 2a 74 65 73 74 2d 6d 65 74 61 -set! *test-meta
6320: 2d 75 70 64 61 74 65 64 2a 20 74 65 73 74 2d 6e -updated* test-n
6330: 61 6d 65 20 23 74 29 0a 20 20 20 20 20 20 20 20 ame #t).
6340: 20 20 20 28 6f 70 65 6e 2d 72 75 6e 2d 63 6c 6f (open-run-clo
6350: 73 65 20 72 75 6e 73 3a 75 70 64 61 74 65 2d 74 se runs:update-t
6360: 65 73 74 5f 6d 65 74 61 20 64 62 20 74 65 73 74 est_meta db test
6370: 2d 6e 61 6d 65 20 74 65 73 74 2d 63 6f 6e 66 29 -name test-conf)
6380: 29 29 0a 20 20 20 20 0a 20 20 20 20 3b 3b 20 28 )). . ;; (
6390: 6c 61 6d 62 64 61 20 28 69 74 65 6d 64 61 74 29 lambda (itemdat)
63a0: 20 3b 3b 3b 20 28 28 72 69 70 65 6e 65 73 73 20 ;;; ((ripeness
63b0: 22 6f 76 65 72 72 69 70 65 22 29 20 28 74 65 6d "overripe") (tem
63c0: 70 65 72 61 74 75 72 65 20 22 63 6f 6f 6c 22 29 perature "cool")
63d0: 20 28 73 65 61 73 6f 6e 20 22 73 75 6d 6d 65 72 (season "summer
63e0: 22 29 29 0a 20 20 20 20 28 6c 65 74 2a 20 28 28 ")). (let* ((
63f0: 6e 65 77 2d 74 65 73 74 2d 70 61 74 68 20 28 73 new-test-path (s
6400: 74 72 69 6e 67 2d 69 6e 74 65 72 73 70 65 72 73 tring-interspers
6410: 65 20 28 63 6f 6e 73 20 74 65 73 74 2d 70 61 74 e (cons test-pat
6420: 68 20 28 6d 61 70 20 63 61 64 72 20 69 74 65 6d h (map cadr item
6430: 64 61 74 29 29 20 22 2f 22 29 29 0a 09 20 20 20 dat)) "/"))..
6440: 28 6e 65 77 2d 74 65 73 74 2d 6e 61 6d 65 20 28 (new-test-name (
6450: 69 66 20 28 65 71 75 61 6c 3f 20 69 74 65 6d 2d if (equal? item-
6460: 70 61 74 68 20 22 22 29 20 74 65 73 74 2d 6e 61 path "") test-na
6470: 6d 65 20 28 63 6f 6e 63 20 74 65 73 74 2d 6e 61 me (conc test-na
6480: 6d 65 20 22 2f 22 20 69 74 65 6d 2d 70 61 74 68 me "/" item-path
6490: 29 29 29 20 3b 3b 20 6a 75 73 74 20 6e 65 65 64 ))) ;; just need
64a0: 20 69 74 20 74 6f 20 62 65 20 75 6e 69 71 75 65 it to be unique
64b0: 0a 09 20 20 20 28 74 65 73 74 2d 69 64 20 20 20 .. (test-id
64c0: 20 20 20 20 28 6f 70 65 6e 2d 72 75 6e 2d 63 6c (open-run-cl
64d0: 6f 73 65 20 64 62 3a 67 65 74 2d 74 65 73 74 2d ose db:get-test-
64e0: 69 64 20 64 62 20 20 72 75 6e 2d 69 64 20 74 65 id db run-id te
64f0: 73 74 2d 6e 61 6d 65 20 69 74 65 6d 2d 70 61 74 st-name item-pat
6500: 68 29 29 0a 09 20 20 20 28 74 65 73 74 64 61 74 h)).. (testdat
6510: 20 20 20 20 20 20 20 28 6f 70 65 6e 2d 72 75 6e (open-run
6520: 2d 63 6c 6f 73 65 20 64 62 3a 67 65 74 2d 74 65 -close db:get-te
6530: 73 74 2d 69 6e 66 6f 2d 62 79 2d 69 64 20 64 62 st-info-by-id db
6540: 20 74 65 73 74 2d 69 64 29 29 29 0a 20 20 20 20 test-id))).
6550: 20 20 28 69 66 20 28 6e 6f 74 20 74 65 73 74 64 (if (not testd
6560: 61 74 29 0a 09 20 20 28 62 65 67 69 6e 0a 09 20 at).. (begin..
6570: 20 20 20 3b 3b 20 65 6e 73 75 72 65 20 74 68 61 ;; ensure tha
6580: 74 20 74 68 65 20 70 61 74 68 20 65 78 69 73 74 t the path exist
6590: 73 20 62 65 66 6f 72 65 20 72 65 67 69 73 74 65 s before registe
65a0: 72 69 6e 67 20 74 68 65 20 74 65 73 74 0a 09 20 ring the test..
65b0: 20 20 20 3b 3b 20 4e 4f 50 45 3a 20 43 61 6e 6e ;; NOPE: Cann
65c0: 6f 74 21 20 44 6f 6e 27 74 20 6b 6e 6f 77 20 79 ot! Don't know y
65d0: 65 74 20 77 68 69 63 68 20 64 69 73 6b 20 61 72 et which disk ar
65e0: 65 61 20 77 69 6c 6c 20 62 65 20 61 73 73 69 67 ea will be assig
65f0: 6e 65 64 2e 2e 2e 2e 0a 09 20 20 20 20 3b 3b 20 ned...... ;;
6600: 28 73 79 73 74 65 6d 20 28 63 6f 6e 63 20 22 6d (system (conc "m
6610: 6b 64 69 72 20 2d 70 20 22 20 6e 65 77 2d 74 65 kdir -p " new-te
6620: 73 74 2d 70 61 74 68 29 29 0a 09 20 20 20 20 3b st-path)).. ;
6630: 3b 0a 09 20 20 20 20 3b 3b 20 28 6f 70 65 6e 2d ;.. ;; (open-
6640: 72 75 6e 2d 63 6c 6f 73 65 20 74 65 73 74 73 3a run-close tests:
6650: 72 65 67 69 73 74 65 72 2d 74 65 73 74 20 64 62 register-test db
6660: 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 6e 61 6d run-id test-nam
6670: 65 20 69 74 65 6d 2d 70 61 74 68 29 0a 09 20 20 e item-path)..
6680: 20 20 3b 3b 0a 09 20 20 20 20 3b 3b 20 4e 42 2f ;;.. ;; NB/
6690: 2f 20 66 6f 72 20 74 68 65 20 61 62 6f 76 65 20 / for the above
66a0: 6c 69 6e 65 2e 20 49 20 77 61 6e 74 20 74 68 65 line. I want the
66b0: 20 74 65 73 74 20 74 6f 20 62 65 20 72 65 67 69 test to be regi
66c0: 73 74 65 72 65 64 20 6c 6f 6e 67 20 62 65 66 6f stered long befo
66d0: 72 65 20 74 68 69 73 20 72 6f 75 74 69 6e 65 20 re this routine
66e0: 67 65 74 73 20 63 61 6c 6c 65 64 21 0a 09 20 20 gets called!..
66f0: 20 20 3b 3b 0a 09 20 20 20 20 28 73 65 74 21 20 ;;.. (set!
6700: 74 65 73 74 2d 69 64 20 28 6f 70 65 6e 2d 72 75 test-id (open-ru
6710: 6e 2d 63 6c 6f 73 65 20 64 62 3a 67 65 74 2d 74 n-close db:get-t
6720: 65 73 74 2d 69 64 20 64 62 20 72 75 6e 2d 69 64 est-id db run-id
6730: 20 74 65 73 74 2d 6e 61 6d 65 20 69 74 65 6d 2d test-name item-
6740: 70 61 74 68 29 29 0a 09 20 20 20 20 28 69 66 20 path)).. (if
6750: 28 6e 6f 74 20 74 65 73 74 2d 69 64 29 0a 09 09 (not test-id)...
6760: 28 62 65 67 69 6e 0a 09 09 20 20 28 64 65 62 75 (begin... (debu
6770: 67 3a 70 72 69 6e 74 20 32 20 22 57 41 52 4e 3a g:print 2 "WARN:
6780: 20 54 65 73 74 20 6e 6f 74 20 70 72 65 2d 63 72 Test not pre-cr
6790: 65 61 74 65 64 3f 20 74 65 73 74 2d 6e 61 6d 65 eated? test-name
67a0: 3d 22 20 74 65 73 74 2d 6e 61 6d 65 20 22 2c 20 =" test-name ",
67b0: 69 74 65 6d 2d 70 61 74 68 3d 22 20 69 74 65 6d item-path=" item
67c0: 2d 70 61 74 68 20 22 2c 20 72 75 6e 2d 69 64 3d -path ", run-id=
67d0: 22 20 72 75 6e 2d 69 64 29 0a 09 09 20 20 28 6f " run-id)... (o
67e0: 70 65 6e 2d 72 75 6e 2d 63 6c 6f 73 65 20 64 62 pen-run-close db
67f0: 3a 74 65 73 74 73 2d 72 65 67 69 73 74 65 72 2d :tests-register-
6800: 74 65 73 74 20 64 62 20 72 75 6e 2d 69 64 20 74 test db run-id t
6810: 65 73 74 2d 6e 61 6d 65 20 69 74 65 6d 2d 70 61 est-name item-pa
6820: 74 68 29 0a 09 09 20 20 28 73 65 74 21 20 74 65 th)... (set! te
6830: 73 74 2d 69 64 20 28 6f 70 65 6e 2d 72 75 6e 2d st-id (open-run-
6840: 63 6c 6f 73 65 20 64 62 3a 67 65 74 2d 74 65 73 close db:get-tes
6850: 74 2d 69 64 20 64 62 20 72 75 6e 2d 69 64 20 74 t-id db run-id t
6860: 65 73 74 2d 6e 61 6d 65 20 69 74 65 6d 2d 70 61 est-name item-pa
6870: 74 68 29 29 29 29 0a 09 20 20 20 20 28 64 65 62 th)))).. (deb
6880: 75 67 3a 70 72 69 6e 74 20 34 20 22 49 4e 46 4f ug:print 4 "INFO
6890: 3a 20 74 65 73 74 2d 69 64 3d 22 20 74 65 73 74 : test-id=" test
68a0: 2d 69 64 20 22 2c 20 72 75 6e 2d 69 64 3d 22 20 -id ", run-id="
68b0: 72 75 6e 2d 69 64 20 22 2c 20 74 65 73 74 2d 6e run-id ", test-n
68c0: 61 6d 65 3d 22 20 74 65 73 74 2d 6e 61 6d 65 20 ame=" test-name
68d0: 22 2c 20 69 74 65 6d 2d 70 61 74 68 3d 5c 22 22 ", item-path=\""
68e0: 20 69 74 65 6d 2d 70 61 74 68 20 22 5c 22 22 29 item-path "\"")
68f0: 0a 09 20 20 20 20 28 73 65 74 21 20 74 65 73 74 .. (set! test
6900: 64 61 74 20 28 6f 70 65 6e 2d 72 75 6e 2d 63 6c dat (open-run-cl
6910: 6f 73 65 20 64 62 3a 67 65 74 2d 74 65 73 74 2d ose db:get-test-
6920: 69 6e 66 6f 2d 62 79 2d 69 64 20 64 62 20 74 65 info-by-id db te
6930: 73 74 2d 69 64 29 29 29 29 0a 20 20 20 20 20 20 st-id)))).
6940: 28 73 65 74 21 20 74 65 73 74 2d 69 64 20 28 64 (set! test-id (d
6950: 62 3a 74 65 73 74 2d 67 65 74 2d 69 64 20 74 65 b:test-get-id te
6960: 73 74 64 61 74 29 29 0a 20 20 20 20 20 20 28 63 stdat)). (c
6970: 68 61 6e 67 65 2d 64 69 72 65 63 74 6f 72 79 20 hange-directory
6980: 74 65 73 74 2d 70 61 74 68 29 0a 20 20 20 20 20 test-path).
6990: 20 28 63 61 73 65 20 28 69 66 20 66 6f 72 63 65 (case (if force
69a0: 20 3b 3b 20 28 61 72 67 73 3a 67 65 74 2d 61 72 ;; (args:get-ar
69b0: 67 20 22 2d 66 6f 72 63 65 22 29 0a 09 09 27 4e g "-force")...'N
69c0: 4f 54 5f 53 54 41 52 54 45 44 0a 09 09 28 69 66 OT_STARTED...(if
69d0: 20 74 65 73 74 64 61 74 0a 09 09 20 20 20 20 28 testdat... (
69e0: 73 74 72 69 6e 67 2d 3e 73 79 6d 62 6f 6c 20 28 string->symbol (
69f0: 74 65 73 74 3a 67 65 74 2d 73 74 61 74 65 20 74 test:get-state t
6a00: 65 73 74 64 61 74 29 29 0a 09 09 20 20 20 20 27 estdat))... '
6a10: 66 61 69 6c 65 64 2d 74 6f 2d 69 6e 73 65 72 74 failed-to-insert
6a20: 29 29 0a 09 28 28 66 61 69 6c 65 64 2d 74 6f 2d ))..((failed-to-
6a30: 69 6e 73 65 72 74 29 0a 09 20 28 64 65 62 75 67 insert).. (debug
6a40: 3a 70 72 69 6e 74 20 30 20 22 45 52 52 4f 52 3a :print 0 "ERROR:
6a50: 20 46 61 69 6c 65 64 20 74 6f 20 69 6e 73 65 72 Failed to inser
6a60: 74 20 74 68 65 20 72 65 63 6f 72 64 20 69 6e 74 t the record int
6a70: 6f 20 74 68 65 20 64 62 22 29 29 0a 09 28 28 4e o the db"))..((N
6a80: 4f 54 5f 53 54 41 52 54 45 44 20 43 4f 4d 50 4c OT_STARTED COMPL
6a90: 45 54 45 44 29 0a 09 20 28 6c 65 74 20 28 28 72 ETED).. (let ((r
6aa0: 75 6e 66 6c 61 67 20 23 66 29 29 0a 09 20 20 20 unflag #f))..
6ab0: 28 63 6f 6e 64 0a 09 20 20 20 20 3b 3b 20 2d 66 (cond.. ;; -f
6ac0: 6f 72 63 65 2c 20 72 75 6e 20 6e 6f 20 6d 61 74 orce, run no mat
6ad0: 74 65 72 20 77 68 61 74 0a 09 20 20 20 20 28 66 ter what.. (f
6ae0: 6f 72 63 65 20 28 73 65 74 21 20 72 75 6e 66 6c orce (set! runfl
6af0: 61 67 20 23 74 29 29 0a 09 20 20 20 20 3b 3b 20 ag #t)).. ;;
6b00: 4e 4f 54 5f 53 54 41 52 54 45 44 2c 20 72 75 6e NOT_STARTED, run
6b10: 20 6e 6f 20 6d 61 74 74 65 72 20 77 68 61 74 0a no matter what.
6b20: 09 20 20 20 20 28 28 65 71 75 61 6c 3f 20 28 74 . ((equal? (t
6b30: 65 73 74 3a 67 65 74 2d 73 74 61 74 65 20 74 65 est:get-state te
6b40: 73 74 64 61 74 29 20 22 4e 4f 54 5f 53 54 41 52 stdat) "NOT_STAR
6b50: 54 45 44 22 29 28 73 65 74 21 20 72 75 6e 66 6c TED")(set! runfl
6b60: 61 67 20 23 74 29 29 0a 09 20 20 20 20 3b 3b 20 ag #t)).. ;;
6b70: 6e 6f 74 20 2d 72 65 72 75 6e 20 61 6e 64 20 50 not -rerun and P
6b80: 41 53 53 2c 20 57 41 52 4e 20 6f 72 20 43 48 45 ASS, WARN or CHE
6b90: 43 4b 2c 20 64 6f 20 6e 6f 20 72 75 6e 0a 09 20 CK, do no run..
6ba0: 20 20 20 28 28 61 6e 64 20 28 6f 72 20 28 6e 6f ((and (or (no
6bb0: 74 20 72 65 72 75 6e 29 0a 09 09 20 20 20 20 20 t rerun)...
6bc0: 20 6b 65 65 70 67 6f 69 6e 67 29 0a 09 09 20 20 keepgoing)...
6bd0: 3b 3b 20 52 65 71 75 69 72 65 20 74 6f 20 66 6f ;; Require to fo
6be0: 72 63 65 20 72 65 2d 72 75 6e 20 66 6f 72 20 43 rce re-run for C
6bf0: 4f 4d 50 4c 45 54 45 44 20 6f 72 20 2a 61 6e 79 OMPLETED or *any
6c00: 74 68 69 6e 67 2a 20 2b 20 50 41 53 53 2c 57 41 thing* + PASS,WA
6c10: 52 4e 20 6f 72 20 43 48 45 43 4b 0a 09 09 20 20 RN or CHECK...
6c20: 28 6f 72 20 28 6d 65 6d 62 65 72 20 28 74 65 73 (or (member (tes
6c30: 74 3a 67 65 74 2d 73 74 61 74 75 73 20 74 65 73 t:get-status tes
6c40: 74 64 61 74 29 20 27 28 22 50 41 53 53 22 20 22 tdat) '("PASS" "
6c50: 57 41 52 4e 22 20 22 43 48 45 43 4b 22 29 29 0a WARN" "CHECK")).
6c60: 09 09 20 20 20 20 20 20 28 6d 65 6d 62 65 72 20 .. (member
6c70: 28 74 65 73 74 3a 67 65 74 2d 73 74 61 74 65 20 (test:get-state
6c80: 20 74 65 73 74 64 61 74 29 20 27 28 22 43 4f 4d testdat) '("COM
6c90: 50 4c 45 54 45 44 22 29 29 29 29 20 0a 09 20 20 PLETED")))) ..
6ca0: 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 (debug:print
6cb0: 32 20 22 49 4e 46 4f 3a 20 72 75 6e 6e 69 6e 67 2 "INFO: running
6cc0: 20 74 65 73 74 20 22 20 74 65 73 74 2d 6e 61 6d test " test-nam
6cd0: 65 20 22 2f 22 20 69 74 65 6d 2d 70 61 74 68 20 e "/" item-path
6ce0: 22 20 73 75 70 70 72 65 73 73 65 64 20 61 73 20 " suppressed as
6cf0: 69 74 20 69 73 20 22 20 28 74 65 73 74 3a 67 65 it is " (test:ge
6d00: 74 2d 73 74 61 74 65 20 74 65 73 74 64 61 74 29 t-state testdat)
6d10: 20 22 20 61 6e 64 20 22 20 28 74 65 73 74 3a 67 " and " (test:g
6d20: 65 74 2d 73 74 61 74 75 73 20 74 65 73 74 64 61 et-status testda
6d30: 74 29 29 0a 09 20 20 20 20 20 28 73 65 74 21 20 t)).. (set!
6d40: 72 75 6e 66 6c 61 67 20 23 66 29 29 0a 09 20 20 runflag #f))..
6d50: 20 20 3b 3b 20 2d 72 65 72 75 6e 20 61 6e 64 20 ;; -rerun and
6d60: 73 74 61 74 75 73 20 69 73 20 6f 6e 65 20 6f 66 status is one of
6d70: 20 74 68 65 20 73 70 65 63 69 66 65 64 2c 20 72 the specifed, r
6d80: 75 6e 20 69 74 0a 09 20 20 20 20 28 28 61 6e 64 un it.. ((and
6d90: 20 72 65 72 75 6e 0a 09 09 20 20 28 6c 65 74 2a rerun... (let*
6da0: 20 28 28 72 65 72 75 6e 6c 73 74 20 20 20 28 73 ((rerunlst (s
6db0: 74 72 69 6e 67 2d 73 70 6c 69 74 20 72 65 72 75 tring-split reru
6dc0: 6e 20 22 2c 22 29 29 0a 09 09 09 20 28 6d 75 73 n ",")).... (mus
6dd0: 74 2d 72 65 72 75 6e 20 28 6d 65 6d 62 65 72 20 t-rerun (member
6de0: 28 74 65 73 74 3a 67 65 74 2d 73 74 61 74 75 73 (test:get-status
6df0: 20 74 65 73 74 64 61 74 29 20 72 65 72 75 6e 6c testdat) rerunl
6e00: 73 74 29 29 29 0a 09 09 20 20 20 20 28 64 65 62 st)))... (deb
6e10: 75 67 3a 70 72 69 6e 74 20 33 20 22 49 4e 46 4f ug:print 3 "INFO
6e20: 3a 20 2d 72 65 72 75 6e 20 6c 69 73 74 3a 20 22 : -rerun list: "
6e30: 20 72 65 72 75 6e 20 22 2c 20 74 65 73 74 2d 73 rerun ", test-s
6e40: 74 61 74 75 73 3a 20 22 20 28 74 65 73 74 3a 67 tatus: " (test:g
6e50: 65 74 2d 73 74 61 74 75 73 20 74 65 73 74 64 61 et-status testda
6e60: 74 29 22 2c 20 6d 75 73 74 2d 72 65 72 75 6e 3a t)", must-rerun:
6e70: 20 22 20 6d 75 73 74 2d 72 65 72 75 6e 29 0a 09 " must-rerun)..
6e80: 09 20 20 20 20 6d 75 73 74 2d 72 65 72 75 6e 29 . must-rerun)
6e90: 29 0a 09 20 20 20 20 20 28 64 65 62 75 67 3a 70 ).. (debug:p
6ea0: 72 69 6e 74 20 32 20 22 49 4e 46 4f 3a 20 52 65 rint 2 "INFO: Re
6eb0: 72 75 6e 20 66 6f 72 63 65 64 20 66 6f 72 20 74 run forced for t
6ec0: 65 73 74 20 22 20 74 65 73 74 2d 6e 61 6d 65 20 est " test-name
6ed0: 22 2f 22 20 69 74 65 6d 2d 70 61 74 68 29 0a 09 "/" item-path)..
6ee0: 20 20 20 20 20 28 73 65 74 21 20 72 75 6e 66 6c (set! runfl
6ef0: 61 67 20 23 74 29 29 0a 09 20 20 20 20 3b 3b 20 ag #t)).. ;;
6f00: 2d 6b 65 65 70 67 6f 69 6e 67 2c 20 64 6f 20 6e -keepgoing, do n
6f10: 6f 74 20 72 65 72 75 6e 20 46 41 49 4c 0a 09 20 ot rerun FAIL..
6f20: 20 20 20 28 28 61 6e 64 20 6b 65 65 70 67 6f 69 ((and keepgoi
6f30: 6e 67 0a 09 09 20 20 28 6d 65 6d 62 65 72 20 28 ng... (member (
6f40: 74 65 73 74 3a 67 65 74 2d 73 74 61 74 75 73 20 test:get-status
6f50: 74 65 73 74 64 61 74 29 20 27 28 22 46 41 49 4c testdat) '("FAIL
6f60: 22 29 29 29 0a 09 20 20 20 20 20 28 73 65 74 21 "))).. (set!
6f70: 20 72 75 6e 66 6c 61 67 20 23 66 29 29 0a 09 20 runflag #f))..
6f80: 20 20 20 28 28 61 6e 64 20 28 6e 6f 74 20 72 65 ((and (not re
6f90: 72 75 6e 29 0a 09 09 20 20 28 6d 65 6d 62 65 72 run)... (member
6fa0: 20 28 74 65 73 74 3a 67 65 74 2d 73 74 61 74 75 (test:get-statu
6fb0: 73 20 74 65 73 74 64 61 74 29 20 27 28 22 46 41 s testdat) '("FA
6fc0: 49 4c 22 20 22 6e 2f 61 22 29 29 29 0a 09 20 20 IL" "n/a")))..
6fd0: 20 20 20 28 73 65 74 21 20 72 75 6e 66 6c 61 67 (set! runflag
6fe0: 20 23 74 29 29 0a 09 20 20 20 20 28 65 6c 73 65 #t)).. (else
6ff0: 20 28 73 65 74 21 20 72 75 6e 66 6c 61 67 20 23 (set! runflag #
7000: 66 29 29 29 0a 09 20 20 20 28 64 65 62 75 67 3a f))).. (debug:
7010: 70 72 69 6e 74 20 36 20 22 52 55 4e 4e 49 4e 47 print 6 "RUNNING
7020: 20 3d 3e 20 72 75 6e 66 6c 61 67 3a 20 22 20 72 => runflag: " r
7030: 75 6e 66 6c 61 67 20 22 20 53 54 41 54 45 3a 20 unflag " STATE:
7040: 22 20 28 74 65 73 74 3a 67 65 74 2d 73 74 61 74 " (test:get-stat
7050: 65 20 74 65 73 74 64 61 74 29 20 22 20 53 54 41 e testdat) " STA
7060: 54 55 53 3a 20 22 20 28 74 65 73 74 3a 67 65 74 TUS: " (test:get
7070: 2d 73 74 61 74 75 73 20 74 65 73 74 64 61 74 29 -status testdat)
7080: 29 0a 09 20 20 20 28 69 66 20 28 6e 6f 74 20 72 ).. (if (not r
7090: 75 6e 66 6c 61 67 29 0a 09 20 20 20 20 20 20 20 unflag)..
70a0: 28 69 66 20 28 6e 6f 74 20 70 61 72 65 6e 74 2d (if (not parent-
70b0: 74 65 73 74 29 0a 09 09 20 20 20 28 64 65 62 75 test)... (debu
70c0: 67 3a 70 72 69 6e 74 20 31 20 22 4e 4f 54 45 3a g:print 1 "NOTE:
70d0: 20 4e 6f 74 20 73 74 61 72 74 69 6e 67 20 74 65 Not starting te
70e0: 73 74 20 22 20 6e 65 77 2d 74 65 73 74 2d 6e 61 st " new-test-na
70f0: 6d 65 20 22 20 61 73 20 69 74 20 69 73 20 73 74 me " as it is st
7100: 61 74 65 20 5c 22 22 20 28 74 65 73 74 3a 67 65 ate \"" (test:ge
7110: 74 2d 73 74 61 74 65 20 74 65 73 74 64 61 74 29 t-state testdat)
7120: 20 0a 09 09 09 09 22 5c 22 20 61 6e 64 20 73 74 ....."\" and st
7130: 61 74 75 73 20 5c 22 22 20 28 74 65 73 74 3a 67 atus \"" (test:g
7140: 65 74 2d 73 74 61 74 75 73 20 74 65 73 74 64 61 et-status testda
7150: 74 29 20 22 5c 22 2c 20 75 73 65 20 2d 72 65 72 t) "\", use -rer
7160: 75 6e 20 5c 22 22 20 28 74 65 73 74 3a 67 65 74 un \"" (test:get
7170: 2d 73 74 61 74 75 73 20 74 65 73 74 64 61 74 29 -status testdat)
7180: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
7190: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
71a0: 20 22 5c 22 20 6f 72 20 2d 66 6f 72 63 65 20 74 "\" or -force t
71b0: 6f 20 6f 76 65 72 72 69 64 65 22 29 29 0a 09 20 o override"))..
71c0: 20 20 20 20 20 20 3b 3b 20 4e 4f 54 45 3a 20 4e ;; NOTE: N
71d0: 6f 20 6c 6f 6e 67 65 72 20 62 65 20 63 68 65 63 o longer be chec
71e0: 6b 69 6e 67 20 70 72 65 72 65 71 75 69 73 69 74 king prerequisit
71f0: 65 73 20 68 65 72 65 21 20 57 69 6c 6c 20 6e 65 es here! Will ne
7200: 76 65 72 20 67 65 74 20 68 65 72 65 20 75 6e 6c ver get here unl
7210: 65 73 73 20 70 72 65 72 65 71 73 20 61 72 65 0a ess prereqs are.
7220: 09 20 20 20 20 20 20 20 3b 3b 20 20 20 20 20 20 . ;;
7230: 20 61 6c 72 65 61 64 79 20 6d 65 74 2e 0a 09 20 already met...
7240: 20 20 20 20 20 20 28 69 66 20 28 6e 6f 74 20 28 (if (not (
7250: 6c 61 75 6e 63 68 2d 74 65 73 74 20 23 66 20 72 launch-test #f r
7260: 75 6e 2d 69 64 20 72 75 6e 6e 61 6d 65 20 74 65 un-id runname te
7270: 73 74 2d 63 6f 6e 66 20 6b 65 79 76 61 6c 6c 73 st-conf keyvalls
7280: 74 20 74 65 73 74 2d 6e 61 6d 65 20 74 65 73 74 t test-name test
7290: 2d 70 61 74 68 20 69 74 65 6d 64 61 74 20 66 6c -path itemdat fl
72a0: 61 67 73 29 29 0a 09 09 20 20 20 28 62 65 67 69 ags))... (begi
72b0: 6e 0a 09 09 20 20 20 20 20 28 70 72 69 6e 74 20 n... (print
72c0: 22 45 52 52 4f 52 3a 20 46 61 69 6c 65 64 20 74 "ERROR: Failed t
72d0: 6f 20 6c 61 75 6e 63 68 20 74 68 65 20 74 65 73 o launch the tes
72e0: 74 2e 20 45 78 69 74 69 6e 67 20 61 73 20 73 6f t. Exiting as so
72f0: 6f 6e 20 61 73 20 70 6f 73 73 69 62 6c 65 22 29 on as possible")
7300: 0a 09 09 20 20 20 20 20 28 73 65 74 21 20 2a 67 ... (set! *g
7310: 6c 6f 62 61 6c 65 78 69 74 73 74 61 74 75 73 2a lobalexitstatus*
7320: 20 31 29 20 3b 3b 20 0a 09 09 20 20 20 20 20 28 1) ;; ... (
7330: 70 72 6f 63 65 73 73 2d 73 69 67 6e 61 6c 20 28 process-signal (
7340: 63 75 72 72 65 6e 74 2d 70 72 6f 63 65 73 73 2d current-process-
7350: 69 64 29 20 73 69 67 6e 61 6c 2f 6b 69 6c 6c 29 id) signal/kill)
7360: 29 29 29 29 29 0a 09 28 28 4b 49 4c 4c 45 44 29 )))))..((KILLED)
7370: 20 0a 09 20 28 64 65 62 75 67 3a 70 72 69 6e 74 .. (debug:print
7380: 20 31 20 22 4e 4f 54 45 3a 20 22 20 6e 65 77 2d 1 "NOTE: " new-
7390: 74 65 73 74 2d 6e 61 6d 65 20 22 20 69 73 20 61 test-name " is a
73a0: 6c 72 65 61 64 79 20 72 75 6e 6e 69 6e 67 20 6f lready running o
73b0: 72 20 77 61 73 20 65 78 70 6c 69 63 74 6c 79 20 r was explictly
73c0: 6b 69 6c 6c 65 64 2c 20 75 73 65 20 2d 66 6f 72 killed, use -for
73d0: 63 65 20 74 6f 20 6c 61 75 6e 63 68 20 69 74 2e ce to launch it.
73e0: 22 29 29 0a 09 28 28 4c 41 55 4e 43 48 45 44 20 "))..((LAUNCHED
73f0: 52 45 4d 4f 54 45 48 4f 53 54 53 54 41 52 54 20 REMOTEHOSTSTART
7400: 52 55 4e 4e 49 4e 47 29 20 20 0a 09 20 28 69 66 RUNNING) .. (if
7410: 20 28 3e 20 28 2d 20 28 63 75 72 72 65 6e 74 2d (> (- (current-
7420: 73 65 63 6f 6e 64 73 29 28 2b 20 28 64 62 3a 74 seconds)(+ (db:t
7430: 65 73 74 2d 67 65 74 2d 65 76 65 6e 74 5f 74 69 est-get-event_ti
7440: 6d 65 20 74 65 73 74 64 61 74 29 0a 09 09 09 09 me testdat).....
7450: 20 20 20 20 20 20 20 28 64 62 3a 74 65 73 74 2d (db:test-
7460: 67 65 74 2d 72 75 6e 5f 64 75 72 61 74 69 6f 6e get-run_duration
7470: 20 74 65 73 74 64 61 74 29 29 29 0a 09 09 36 30 testdat)))...60
7480: 30 29 20 3b 3b 20 69 2e 65 2e 20 6e 6f 20 75 70 0) ;; i.e. no up
7490: 64 61 74 65 20 66 6f 72 20 6d 6f 72 65 20 74 68 date for more th
74a0: 61 6e 20 36 30 30 20 73 65 63 6f 6e 64 73 0a 09 an 600 seconds..
74b0: 20 20 20 20 20 28 62 65 67 69 6e 0a 09 20 20 20 (begin..
74c0: 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 (debug:print
74d0: 20 30 20 22 57 41 52 4e 49 4e 47 3a 20 54 65 73 0 "WARNING: Tes
74e0: 74 20 22 20 74 65 73 74 2d 6e 61 6d 65 20 22 20 t " test-name "
74f0: 61 70 70 65 61 72 73 20 74 6f 20 62 65 20 64 65 appears to be de
7500: 61 64 2e 20 46 6f 72 63 69 6e 67 20 69 74 20 74 ad. Forcing it t
7510: 6f 20 73 74 61 74 65 20 49 4e 43 4f 4d 50 4c 45 o state INCOMPLE
7520: 54 45 20 61 6e 64 20 73 74 61 74 75 73 20 53 54 TE and status ST
7530: 55 43 4b 2f 44 45 41 44 22 29 0a 09 20 20 20 20 UCK/DEAD")..
7540: 20 20 20 28 6f 70 65 6e 2d 72 75 6e 2d 63 6c 6f (open-run-clo
7550: 73 65 20 74 65 73 74 2d 73 65 74 2d 73 74 61 74 se test-set-stat
7560: 75 73 21 20 64 62 20 74 65 73 74 2d 69 64 20 22 us! db test-id "
7570: 49 4e 43 4f 4d 50 4c 45 54 45 22 20 22 53 54 55 INCOMPLETE" "STU
7580: 43 4b 2f 44 45 41 44 22 20 22 54 65 73 74 20 69 CK/DEAD" "Test i
7590: 73 20 73 74 75 63 6b 20 6f 72 20 64 65 61 64 22 s stuck or dead"
75a0: 20 23 66 29 29 0a 09 20 20 20 20 20 28 64 65 62 #f)).. (deb
75b0: 75 67 3a 70 72 69 6e 74 20 32 20 22 4e 4f 54 45 ug:print 2 "NOTE
75c0: 3a 20 22 20 74 65 73 74 2d 6e 61 6d 65 20 22 20 : " test-name "
75d0: 69 73 20 61 6c 72 65 61 64 79 20 72 75 6e 6e 69 is already runni
75e0: 6e 67 22 29 29 29 0a 09 28 65 6c 73 65 20 20 20 ng")))..(else
75f0: 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 (debug:print
7600: 20 30 20 22 45 52 52 4f 52 3a 20 46 61 69 6c 65 0 "ERROR: Faile
7610: 64 20 74 6f 20 6c 61 75 6e 63 68 20 74 65 73 74 d to launch test
7620: 20 22 20 6e 65 77 2d 74 65 73 74 2d 6e 61 6d 65 " new-test-name
7630: 20 22 2e 20 55 6e 72 65 63 6f 67 6e 69 73 65 64 ". Unrecognised
7640: 20 73 74 61 74 65 20 22 20 28 74 65 73 74 3a 67 state " (test:g
7650: 65 74 2d 73 74 61 74 65 20 74 65 73 74 64 61 74 et-state testdat
7660: 29 29 29 29 29 29 29 0a 0a 3b 3b 3d 3d 3d 3d 3d )))))))..;;=====
7670: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7680: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7690: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
76a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
76b0: 3d 0a 3b 3b 20 45 4e 44 20 4f 46 20 4e 45 57 20 =.;; END OF NEW
76c0: 53 54 55 46 46 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d STUFF.;;========
76d0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
76e0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
76f0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7700: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a ==============..
7710: 28 64 65 66 69 6e 65 20 28 67 65 74 2d 64 69 72 (define (get-dir
7720: 2d 75 70 2d 6e 20 64 69 72 20 2e 20 70 61 72 61 -up-n dir . para
7730: 6d 73 29 20 0a 20 20 28 6c 65 74 20 28 28 64 70 ms) . (let ((dp
7740: 61 72 74 73 20 20 28 73 74 72 69 6e 67 2d 73 70 arts (string-sp
7750: 6c 69 74 20 64 69 72 20 22 2f 22 29 29 0a 09 28 lit dir "/"))..(
7760: 63 6f 75 6e 74 20 20 20 28 69 66 20 28 6e 75 6c count (if (nul
7770: 6c 3f 20 70 61 72 61 6d 73 29 20 31 20 28 63 61 l? params) 1 (ca
7780: 72 20 70 61 72 61 6d 73 29 29 29 29 0a 20 20 20 r params)))).
7790: 20 28 63 6f 6e 63 20 22 2f 22 20 28 73 74 72 69 (conc "/" (stri
77a0: 6e 67 2d 69 6e 74 65 72 73 70 65 72 73 65 20 0a ng-intersperse .
77b0: 09 20 20 20 20 20 20 20 28 74 61 6b 65 20 64 70 . (take dp
77c0: 61 72 74 73 20 28 2d 20 28 6c 65 6e 67 74 68 20 arts (- (length
77d0: 64 70 61 72 74 73 29 20 63 6f 75 6e 74 29 29 0a dparts) count)).
77e0: 09 20 20 20 20 20 20 20 22 2f 22 29 29 29 29 0a . "/")))).
77f0: 3b 3b 20 52 65 6d 6f 76 65 20 72 75 6e 73 0a 3b ;; Remove runs.;
7800: 3b 20 66 69 65 6c 64 73 20 61 72 65 20 70 61 73 ; fields are pas
7810: 73 69 6e 67 20 69 6e 20 74 68 72 6f 75 67 68 20 sing in through
7820: 0a 3b 3b 20 61 63 74 69 6f 6e 3a 0a 3b 3b 20 20 .;; action:.;;
7830: 20 20 27 72 65 6d 6f 76 65 2d 72 75 6e 73 0a 3b 'remove-runs.;
7840: 3b 20 20 20 20 27 73 65 74 2d 73 74 61 74 65 2d ; 'set-state-
7850: 73 74 61 74 75 73 0a 3b 3b 0a 3b 3b 20 4e 42 2f status.;;.;; NB/
7860: 2f 20 73 68 6f 75 6c 64 20 70 61 73 73 20 69 6e / should pass in
7870: 20 6b 65 79 73 3f 0a 3b 3b 0a 28 64 65 66 69 6e keys?.;;.(defin
7880: 65 20 28 72 75 6e 73 3a 6f 70 65 72 61 74 65 2d e (runs:operate-
7890: 6f 6e 20 64 62 20 61 63 74 69 6f 6e 20 72 75 6e on db action run
78a0: 6e 61 6d 65 70 61 74 74 20 74 65 73 74 70 61 74 namepatt testpat
78b0: 74 20 69 74 65 6d 70 61 74 74 20 23 21 6b 65 79 t itempatt #!key
78c0: 20 28 73 74 61 74 65 20 23 66 29 28 73 74 61 74 (state #f)(stat
78d0: 75 73 20 23 66 29 28 6e 65 77 2d 73 74 61 74 65 us #f)(new-state
78e0: 2d 73 74 61 74 75 73 20 23 66 29 29 0a 20 20 28 -status #f)). (
78f0: 6c 65 74 2a 20 28 28 6b 65 79 73 20 20 20 20 20 let* ((keys
7900: 20 20 20 20 28 72 64 62 3a 67 65 74 2d 6b 65 79 (rdb:get-key
7910: 73 20 64 62 29 29 0a 09 20 28 72 75 6e 64 61 74 s db)).. (rundat
7920: 20 20 20 20 20 20 20 28 72 75 6e 73 3a 67 65 74 (runs:get
7930: 2d 72 75 6e 73 2d 62 79 2d 70 61 74 74 20 64 62 -runs-by-patt db
7940: 20 6b 65 79 73 20 72 75 6e 6e 61 6d 65 70 61 74 keys runnamepat
7950: 74 29 29 0a 09 20 28 68 65 61 64 65 72 20 20 20 t)).. (header
7960: 20 20 20 20 28 76 65 63 74 6f 72 2d 72 65 66 20 (vector-ref
7970: 72 75 6e 64 61 74 20 30 29 29 0a 09 20 28 72 75 rundat 0)).. (ru
7980: 6e 73 20 20 20 20 20 20 20 20 20 28 76 65 63 74 ns (vect
7990: 6f 72 2d 72 65 66 20 72 75 6e 64 61 74 20 31 29 or-ref rundat 1)
79a0: 29 0a 09 20 28 73 74 61 74 65 73 20 20 20 20 20 ).. (states
79b0: 20 20 28 69 66 20 73 74 61 74 65 20 20 28 73 74 (if state (st
79c0: 72 69 6e 67 2d 73 70 6c 69 74 20 73 74 61 74 65 ring-split state
79d0: 20 20 22 2c 22 29 20 27 28 29 29 29 0a 09 20 28 ",") '())).. (
79e0: 73 74 61 74 75 73 65 73 20 20 20 20 20 28 69 66 statuses (if
79f0: 20 73 74 61 74 75 73 20 28 73 74 72 69 6e 67 2d status (string-
7a00: 73 70 6c 69 74 20 73 74 61 74 75 73 20 22 2c 22 split status ","
7a10: 29 20 27 28 29 29 29 0a 09 20 28 73 74 61 74 65 ) '())).. (state
7a20: 2d 73 74 61 74 75 73 20 28 69 66 20 28 73 74 72 -status (if (str
7a30: 69 6e 67 3f 20 6e 65 77 2d 73 74 61 74 65 2d 73 ing? new-state-s
7a40: 74 61 74 75 73 29 20 28 73 74 72 69 6e 67 2d 73 tatus) (string-s
7a50: 70 6c 69 74 20 6e 65 77 2d 73 74 61 74 65 2d 73 plit new-state-s
7a60: 74 61 74 75 73 20 22 2c 22 29 20 27 28 23 66 20 tatus ",") '(#f
7a70: 23 66 29 29 29 29 0a 20 20 20 20 28 64 65 62 75 #f)))). (debu
7a80: 67 3a 70 72 69 6e 74 20 32 20 22 48 65 61 64 65 g:print 2 "Heade
7a90: 72 3a 20 22 20 68 65 61 64 65 72 20 22 20 61 63 r: " header " ac
7aa0: 74 69 6f 6e 3a 20 22 20 61 63 74 69 6f 6e 20 22 tion: " action "
7ab0: 20 6e 65 77 2d 73 74 61 74 65 2d 73 74 61 74 75 new-state-statu
7ac0: 73 3a 20 22 20 6e 65 77 2d 73 74 61 74 65 2d 73 s: " new-state-s
7ad0: 74 61 74 75 73 29 0a 20 20 20 20 28 66 6f 72 2d tatus). (for-
7ae0: 65 61 63 68 0a 20 20 20 20 20 28 6c 61 6d 62 64 each. (lambd
7af0: 61 20 28 72 75 6e 29 0a 20 20 20 20 20 20 20 28 a (run). (
7b00: 6c 65 74 20 28 28 72 75 6e 6b 65 79 20 28 73 74 let ((runkey (st
7b10: 72 69 6e 67 2d 69 6e 74 65 72 73 70 65 72 73 65 ring-intersperse
7b20: 20 28 6d 61 70 20 28 6c 61 6d 62 64 61 20 28 6b (map (lambda (k
7b30: 29 0a 09 09 09 09 09 09 28 64 62 3a 67 65 74 2d ).......(db:get-
7b40: 76 61 6c 75 65 2d 62 79 2d 68 65 61 64 65 72 20 value-by-header
7b50: 72 75 6e 20 68 65 61 64 65 72 20 28 76 65 63 74 run header (vect
7b60: 6f 72 2d 72 65 66 20 6b 20 30 29 29 29 20 6b 65 or-ref k 0))) ke
7b70: 79 73 29 20 22 2f 22 29 29 0a 09 20 20 20 20 20 ys) "/"))..
7b80: 28 64 69 72 73 2d 74 6f 2d 72 65 6d 6f 76 65 20 (dirs-to-remove
7b90: 28 6d 61 6b 65 2d 68 61 73 68 2d 74 61 62 6c 65 (make-hash-table
7ba0: 29 29 29 0a 09 20 28 6c 65 74 2a 20 28 28 72 75 ))).. (let* ((ru
7bb0: 6e 2d 69 64 20 20 20 20 28 64 62 3a 67 65 74 2d n-id (db:get-
7bc0: 76 61 6c 75 65 2d 62 79 2d 68 65 61 64 65 72 20 value-by-header
7bd0: 72 75 6e 20 68 65 61 64 65 72 20 22 69 64 22 29 run header "id")
7be0: 29 0a 09 09 28 72 75 6e 2d 73 74 61 74 65 20 28 )...(run-state (
7bf0: 64 62 3a 67 65 74 2d 76 61 6c 75 65 2d 62 79 2d db:get-value-by-
7c00: 68 65 61 64 65 72 20 72 75 6e 20 68 65 61 64 65 header run heade
7c10: 72 20 22 73 74 61 74 65 22 29 29 0a 09 09 28 74 r "state"))...(t
7c20: 65 73 74 73 20 20 20 20 20 28 69 66 20 28 6e 6f ests (if (no
7c30: 74 20 28 65 71 75 61 6c 3f 20 72 75 6e 2d 73 74 t (equal? run-st
7c40: 61 74 65 20 22 6c 6f 63 6b 65 64 22 29 29 0a 09 ate "locked"))..
7c50: 09 09 20 20 20 20 20 20 20 28 72 64 62 3a 67 65 .. (rdb:ge
7c60: 74 2d 74 65 73 74 73 2d 66 6f 72 2d 72 75 6e 20 t-tests-for-run
7c70: 64 62 20 28 64 62 3a 67 65 74 2d 76 61 6c 75 65 db (db:get-value
7c80: 2d 62 79 2d 68 65 61 64 65 72 20 72 75 6e 20 68 -by-header run h
7c90: 65 61 64 65 72 20 22 69 64 22 29 0a 09 09 09 09 eader "id").....
7ca0: 09 09 20 20 20 20 20 20 74 65 73 74 70 61 74 74 .. testpatt
7cb0: 20 69 74 65 6d 70 61 74 74 20 73 74 61 74 65 73 itempatt states
7cc0: 20 73 74 61 74 75 73 65 73 0a 09 09 09 09 09 09 statuses.......
7cd0: 20 20 20 20 20 20 6e 6f 74 2d 69 6e 3a 20 20 23 not-in: #
7ce0: 66 0a 09 09 09 09 09 09 20 20 20 20 20 20 73 6f f....... so
7cf0: 72 74 2d 62 79 3a 20 28 63 61 73 65 20 61 63 74 rt-by: (case act
7d00: 69 6f 6e 0a 09 09 09 09 09 09 09 09 20 28 28 72 ion......... ((r
7d10: 65 6d 6f 76 65 2d 72 75 6e 73 29 20 27 72 75 6e emove-runs) 'run
7d20: 64 69 72 29 0a 09 09 09 09 09 09 09 09 20 28 65 dir)......... (e
7d30: 6c 73 65 20 20 20 20 20 20 20 20 20 20 27 65 76 lse 'ev
7d40: 65 6e 74 5f 74 69 6d 65 29 29 29 0a 09 09 09 20 ent_time)))....
7d50: 20 20 20 20 20 20 27 28 29 29 29 0a 09 09 28 6c '()))...(l
7d60: 61 73 74 74 70 61 74 68 20 22 2f 64 6f 65 73 2f asttpath "/does/
7d70: 6e 6f 74 2f 65 78 69 73 74 2f 49 2f 68 6f 70 65 not/exist/I/hope
7d80: 22 29 29 0a 0a 09 20 20 20 28 69 66 20 28 6e 6f "))... (if (no
7d90: 74 20 28 6e 75 6c 6c 3f 20 74 65 73 74 73 29 29 t (null? tests))
7da0: 0a 09 20 20 20 20 20 20 20 28 62 65 67 69 6e 0a .. (begin.
7db0: 09 09 20 28 63 61 73 65 20 61 63 74 69 6f 6e 0a .. (case action.
7dc0: 09 09 20 20 20 28 28 72 65 6d 6f 76 65 2d 72 75 .. ((remove-ru
7dd0: 6e 73 29 0a 09 09 20 20 20 20 28 64 65 62 75 67 ns)... (debug
7de0: 3a 70 72 69 6e 74 20 31 20 22 52 65 6d 6f 76 69 :print 1 "Removi
7df0: 6e 67 20 74 65 73 74 73 20 66 6f 72 20 72 75 6e ng tests for run
7e00: 3a 20 22 20 72 75 6e 6b 65 79 20 22 20 22 20 28 : " runkey " " (
7e10: 64 62 3a 67 65 74 2d 76 61 6c 75 65 2d 62 79 2d db:get-value-by-
7e20: 68 65 61 64 65 72 20 72 75 6e 20 68 65 61 64 65 header run heade
7e30: 72 20 22 72 75 6e 6e 61 6d 65 22 29 29 29 0a 09 r "runname")))..
7e40: 09 20 20 20 28 28 73 65 74 2d 73 74 61 74 65 2d . ((set-state-
7e50: 73 74 61 74 75 73 29 0a 09 09 20 20 20 20 28 64 status)... (d
7e60: 65 62 75 67 3a 70 72 69 6e 74 20 31 20 22 4d 6f ebug:print 1 "Mo
7e70: 64 69 66 79 69 6e 67 20 73 74 61 74 65 20 61 6e difying state an
7e80: 64 20 73 74 61 75 73 20 66 6f 72 20 74 65 73 74 d staus for test
7e90: 73 20 66 6f 72 20 72 75 6e 3a 20 22 20 72 75 6e s for run: " run
7ea0: 6b 65 79 20 22 20 22 20 28 64 62 3a 67 65 74 2d key " " (db:get-
7eb0: 76 61 6c 75 65 2d 62 79 2d 68 65 61 64 65 72 20 value-by-header
7ec0: 72 75 6e 20 68 65 61 64 65 72 20 22 72 75 6e 6e run header "runn
7ed0: 61 6d 65 22 29 29 29 0a 09 09 20 20 20 28 65 6c ame")))... (el
7ee0: 73 65 0a 09 09 20 20 20 20 28 70 72 69 6e 74 20 se... (print
7ef0: 22 49 4e 46 4f 3a 20 61 63 74 69 6f 6e 20 6e 6f "INFO: action no
7f00: 74 20 72 65 63 6f 67 6e 69 73 65 64 20 22 20 61 t recognised " a
7f10: 63 74 69 6f 6e 29 29 29 0a 09 09 20 28 66 6f 72 ction)))... (for
7f20: 2d 65 61 63 68 0a 09 09 20 20 28 6c 61 6d 62 64 -each... (lambd
7f30: 61 20 28 74 65 73 74 29 0a 09 09 20 20 20 20 28 a (test)... (
7f40: 6c 65 74 2a 20 28 28 69 74 65 6d 2d 70 61 74 68 let* ((item-path
7f50: 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 69 74 (db:test-get-it
7f60: 65 6d 2d 70 61 74 68 20 74 65 73 74 29 29 0a 09 em-path test))..
7f70: 09 09 20 20 20 28 74 65 73 74 2d 6e 61 6d 65 20 .. (test-name
7f80: 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 74 65 73 (db:test-get-tes
7f90: 74 6e 61 6d 65 20 74 65 73 74 29 29 0a 09 09 09 tname test))....
7fa0: 20 20 20 28 72 75 6e 2d 64 69 72 20 20 20 28 64 (run-dir (d
7fb0: 62 3a 74 65 73 74 2d 67 65 74 2d 72 75 6e 64 69 b:test-get-rundi
7fc0: 72 20 74 65 73 74 29 29 29 0a 09 09 20 20 20 20 r test)))...
7fd0: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 31 (debug:print 1
7fe0: 20 22 20 20 22 20 28 64 62 3a 74 65 73 74 2d 67 " " (db:test-g
7ff0: 65 74 2d 74 65 73 74 6e 61 6d 65 20 74 65 73 74 et-testname test
8000: 29 20 22 20 69 64 3a 20 22 20 28 64 62 3a 74 65 ) " id: " (db:te
8010: 73 74 2d 67 65 74 2d 69 64 20 74 65 73 74 29 20 st-get-id test)
8020: 22 20 22 20 69 74 65 6d 2d 70 61 74 68 20 22 20 " " item-path "
8030: 61 63 74 69 6f 6e 3a 20 22 20 61 63 74 69 6f 6e action: " action
8040: 29 0a 09 09 20 20 20 20 20 20 28 63 61 73 65 20 )... (case
8050: 61 63 74 69 6f 6e 0a 09 09 09 28 28 72 65 6d 6f action....((remo
8060: 76 65 2d 72 75 6e 73 29 0a 09 09 09 20 28 72 64 ve-runs).... (rd
8070: 62 3a 64 65 6c 65 74 65 2d 74 65 73 74 2d 72 65 b:delete-test-re
8080: 63 6f 72 64 73 20 64 62 20 28 64 62 3a 74 65 73 cords db (db:tes
8090: 74 2d 67 65 74 2d 69 64 20 74 65 73 74 29 29 0a t-get-id test)).
80a0: 09 09 09 20 28 64 65 62 75 67 3a 70 72 69 6e 74 ... (debug:print
80b0: 20 31 20 22 49 4e 46 4f 3a 20 41 74 74 65 6d 70 1 "INFO: Attemp
80c0: 74 69 6e 67 20 74 6f 20 72 65 6d 6f 76 65 20 64 ting to remove d
80d0: 69 72 20 22 20 72 75 6e 2d 64 69 72 29 0a 09 09 ir " run-dir)...
80e0: 09 20 28 69 66 20 28 61 6e 64 20 28 3e 20 28 73 . (if (and (> (s
80f0: 74 72 69 6e 67 2d 6c 65 6e 67 74 68 20 72 75 6e tring-length run
8100: 2d 64 69 72 29 20 35 29 0a 09 09 09 09 20 20 28 -dir) 5)..... (
8110: 66 69 6c 65 2d 65 78 69 73 74 73 3f 20 72 75 6e file-exists? run
8120: 2d 64 69 72 29 29 20 3b 3b 20 62 61 64 20 68 65 -dir)) ;; bad he
8130: 75 72 69 73 74 69 63 20 62 75 74 20 73 68 6f 75 uristic but shou
8140: 6c 64 20 70 72 65 76 65 6e 74 20 2f 74 6d 70 20 ld prevent /tmp
8150: 2f 68 6f 6d 65 20 65 74 63 2e 0a 09 09 09 20 20 /home etc.....
8160: 20 20 20 28 6c 65 74 2a 20 28 28 72 65 61 6c 70 (let* ((realp
8170: 61 74 68 20 28 72 65 73 6f 6c 76 65 2d 70 61 74 ath (resolve-pat
8180: 68 6e 61 6d 65 20 72 75 6e 2d 64 69 72 29 29 29 hname run-dir)))
8190: 0a 09 09 09 20 20 20 20 20 20 20 28 64 65 62 75 .... (debu
81a0: 67 3a 70 72 69 6e 74 20 31 20 22 49 4e 46 4f 3a g:print 1 "INFO:
81b0: 20 52 65 61 6c 20 70 61 74 68 20 6f 66 20 69 73 Real path of is
81c0: 20 22 20 72 65 61 6c 70 61 74 68 29 0a 09 09 09 " realpath)....
81d0: 20 20 20 20 20 20 20 28 69 66 20 28 66 69 6c 65 (if (file
81e0: 2d 65 78 69 73 74 73 3f 20 72 65 61 6c 70 61 74 -exists? realpat
81f0: 68 29 0a 09 09 09 09 20 20 20 28 69 66 20 28 3e h)..... (if (>
8200: 20 28 73 79 73 74 65 6d 20 28 63 6f 6e 63 20 22 (system (conc "
8210: 72 6d 20 2d 72 66 20 22 20 72 65 61 6c 70 61 74 rm -rf " realpat
8220: 68 29 29 20 30 29 0a 09 09 09 09 20 20 20 20 20 h)) 0).....
8230: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 (debug:print 0
8240: 20 22 45 52 52 4f 52 3a 20 54 68 65 72 65 20 77 "ERROR: There w
8250: 61 73 20 61 20 70 72 6f 62 6c 65 6d 20 72 65 6d as a problem rem
8260: 6f 76 69 6e 67 20 22 20 72 65 61 6c 70 61 74 68 oving " realpath
8270: 20 22 20 77 69 74 68 20 72 6d 20 2d 66 22 29 29 " with rm -f"))
8280: 0a 09 09 09 09 20 20 20 28 64 65 62 75 67 3a 70 ..... (debug:p
8290: 72 69 6e 74 20 30 20 22 57 41 52 4e 49 4e 47 3a rint 0 "WARNING:
82a0: 20 74 65 73 74 20 72 75 6e 20 64 69 72 20 22 20 test run dir "
82b0: 72 65 61 6c 70 61 74 68 20 22 20 61 70 70 65 61 realpath " appea
82c0: 72 73 20 74 6f 20 6e 6f 74 20 65 78 69 73 74 22 rs to not exist"
82d0: 29 29 0a 09 09 09 20 20 20 20 20 20 20 28 69 66 )).... (if
82e0: 20 28 66 69 6c 65 2d 65 78 69 73 74 73 3f 20 72 (file-exists? r
82f0: 75 6e 2d 64 69 72 29 20 3b 3b 20 74 68 65 20 6c un-dir) ;; the l
8300: 69 6e 6b 0a 09 09 09 09 20 20 20 28 69 66 20 28 ink..... (if (
8310: 73 79 6d 62 6f 6c 69 63 2d 6c 69 6e 6b 3f 20 72 symbolic-link? r
8320: 75 6e 2d 64 69 72 29 0a 09 09 09 09 20 20 20 20 un-dir).....
8330: 20 20 20 28 64 65 6c 65 74 65 2d 66 69 6c 65 20 (delete-file
8340: 72 75 6e 2d 64 69 72 29 0a 09 09 09 09 20 20 20 run-dir).....
8350: 20 20 20 20 28 69 66 20 28 64 69 72 65 63 74 6f (if (directo
8360: 72 79 3f 20 72 75 6e 2d 64 69 72 29 0a 09 09 09 ry? run-dir)....
8370: 09 09 20 20 20 28 69 66 20 28 3e 20 28 64 69 72 .. (if (> (dir
8380: 65 63 74 6f 72 79 2d 66 6f 6c 64 20 28 6c 61 6d ectory-fold (lam
8390: 62 64 61 20 28 66 20 78 29 28 2b 20 31 20 78 29 bda (f x)(+ 1 x)
83a0: 29 20 30 20 72 75 6e 2d 64 69 72 29 20 30 29 0a ) 0 run-dir) 0).
83b0: 09 09 09 09 09 20 20 20 20 20 20 20 28 64 65 62 ..... (deb
83c0: 75 67 3a 70 72 69 6e 74 20 30 20 22 57 41 52 4e ug:print 0 "WARN
83d0: 49 4e 47 3a 20 72 65 66 75 73 69 6e 67 20 74 6f ING: refusing to
83e0: 20 72 65 6d 6f 76 65 20 22 20 72 75 6e 2d 64 69 remove " run-di
83f0: 72 20 22 20 61 73 20 69 74 20 69 73 20 6e 6f 74 r " as it is not
8400: 20 65 6d 70 74 79 22 29 0a 09 09 09 09 09 20 20 empty")......
8410: 20 20 20 20 20 28 64 65 6c 65 74 65 2d 64 69 72 (delete-dir
8420: 65 63 74 6f 72 79 20 72 75 6e 2d 64 69 72 29 29 ectory run-dir))
8430: 20 3b 3b 20 69 74 20 73 68 6f 75 6c 64 20 62 65 ;; it should be
8440: 20 65 6d 70 74 79 20 62 79 20 68 65 72 65 20 42 empty by here B
8450: 55 47 20 42 55 47 2c 20 61 64 64 20 65 72 72 6f UG BUG, add erro
8460: 72 20 63 61 74 63 68 0a 09 09 09 09 09 20 20 20 r catch......
8470: 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 22 (debug:print 0 "
8480: 45 52 52 4f 52 3a 20 72 65 66 75 73 69 6e 67 20 ERROR: refusing
8490: 74 6f 20 72 65 6d 6f 76 65 20 22 20 72 75 6e 2d to remove " run-
84a0: 64 69 72 20 22 20 61 73 20 69 74 20 69 73 20 6e dir " as it is n
84b0: 65 69 74 68 65 72 20 61 20 73 79 6d 6c 69 6e 6b either a symlink
84c0: 20 6e 6f 72 20 61 20 64 69 72 65 63 74 6f 72 79 nor a directory
84d0: 22 29 0a 09 09 09 09 09 20 20 20 29 29 29 29 0a ")...... )))).
84e0: 09 09 09 20 20 20 20 20 28 64 65 62 75 67 3a 70 ... (debug:p
84f0: 72 69 6e 74 20 30 20 22 57 41 52 4e 49 4e 47 3a rint 0 "WARNING:
8500: 20 64 69 72 65 63 74 6f 72 79 20 61 6c 72 65 61 directory alrea
8510: 64 79 20 72 65 6d 6f 76 65 64 20 22 20 72 75 6e dy removed " run
8520: 2d 64 69 72 29 29 29 0a 09 09 09 28 28 73 65 74 -dir)))....((set
8530: 2d 73 74 61 74 65 2d 73 74 61 74 75 73 29 0a 09 -state-status)..
8540: 09 09 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 .. (debug:print
8550: 32 20 22 49 4e 46 4f 3a 20 6e 65 77 20 73 74 61 2 "INFO: new sta
8560: 74 65 20 22 20 28 63 61 72 20 73 74 61 74 65 2d te " (car state-
8570: 73 74 61 74 75 73 29 20 22 2c 20 6e 65 77 20 73 status) ", new s
8580: 74 61 74 75 73 20 22 20 28 63 61 64 72 20 73 74 tatus " (cadr st
8590: 61 74 65 2d 73 74 61 74 75 73 29 29 0a 09 09 09 ate-status))....
85a0: 20 28 64 62 3a 74 65 73 74 2d 73 65 74 2d 73 74 (db:test-set-st
85b0: 61 74 65 2d 73 74 61 74 75 73 2d 62 79 2d 69 64 ate-status-by-id
85c0: 20 64 62 20 28 64 62 3a 74 65 73 74 2d 67 65 74 db (db:test-get
85d0: 2d 69 64 20 74 65 73 74 29 20 28 63 61 72 20 73 -id test) (car s
85e0: 74 61 74 65 2d 73 74 61 74 75 73 29 28 63 61 64 tate-status)(cad
85f0: 72 20 73 74 61 74 65 2d 73 74 61 74 75 73 29 20 r state-status)
8600: 23 66 29 29 29 29 29 0a 09 09 20 20 74 65 73 74 #f)))))... test
8610: 73 29 29 29 0a 09 20 20 20 0a 09 20 20 20 3b 3b s))).. .. ;;
8620: 20 72 65 6d 6f 76 65 20 74 68 65 20 72 75 6e 20 remove the run
8630: 69 66 20 7a 65 72 6f 20 74 65 73 74 73 20 72 65 if zero tests re
8640: 6d 61 69 6e 0a 09 20 20 20 28 69 66 20 28 65 71 main.. (if (eq
8650: 3f 20 61 63 74 69 6f 6e 20 27 72 65 6d 6f 76 65 ? action 'remove
8660: 2d 72 75 6e 73 29 0a 09 20 20 20 20 20 20 20 28 -runs).. (
8670: 6c 65 74 20 28 28 72 65 6d 74 65 73 74 73 20 28 let ((remtests (
8680: 72 64 62 3a 67 65 74 2d 74 65 73 74 73 2d 66 6f rdb:get-tests-fo
8690: 72 2d 72 75 6e 20 64 62 20 28 64 62 3a 67 65 74 r-run db (db:get
86a0: 2d 76 61 6c 75 65 2d 62 79 2d 68 65 61 64 65 72 -value-by-header
86b0: 20 72 75 6e 20 68 65 61 64 65 72 20 22 69 64 22 run header "id"
86c0: 29 20 23 66 20 23 66 20 27 28 29 20 27 28 29 29 ) #f #f '() '())
86d0: 29 29 0a 09 09 20 28 69 66 20 28 6e 75 6c 6c 3f ))... (if (null?
86e0: 20 72 65 6d 74 65 73 74 73 29 20 3b 3b 20 6e 6f remtests) ;; no
86f0: 20 6d 6f 72 65 20 74 65 73 74 73 20 72 65 6d 61 more tests rema
8700: 69 6e 69 6e 67 0a 09 09 20 20 20 20 20 28 6c 65 ining... (le
8710: 74 2a 20 28 28 64 70 61 72 74 73 20 20 28 73 74 t* ((dparts (st
8720: 72 69 6e 67 2d 73 70 6c 69 74 20 6c 61 73 74 74 ring-split lastt
8730: 70 61 74 68 20 22 2f 22 29 29 0a 09 09 09 20 20 path "/"))....
8740: 20 20 28 72 75 6e 70 61 74 68 20 28 63 6f 6e 63 (runpath (conc
8750: 20 22 2f 22 20 28 73 74 72 69 6e 67 2d 69 6e 74 "/" (string-int
8760: 65 72 73 70 65 72 73 65 20 0a 09 09 09 09 09 09 ersperse .......
8770: 28 74 61 6b 65 20 64 70 61 72 74 73 20 28 2d 20 (take dparts (-
8780: 28 6c 65 6e 67 74 68 20 64 70 61 72 74 73 29 20 (length dparts)
8790: 31 29 29 0a 09 09 09 09 09 09 22 2f 22 29 29 29 1))......."/")))
87a0: 29 0a 09 09 20 20 20 20 20 20 20 28 64 65 62 75 )... (debu
87b0: 67 3a 70 72 69 6e 74 20 31 20 22 52 65 6d 6f 76 g:print 1 "Remov
87c0: 69 6e 67 20 72 75 6e 3a 20 22 20 72 75 6e 6b 65 ing run: " runke
87d0: 79 20 22 20 22 20 28 64 62 3a 67 65 74 2d 76 61 y " " (db:get-va
87e0: 6c 75 65 2d 62 79 2d 68 65 61 64 65 72 20 72 75 lue-by-header ru
87f0: 6e 20 68 65 61 64 65 72 20 22 72 75 6e 6e 61 6d n header "runnam
8800: 65 22 29 29 0a 09 09 20 20 20 20 20 20 20 28 64 e"))... (d
8810: 62 3a 64 65 6c 65 74 65 2d 72 75 6e 20 64 62 20 b:delete-run db
8820: 72 75 6e 2d 69 64 29 0a 09 09 20 20 20 20 20 20 run-id)...
8830: 20 3b 3b 20 6e 65 65 64 20 74 6f 20 66 69 67 75 ;; need to figu
8840: 72 65 20 6f 75 74 20 74 68 65 20 70 61 74 68 20 re out the path
8850: 74 6f 20 74 68 65 20 72 75 6e 20 64 69 72 20 61 to the run dir a
8860: 6e 64 20 72 65 6d 6f 76 65 20 69 74 20 69 66 20 nd remove it if
8870: 65 6d 70 74 79 0a 09 09 20 20 20 20 20 20 20 3b empty... ;
8880: 3b 20 20 20 20 28 69 66 20 28 6e 75 6c 6c 3f 20 ; (if (null?
8890: 28 67 6c 6f 62 20 28 63 6f 6e 63 20 72 75 6e 70 (glob (conc runp
88a0: 61 74 68 20 22 2f 2a 22 29 29 29 0a 09 09 20 20 ath "/*")))...
88b0: 20 20 20 20 20 3b 3b 20 20 20 20 20 20 20 20 28 ;; (
88c0: 62 65 67 69 6e 0a 09 09 20 20 20 20 20 20 20 3b begin... ;
88d0: 3b 20 09 20 28 64 65 62 75 67 3a 70 72 69 6e 74 ; . (debug:print
88e0: 20 31 20 22 52 65 6d 6f 76 69 6e 67 20 72 75 6e 1 "Removing run
88f0: 20 64 69 72 20 22 20 72 75 6e 70 61 74 68 29 0a dir " runpath).
8900: 09 09 20 20 20 20 20 20 20 3b 3b 20 09 20 28 73 .. ;; . (s
8910: 79 73 74 65 6d 20 28 63 6f 6e 63 20 22 72 6d 64 ystem (conc "rmd
8920: 69 72 20 2d 70 20 22 20 72 75 6e 70 61 74 68 29 ir -p " runpath)
8930: 29 29 29 0a 09 09 20 20 20 20 20 20 20 29 29 29 )))... )))
8940: 29 29 0a 09 20 29 29 0a 20 20 20 20 20 72 75 6e )).. )). run
8950: 73 29 29 29 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d s)))..;;========
8960: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8970: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8980: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8990: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b ==============.;
89a0: 3b 20 52 6f 75 74 69 6e 65 73 20 66 6f 72 20 6d ; Routines for m
89b0: 61 6e 69 70 75 6c 61 74 69 6e 67 20 72 75 6e 73 anipulating runs
89c0: 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d .;;=============
89d0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
89e0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
89f0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8a00: 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 3b 3b 20 53 69 =========..;; Si
8a10: 6e 63 65 20 6d 61 6e 79 20 63 61 6c 6c 73 20 74 nce many calls t
8a20: 6f 20 61 20 72 75 6e 20 72 65 71 75 69 72 65 20 o a run require
8a30: 70 72 65 74 74 79 20 6d 75 63 68 20 74 68 65 20 pretty much the
8a40: 73 61 6d 65 20 73 65 74 75 70 20 0a 3b 3b 20 74 same setup .;; t
8a50: 68 69 73 20 77 72 61 70 70 65 72 20 69 73 20 75 his wrapper is u
8a60: 73 65 64 20 74 6f 20 72 65 64 75 63 65 20 74 68 sed to reduce th
8a70: 65 20 72 65 70 6c 69 63 61 74 69 6f 6e 20 6f 66 e replication of
8a80: 20 63 6f 64 65 0a 28 64 65 66 69 6e 65 20 28 67 code.(define (g
8a90: 65 6e 65 72 61 6c 2d 72 75 6e 2d 63 61 6c 6c 20 eneral-run-call
8aa0: 73 77 69 74 63 68 6e 61 6d 65 20 61 63 74 69 6f switchname actio
8ab0: 6e 2d 64 65 73 63 20 70 72 6f 63 29 0a 20 20 28 n-desc proc). (
8ac0: 6c 65 74 20 28 28 72 75 6e 6e 61 6d 65 20 28 61 let ((runname (a
8ad0: 72 67 73 3a 67 65 74 2d 61 72 67 20 22 3a 72 75 rgs:get-arg ":ru
8ae0: 6e 6e 61 6d 65 22 29 29 0a 09 28 74 61 72 67 65 nname"))..(targe
8af0: 74 20 20 28 69 66 20 28 61 72 67 73 3a 67 65 74 t (if (args:get
8b00: 2d 61 72 67 20 22 2d 74 61 72 67 65 74 22 29 0a -arg "-target").
8b10: 09 09 20 20 20 20 20 28 61 72 67 73 3a 67 65 74 .. (args:get
8b20: 2d 61 72 67 20 22 2d 74 61 72 67 65 74 22 29 0a -arg "-target").
8b30: 09 09 20 20 20 20 20 28 61 72 67 73 3a 67 65 74 .. (args:get
8b40: 2d 61 72 67 20 22 2d 72 65 71 74 61 72 67 22 29 -arg "-reqtarg")
8b50: 29 29 0a 09 28 74 68 31 20 20 20 20 20 23 66 29 ))..(th1 #f)
8b60: 29 0a 20 20 20 20 28 63 6f 6e 64 0a 20 20 20 20 ). (cond.
8b70: 20 28 28 6e 6f 74 20 74 61 72 67 65 74 29 0a 20 ((not target).
8b80: 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e (debug:prin
8b90: 74 20 30 20 22 45 52 52 4f 52 3a 20 4d 69 73 73 t 0 "ERROR: Miss
8ba0: 69 6e 67 20 72 65 71 75 69 72 65 64 20 70 61 72 ing required par
8bb0: 61 6d 65 74 65 72 20 66 6f 72 20 22 20 73 77 69 ameter for " swi
8bc0: 74 63 68 6e 61 6d 65 20 22 2c 20 79 6f 75 20 6d tchname ", you m
8bd0: 75 73 74 20 73 70 65 63 69 66 79 20 74 68 65 20 ust specify the
8be0: 74 61 72 67 65 74 20 77 69 74 68 20 2d 74 61 72 target with -tar
8bf0: 67 65 74 22 29 0a 20 20 20 20 20 20 28 65 78 69 get"). (exi
8c00: 74 20 33 29 29 0a 20 20 20 20 20 28 28 6e 6f 74 t 3)). ((not
8c10: 20 72 75 6e 6e 61 6d 65 29 0a 20 20 20 20 20 20 runname).
8c20: 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 22 (debug:print 0 "
8c30: 45 52 52 4f 52 3a 20 4d 69 73 73 69 6e 67 20 72 ERROR: Missing r
8c40: 65 71 75 69 72 65 64 20 70 61 72 61 6d 65 74 65 equired paramete
8c50: 72 20 66 6f 72 20 22 20 73 77 69 74 63 68 6e 61 r for " switchna
8c60: 6d 65 20 22 2c 20 79 6f 75 20 6d 75 73 74 20 73 me ", you must s
8c70: 70 65 63 69 66 79 20 74 68 65 20 72 75 6e 20 6e pecify the run n
8c80: 61 6d 65 20 77 69 74 68 20 3a 72 75 6e 6e 61 6d ame with :runnam
8c90: 65 20 72 75 6e 6e 61 6d 65 22 29 0a 20 20 20 20 e runname").
8ca0: 20 20 28 65 78 69 74 20 33 29 29 0a 20 20 20 20 (exit 3)).
8cb0: 20 28 65 6c 73 65 0a 20 20 20 20 20 20 28 6c 65 (else. (le
8cc0: 74 20 28 28 64 62 20 20 20 23 66 29 0a 09 20 20 t ((db #f)..
8cd0: 20 20 28 6b 65 79 73 20 23 66 29 29 0a 09 28 69 (keys #f))..(i
8ce0: 66 20 28 6e 6f 74 20 28 73 65 74 75 70 2d 66 6f f (not (setup-fo
8cf0: 72 2d 72 75 6e 29 29 0a 09 20 20 20 20 28 62 65 r-run)).. (be
8d00: 67 69 6e 20 0a 09 20 20 20 20 20 20 28 64 65 62 gin .. (deb
8d10: 75 67 3a 70 72 69 6e 74 20 30 20 22 46 61 69 6c ug:print 0 "Fail
8d20: 65 64 20 74 6f 20 73 65 74 75 70 2c 20 65 78 69 ed to setup, exi
8d30: 74 69 6e 67 22 29 0a 09 20 20 20 20 20 20 28 65 ting").. (e
8d40: 78 69 74 20 31 29 29 29 0a 09 28 73 65 74 21 20 xit 1)))..(set!
8d50: 64 62 20 20 20 28 6f 70 65 6e 2d 64 62 29 29 0a db (open-db)).
8d60: 09 28 69 66 20 28 61 72 67 73 3a 67 65 74 2d 61 .(if (args:get-a
8d70: 72 67 20 22 2d 73 65 72 76 65 72 22 29 0a 09 20 rg "-server")..
8d80: 20 20 20 28 73 65 72 76 65 72 3a 73 74 61 72 74 (server:start
8d90: 20 64 62 20 28 61 72 67 73 3a 67 65 74 2d 61 72 db (args:get-ar
8da0: 67 20 22 2d 73 65 72 76 65 72 22 29 29 0a 09 20 g "-server"))..
8db0: 20 20 20 28 69 66 20 28 6e 6f 74 20 28 6f 72 20 (if (not (or
8dc0: 28 61 72 67 73 3a 67 65 74 2d 61 72 67 20 22 2d (args:get-arg "-
8dd0: 72 75 6e 61 6c 6c 22 29 0a 09 09 09 20 20 28 61 runall").... (a
8de0: 72 67 73 3a 67 65 74 2d 61 72 67 20 22 2d 72 75 rgs:get-arg "-ru
8df0: 6e 74 65 73 74 73 22 29 29 29 0a 09 09 28 73 65 ntests")))...(se
8e00: 72 76 65 72 3a 63 6c 69 65 6e 74 2d 73 65 74 75 rver:client-setu
8e10: 70 20 64 62 29 29 29 0a 09 28 73 65 74 21 20 6b p db)))..(set! k
8e20: 65 79 73 20 28 72 64 62 3a 67 65 74 2d 6b 65 79 eys (rdb:get-key
8e30: 73 20 64 62 29 29 0a 09 3b 3b 20 68 61 76 65 20 s db))..;; have
8e40: 65 6e 6f 75 67 68 20 74 6f 20 70 72 6f 63 65 73 enough to proces
8e50: 73 20 2d 74 61 72 67 65 74 20 6f 72 20 2d 72 65 s -target or -re
8e60: 71 74 61 72 67 20 68 65 72 65 0a 09 28 69 66 20 qtarg here..(if
8e70: 28 61 72 67 73 3a 67 65 74 2d 61 72 67 20 22 2d (args:get-arg "-
8e80: 72 65 71 74 61 72 67 22 29 0a 09 20 20 20 20 28 reqtarg").. (
8e90: 6c 65 74 2a 20 28 28 72 75 6e 63 6f 6e 66 69 67 let* ((runconfig
8ea0: 66 20 28 63 6f 6e 63 20 20 2a 74 6f 70 70 61 74 f (conc *toppat
8eb0: 68 2a 20 22 2f 72 75 6e 63 6f 6e 66 69 67 73 2e h* "/runconfigs.
8ec0: 63 6f 6e 66 69 67 22 29 29 20 3b 3b 20 44 4f 20 config")) ;; DO
8ed0: 4e 4f 54 20 45 56 41 4c 55 41 54 45 20 41 4c 4c NOT EVALUATE ALL
8ee0: 20 0a 09 09 20 20 20 28 72 75 6e 63 6f 6e 66 69 ... (runconfi
8ef0: 67 20 20 28 72 65 61 64 2d 63 6f 6e 66 69 67 20 g (read-config
8f00: 72 75 6e 63 6f 6e 66 69 67 66 20 23 66 20 23 66 runconfigf #f #f
8f10: 20 65 6e 76 69 72 6f 6e 2d 70 61 74 74 3a 20 23 environ-patt: #
8f20: 66 29 29 29 20 0a 09 20 20 20 20 20 20 28 69 66 f))) .. (if
8f30: 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 (hash-table-ref
8f40: 2f 64 65 66 61 75 6c 74 20 72 75 6e 63 6f 6e 66 /default runconf
8f50: 69 67 20 28 61 72 67 73 3a 67 65 74 2d 61 72 67 ig (args:get-arg
8f60: 20 22 2d 72 65 71 74 61 72 67 22 29 20 23 66 29 "-reqtarg") #f)
8f70: 0a 09 09 20 20 28 6b 65 79 73 3a 74 61 72 67 65 ... (keys:targe
8f80: 74 2d 73 65 74 2d 61 72 67 73 20 6b 65 79 73 20 t-set-args keys
8f90: 28 61 72 67 73 3a 67 65 74 2d 61 72 67 20 22 2d (args:get-arg "-
8fa0: 72 65 71 74 61 72 67 22 29 20 61 72 67 73 3a 61 reqtarg") args:a
8fb0: 72 67 2d 68 61 73 68 29 0a 09 09 20 20 28 62 65 rg-hash)... (be
8fc0: 67 69 6e 0a 09 09 20 20 20 20 28 64 65 62 75 67 gin... (debug
8fd0: 3a 70 72 69 6e 74 20 30 20 22 45 52 52 4f 52 3a :print 0 "ERROR:
8fe0: 20 5b 22 20 28 61 72 67 73 3a 67 65 74 2d 61 72 [" (args:get-ar
8ff0: 67 20 22 2d 72 65 71 74 61 72 67 22 29 20 22 5d g "-reqtarg") "]
9000: 20 6e 6f 74 20 66 6f 75 6e 64 20 69 6e 20 22 20 not found in "
9010: 72 75 6e 63 6f 6e 66 69 67 66 29 0a 09 09 20 20 runconfigf)...
9020: 20 20 28 73 71 6c 69 74 65 33 3a 66 69 6e 61 6c (sqlite3:final
9030: 69 7a 65 21 20 64 62 29 0a 09 09 20 20 20 20 28 ize! db)... (
9040: 65 78 69 74 20 31 29 29 29 29 0a 09 20 20 20 20 exit 1))))..
9050: 28 69 66 20 28 61 72 67 73 3a 67 65 74 2d 61 72 (if (args:get-ar
9060: 67 20 22 2d 74 61 72 67 65 74 22 29 0a 09 09 28 g "-target")...(
9070: 6b 65 79 73 3a 74 61 72 67 65 74 2d 73 65 74 2d keys:target-set-
9080: 61 72 67 73 20 6b 65 79 73 20 28 61 72 67 73 3a args keys (args:
9090: 67 65 74 2d 61 72 67 20 22 2d 74 61 72 67 65 74 get-arg "-target
90a0: 22 20 61 72 67 73 3a 61 72 67 2d 68 61 73 68 29 " args:arg-hash)
90b0: 20 61 72 67 73 3a 61 72 67 2d 68 61 73 68 29 29 args:arg-hash))
90c0: 29 0a 09 28 69 66 20 28 6e 6f 74 20 28 63 61 72 )..(if (not (car
90d0: 20 2a 63 6f 6e 66 69 67 69 6e 66 6f 2a 29 29 0a *configinfo*)).
90e0: 09 20 20 20 20 28 62 65 67 69 6e 0a 09 20 20 20 . (begin..
90f0: 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 (debug:print
9100: 30 20 22 45 52 52 4f 52 3a 20 41 74 74 65 6d 70 0 "ERROR: Attemp
9110: 74 65 64 20 74 6f 20 22 20 61 63 74 69 6f 6e 2d ted to " action-
9120: 64 65 73 63 20 22 20 62 75 74 20 72 75 6e 20 61 desc " but run a
9130: 72 65 61 20 63 6f 6e 66 69 67 20 66 69 6c 65 20 rea config file
9140: 6e 6f 74 20 66 6f 75 6e 64 22 29 0a 09 20 20 20 not found")..
9150: 20 20 20 28 65 78 69 74 20 31 29 29 0a 09 20 20 (exit 1))..
9160: 20 20 3b 3b 20 45 78 74 72 61 63 74 20 6f 75 74 ;; Extract out
9170: 20 73 74 75 66 66 20 6e 65 65 64 65 64 20 69 6e stuff needed in
9180: 20 6d 6f 73 74 20 6f 72 20 6d 61 6e 79 20 63 61 most or many ca
9190: 6c 6c 73 0a 09 20 20 20 20 3b 3b 20 68 65 72 65 lls.. ;; here
91a0: 20 74 68 65 6e 20 63 61 6c 6c 20 70 72 6f 63 0a then call proc.
91b0: 09 20 20 20 20 28 6c 65 74 2a 20 28 28 6b 65 79 . (let* ((key
91c0: 6e 61 6d 65 73 20 20 20 28 6d 61 70 20 6b 65 79 names (map key
91d0: 3a 67 65 74 2d 66 69 65 6c 64 6e 61 6d 65 20 6b :get-fieldname k
91e0: 65 79 73 29 29 0a 09 09 20 20 20 28 6b 65 79 76 eys))... (keyv
91f0: 61 6c 6c 73 74 20 20 28 6b 65 79 73 2d 3e 76 61 allst (keys->va
9200: 6c 6c 69 73 74 20 6b 65 79 73 20 23 74 29 29 29 llist keys #t)))
9210: 0a 09 20 20 20 20 20 20 28 70 72 6f 63 20 64 62 .. (proc db
9220: 20 74 61 72 67 65 74 20 72 75 6e 6e 61 6d 65 20 target runname
9230: 6b 65 79 73 20 6b 65 79 6e 61 6d 65 73 20 6b 65 keys keynames ke
9240: 79 76 61 6c 6c 73 74 29 29 29 0a 09 28 69 66 20 yvallst)))..(if
9250: 74 68 31 20 28 74 68 72 65 61 64 2d 6a 6f 69 6e th1 (thread-join
9260: 21 20 74 68 31 29 29 0a 09 28 73 71 6c 69 74 65 ! th1))..(sqlite
9270: 33 3a 66 69 6e 61 6c 69 7a 65 21 20 64 62 29 0a 3:finalize! db).
9280: 09 28 73 65 74 21 20 2a 64 69 64 73 6f 6d 65 74 .(set! *didsomet
9290: 68 69 6e 67 2a 20 23 74 29 29 29 29 29 29 0a 0a hing* #t))))))..
92a0: 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;;==============
92b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
92c0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
92d0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
92e0: 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 4c 6f 63 6b ========.;; Lock
92f0: 2f 75 6e 6c 6f 63 6b 20 72 75 6e 73 0a 3b 3b 3d /unlock runs.;;=
9300: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
9310: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
9320: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
9330: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
9340: 3d 3d 3d 3d 3d 0a 0a 28 64 65 66 69 6e 65 20 28 =====..(define (
9350: 72 75 6e 73 3a 68 61 6e 64 6c 65 2d 6c 6f 63 6b runs:handle-lock
9360: 69 6e 67 20 64 62 20 74 61 72 67 65 74 20 6b 65 ing db target ke
9370: 79 73 20 72 75 6e 6e 61 6d 65 20 6c 6f 63 6b 20 ys runname lock
9380: 75 6e 6c 6f 63 6b 20 75 73 65 72 29 0a 20 20 28 unlock user). (
9390: 6c 65 74 2a 20 28 28 72 75 6e 64 61 74 20 20 20 let* ((rundat
93a0: 28 72 75 6e 73 3a 67 65 74 2d 72 75 6e 73 2d 62 (runs:get-runs-b
93b0: 79 2d 70 61 74 74 20 64 62 20 6b 65 79 73 20 72 y-patt db keys r
93c0: 75 6e 6e 61 6d 65 29 29 0a 09 20 28 68 65 61 64 unname)).. (head
93d0: 65 72 20 20 20 28 76 65 63 74 6f 72 2d 72 65 66 er (vector-ref
93e0: 20 72 75 6e 64 61 74 20 30 29 29 0a 09 20 28 72 rundat 0)).. (r
93f0: 75 6e 73 20 20 20 20 20 28 76 65 63 74 6f 72 2d uns (vector-
9400: 72 65 66 20 72 75 6e 64 61 74 20 31 29 29 29 0a ref rundat 1))).
9410: 20 20 20 20 28 66 6f 72 2d 65 61 63 68 20 28 6c (for-each (l
9420: 61 6d 62 64 61 20 28 72 75 6e 29 0a 09 09 28 6c ambda (run)...(l
9430: 65 74 20 28 28 72 75 6e 2d 69 64 20 28 64 62 3a et ((run-id (db:
9440: 67 65 74 2d 76 61 6c 75 65 2d 62 79 2d 68 65 61 get-value-by-hea
9450: 64 65 72 20 72 75 6e 20 68 65 61 64 65 72 20 22 der run header "
9460: 69 64 22 29 29 29 0a 09 09 20 20 28 69 66 20 28 id")))... (if (
9470: 6f 72 20 6c 6f 63 6b 0a 09 09 09 20 20 28 61 6e or lock.... (an
9480: 64 20 75 6e 6c 6f 63 6b 0a 09 09 09 20 20 20 20 d unlock....
9490: 20 20 20 28 62 65 67 69 6e 0a 09 09 09 09 20 28 (begin..... (
94a0: 70 72 69 6e 74 20 22 44 6f 20 79 6f 75 20 72 65 print "Do you re
94b0: 61 6c 6c 79 20 77 69 73 68 20 74 6f 20 75 6e 6c ally wish to unl
94c0: 6f 63 6b 20 72 75 6e 20 22 20 72 75 6e 2d 69 64 ock run " run-id
94d0: 20 22 3f 5c 6e 20 20 20 79 2f 6e 3a 20 22 29 0a "?\n y/n: ").
94e0: 09 09 09 09 20 28 65 71 75 61 6c 3f 20 22 79 22 .... (equal? "y"
94f0: 20 28 72 65 61 64 2d 6c 69 6e 65 29 29 29 29 29 (read-line)))))
9500: 0a 09 09 20 20 20 20 20 20 28 64 62 3a 6c 6f 63 ... (db:loc
9510: 6b 2f 75 6e 6c 6f 63 6b 2d 72 75 6e 20 64 62 20 k/unlock-run db
9520: 72 75 6e 2d 69 64 20 6c 6f 63 6b 20 75 6e 6c 6f run-id lock unlo
9530: 63 6b 20 75 73 65 72 29 0a 09 09 20 20 20 20 20 ck user)...
9540: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 (debug:print 0
9550: 22 49 4e 46 4f 3a 20 53 6b 69 70 70 69 6e 67 20 "INFO: Skipping
9560: 6c 6f 63 6b 2f 75 6e 6c 6f 63 6b 20 6f 6e 20 22 lock/unlock on "
9570: 20 72 75 6e 2d 69 64 29 29 29 29 0a 09 20 20 20 run-id))))..
9580: 20 20 20 72 75 6e 73 29 29 29 0a 3b 3b 3d 3d 3d runs))).;;===
9590: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
95a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
95b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
95c0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
95d0: 3d 3d 3d 0a 3b 3b 20 52 6f 6c 6c 75 70 20 72 75 ===.;; Rollup ru
95e0: 6e 73 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ns.;;===========
95f0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
9600: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
9610: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
9620: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 3b 3b 20 ===========..;;
9630: 55 70 64 61 74 65 20 74 68 65 20 74 65 73 74 5f Update the test_
9640: 6d 65 74 61 20 74 61 62 6c 65 20 66 6f 72 20 74 meta table for t
9650: 68 69 73 20 74 65 73 74 0a 28 64 65 66 69 6e 65 his test.(define
9660: 20 28 72 75 6e 73 3a 75 70 64 61 74 65 2d 74 65 (runs:update-te
9670: 73 74 5f 6d 65 74 61 20 64 62 20 74 65 73 74 2d st_meta db test-
9680: 6e 61 6d 65 20 74 65 73 74 2d 63 6f 6e 66 29 0a name test-conf).
9690: 20 20 28 6c 65 74 20 28 28 63 75 72 72 72 65 63 (let ((currrec
96a0: 6f 72 64 20 28 64 62 3a 74 65 73 74 6d 65 74 61 ord (db:testmeta
96b0: 2d 67 65 74 2d 72 65 63 6f 72 64 20 64 62 20 74 -get-record db t
96c0: 65 73 74 2d 6e 61 6d 65 29 29 29 0a 20 20 20 20 est-name))).
96d0: 28 69 66 20 28 6e 6f 74 20 63 75 72 72 72 65 63 (if (not currrec
96e0: 6f 72 64 29 0a 09 28 62 65 67 69 6e 0a 09 20 20 ord)..(begin..
96f0: 28 73 65 74 21 20 63 75 72 72 72 65 63 6f 72 64 (set! currrecord
9700: 20 28 6d 61 6b 65 2d 76 65 63 74 6f 72 20 31 30 (make-vector 10
9710: 20 23 66 29 29 0a 09 20 20 28 64 62 3a 74 65 73 #f)).. (db:tes
9720: 74 6d 65 74 61 2d 61 64 64 2d 72 65 63 6f 72 64 tmeta-add-record
9730: 20 64 62 20 74 65 73 74 2d 6e 61 6d 65 29 29 29 db test-name)))
9740: 0a 20 20 20 20 28 66 6f 72 2d 65 61 63 68 20 0a . (for-each .
9750: 20 20 20 20 20 28 6c 61 6d 62 64 61 20 28 6b 65 (lambda (ke
9760: 79 29 0a 20 20 20 20 20 20 20 28 6c 65 74 2a 20 y). (let*
9770: 28 28 69 64 78 20 28 63 61 64 72 20 6b 65 79 29 ((idx (cadr key)
9780: 29 0a 09 20 20 20 20 20 20 28 66 6c 64 20 28 63 ).. (fld (c
9790: 61 72 20 20 6b 65 79 29 29 0a 09 20 20 20 20 20 ar key))..
97a0: 20 28 76 61 6c 20 28 63 6f 6e 66 69 67 2d 6c 6f (val (config-lo
97b0: 6f 6b 75 70 20 74 65 73 74 2d 63 6f 6e 66 20 22 okup test-conf "
97c0: 74 65 73 74 5f 6d 65 74 61 22 20 66 6c 64 29 29 test_meta" fld))
97d0: 29 0a 09 20 3b 3b 20 28 64 65 62 75 67 3a 70 72 ).. ;; (debug:pr
97e0: 69 6e 74 20 35 20 22 69 64 78 3a 20 22 20 69 64 int 5 "idx: " id
97f0: 78 20 22 20 66 6c 64 3a 20 22 20 66 6c 64 20 22 x " fld: " fld "
9800: 20 76 61 6c 3a 20 22 20 76 61 6c 29 0a 09 20 28 val: " val).. (
9810: 69 66 20 28 61 6e 64 20 76 61 6c 20 28 6e 6f 74 if (and val (not
9820: 20 28 65 71 75 61 6c 3f 20 28 76 65 63 74 6f 72 (equal? (vector
9830: 2d 72 65 66 20 63 75 72 72 72 65 63 6f 72 64 20 -ref currrecord
9840: 69 64 78 29 20 76 61 6c 29 29 29 0a 09 20 20 20 idx) val)))..
9850: 20 20 28 62 65 67 69 6e 0a 09 20 20 20 20 20 20 (begin..
9860: 20 28 70 72 69 6e 74 20 22 55 70 64 61 74 69 6e (print "Updatin
9870: 67 20 22 20 74 65 73 74 2d 6e 61 6d 65 20 22 20 g " test-name "
9880: 22 20 66 6c 64 20 22 20 74 6f 20 22 20 76 61 6c " fld " to " val
9890: 29 0a 09 20 20 20 20 20 20 20 28 64 62 3a 74 65 ).. (db:te
98a0: 73 74 6d 65 74 61 2d 75 70 64 61 74 65 2d 66 69 stmeta-update-fi
98b0: 65 6c 64 20 64 62 20 74 65 73 74 2d 6e 61 6d 65 eld db test-name
98c0: 20 66 6c 64 20 76 61 6c 29 29 29 29 29 0a 20 20 fld val))))).
98d0: 20 20 20 27 28 28 22 61 75 74 68 6f 72 22 20 32 '(("author" 2
98e0: 29 28 22 6f 77 6e 65 72 22 20 33 29 28 22 64 65 )("owner" 3)("de
98f0: 73 63 72 69 70 74 69 6f 6e 22 20 34 29 28 22 72 scription" 4)("r
9900: 65 76 69 65 77 65 64 22 20 35 29 28 22 74 61 67 eviewed" 5)("tag
9910: 73 22 20 39 29 29 29 29 29 0a 0a 3b 3b 20 55 70 s" 9)))))..;; Up
9920: 64 61 74 65 20 74 65 73 74 5f 6d 65 74 61 20 66 date test_meta f
9930: 6f 72 20 61 6c 6c 20 74 65 73 74 73 0a 28 64 65 or all tests.(de
9940: 66 69 6e 65 20 28 72 75 6e 73 3a 75 70 64 61 74 fine (runs:updat
9950: 65 2d 61 6c 6c 2d 74 65 73 74 5f 6d 65 74 61 20 e-all-test_meta
9960: 64 62 29 0a 20 20 28 6c 65 74 20 28 28 74 65 73 db). (let ((tes
9970: 74 2d 6e 61 6d 65 73 20 28 67 65 74 2d 61 6c 6c t-names (get-all
9980: 2d 6c 65 67 61 6c 2d 74 65 73 74 73 29 29 29 0a -legal-tests))).
9990: 20 20 20 20 28 66 6f 72 2d 65 61 63 68 20 0a 20 (for-each .
99a0: 20 20 20 20 28 6c 61 6d 62 64 61 20 28 74 65 73 (lambda (tes
99b0: 74 2d 6e 61 6d 65 29 0a 20 20 20 20 20 20 20 28 t-name). (
99c0: 6c 65 74 2a 20 28 28 74 65 73 74 2d 70 61 74 68 let* ((test-path
99d0: 20 20 20 20 28 63 6f 6e 63 20 2a 74 6f 70 70 61 (conc *toppa
99e0: 74 68 2a 20 22 2f 74 65 73 74 73 2f 22 20 74 65 th* "/tests/" te
99f0: 73 74 2d 6e 61 6d 65 29 29 0a 09 20 20 20 20 20 st-name))..
9a00: 20 28 74 65 73 74 2d 63 6f 6e 66 69 67 66 20 28 (test-configf (
9a10: 63 6f 6e 63 20 74 65 73 74 2d 70 61 74 68 20 22 conc test-path "
9a20: 2f 74 65 73 74 63 6f 6e 66 69 67 22 29 29 0a 09 /testconfig"))..
9a30: 20 20 20 20 20 20 28 74 65 73 74 65 78 69 73 74 (testexist
9a40: 73 20 20 20 28 61 6e 64 20 28 66 69 6c 65 2d 65 s (and (file-e
9a50: 78 69 73 74 73 3f 20 74 65 73 74 2d 63 6f 6e 66 xists? test-conf
9a60: 69 67 66 29 28 66 69 6c 65 2d 72 65 61 64 2d 61 igf)(file-read-a
9a70: 63 63 65 73 73 3f 20 74 65 73 74 2d 63 6f 6e 66 ccess? test-conf
9a80: 69 67 66 29 29 29 0a 09 20 20 20 20 20 20 3b 3b igf))).. ;;
9a90: 20 72 65 61 64 20 63 6f 6e 66 69 67 73 20 77 69 read configs wi
9aa0: 74 68 20 74 72 69 63 6b 73 20 74 75 72 6e 65 64 th tricks turned
9ab0: 20 6f 66 66 20 28 69 2e 65 2e 20 6e 6f 20 73 79 off (i.e. no sy
9ac0: 73 74 65 6d 29 0a 09 20 20 20 20 20 20 28 74 65 stem).. (te
9ad0: 73 74 2d 63 6f 6e 66 20 20 20 20 28 69 66 20 74 st-conf (if t
9ae0: 65 73 74 65 78 69 73 74 73 20 28 72 65 61 64 2d estexists (read-
9af0: 63 6f 6e 66 69 67 20 74 65 73 74 2d 63 6f 6e 66 config test-conf
9b00: 69 67 66 20 23 66 20 23 66 29 28 6d 61 6b 65 2d igf #f #f)(make-
9b10: 68 61 73 68 2d 74 61 62 6c 65 29 29 29 29 0a 09 hash-table))))..
9b20: 20 28 72 75 6e 73 3a 75 70 64 61 74 65 2d 74 65 (runs:update-te
9b30: 73 74 5f 6d 65 74 61 20 64 62 20 74 65 73 74 2d st_meta db test-
9b40: 6e 61 6d 65 20 74 65 73 74 2d 63 6f 6e 66 29 29 name test-conf))
9b50: 29 0a 20 20 20 20 20 74 65 73 74 2d 6e 61 6d 65 ). test-name
9b60: 73 29 29 29 0a 0a 3b 3b 20 54 68 69 73 20 63 6f s)))..;; This co
9b70: 75 6c 64 20 70 72 6f 62 61 62 6c 79 20 62 65 20 uld probably be
9b80: 72 65 66 61 63 74 6f 72 65 64 20 69 6e 74 6f 20 refactored into
9b90: 6f 6e 65 20 63 6f 6d 70 6c 65 78 20 71 75 65 72 one complex quer
9ba0: 79 20 2e 2e 2e 0a 28 64 65 66 69 6e 65 20 28 72 y ....(define (r
9bb0: 75 6e 73 3a 72 6f 6c 6c 75 70 2d 72 75 6e 20 64 uns:rollup-run d
9bc0: 62 20 6b 65 79 73 20 6b 65 79 76 61 6c 6c 73 74 b keys keyvallst
9bd0: 20 72 75 6e 6e 61 6d 65 20 75 73 65 72 29 20 3b runname user) ;
9be0: 3b 20 77 61 73 20 74 61 72 67 65 74 2c 20 6e 6f ; was target, no
9bf0: 77 20 6b 65 79 76 61 6c 6c 73 74 0a 20 20 28 64 w keyvallst. (d
9c00: 65 62 75 67 3a 70 72 69 6e 74 20 34 20 22 72 75 ebug:print 4 "ru
9c10: 6e 73 3a 72 6f 6c 6c 75 70 2d 72 75 6e 2c 20 6b ns:rollup-run, k
9c20: 65 79 73 3a 20 22 20 6b 65 79 73 20 22 20 6b 65 eys: " keys " ke
9c30: 79 76 61 6c 6c 73 74 3a 20 22 20 6b 65 79 76 61 yvallst: " keyva
9c40: 6c 6c 73 74 20 22 20 3a 72 75 6e 6e 61 6d 65 20 llst " :runname
9c50: 22 20 72 75 6e 6e 61 6d 65 20 22 20 75 73 65 72 " runname " user
9c60: 3a 20 22 20 75 73 65 72 29 0a 20 20 28 6c 65 74 : " user). (let
9c70: 2a 20 28 3b 20 28 6b 65 79 76 61 6c 6c 6c 73 74 * (; (keyvalllst
9c80: 20 20 20 20 20 20 28 6b 65 79 73 3a 74 61 72 67 (keys:targ
9c90: 65 74 2d 3e 6b 65 79 76 61 6c 20 6b 65 79 73 20 et->keyval keys
9ca0: 74 61 72 67 65 74 29 29 0a 09 20 28 6e 65 77 2d target)).. (new-
9cb0: 72 75 6e 2d 69 64 20 20 20 20 20 20 28 72 75 6e run-id (run
9cc0: 73 3a 72 65 67 69 73 74 65 72 2d 72 75 6e 20 64 s:register-run d
9cd0: 62 20 6b 65 79 73 20 6b 65 79 76 61 6c 6c 73 74 b keys keyvallst
9ce0: 20 72 75 6e 6e 61 6d 65 20 22 6e 65 77 22 20 22 runname "new" "
9cf0: 6e 2f 61 22 20 75 73 65 72 29 29 0a 09 20 28 70 n/a" user)).. (p
9d00: 72 65 76 2d 74 65 73 74 73 20 20 20 20 20 20 28 rev-tests (
9d10: 74 65 73 74 3a 67 65 74 2d 6d 61 74 63 68 69 6e test:get-matchin
9d20: 67 2d 70 72 65 76 69 6f 75 73 2d 74 65 73 74 2d g-previous-test-
9d30: 72 75 6e 2d 72 65 63 6f 72 64 73 20 64 62 20 6e run-records db n
9d40: 65 77 2d 72 75 6e 2d 69 64 20 22 25 22 20 22 25 ew-run-id "%" "%
9d50: 22 29 29 0a 09 20 28 63 75 72 72 2d 74 65 73 74 ")).. (curr-test
9d60: 73 20 20 20 20 20 20 28 72 64 62 3a 67 65 74 2d s (rdb:get-
9d70: 74 65 73 74 73 2d 66 6f 72 2d 72 75 6e 20 64 62 tests-for-run db
9d80: 20 6e 65 77 2d 72 75 6e 2d 69 64 20 22 25 22 20 new-run-id "%"
9d90: 22 25 22 20 27 28 29 20 27 28 29 29 29 0a 09 20 "%" '() '()))..
9da0: 28 63 75 72 72 2d 74 65 73 74 73 2d 68 61 73 68 (curr-tests-hash
9db0: 20 28 6d 61 6b 65 2d 68 61 73 68 2d 74 61 62 6c (make-hash-tabl
9dc0: 65 29 29 29 0a 20 20 20 20 28 64 62 3a 75 70 64 e))). (db:upd
9dd0: 61 74 65 2d 72 75 6e 2d 65 76 65 6e 74 5f 74 69 ate-run-event_ti
9de0: 6d 65 20 64 62 20 6e 65 77 2d 72 75 6e 2d 69 64 me db new-run-id
9df0: 29 0a 20 20 20 20 3b 3b 20 69 6e 64 65 78 20 74 ). ;; index t
9e00: 68 65 20 61 6c 72 65 61 64 79 20 73 61 76 65 64 he already saved
9e10: 20 74 65 73 74 73 20 62 79 20 74 65 73 74 6e 61 tests by testna
9e20: 6d 65 20 61 6e 64 20 69 74 65 6d 64 61 74 20 69 me and itemdat i
9e30: 6e 20 63 75 72 72 2d 74 65 73 74 73 2d 68 61 73 n curr-tests-has
9e40: 68 0a 20 20 20 20 28 66 6f 72 2d 65 61 63 68 0a h. (for-each.
9e50: 20 20 20 20 20 28 6c 61 6d 62 64 61 20 28 74 65 (lambda (te
9e60: 73 74 64 61 74 29 0a 20 20 20 20 20 20 20 28 6c stdat). (l
9e70: 65 74 2a 20 28 28 74 65 73 74 6e 61 6d 65 20 20 et* ((testname
9e80: 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 74 65 73 (db:test-get-tes
9e90: 74 6e 61 6d 65 20 74 65 73 74 64 61 74 29 29 0a tname testdat)).
9ea0: 09 20 20 20 20 20 20 28 69 74 65 6d 2d 70 61 74 . (item-pat
9eb0: 68 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 69 h (db:test-get-i
9ec0: 74 65 6d 2d 70 61 74 68 20 74 65 73 74 64 61 74 tem-path testdat
9ed0: 29 29 0a 09 20 20 20 20 20 20 28 66 75 6c 6c 2d )).. (full-
9ee0: 6e 61 6d 65 20 28 63 6f 6e 63 20 74 65 73 74 6e name (conc testn
9ef0: 61 6d 65 20 22 2f 22 20 69 74 65 6d 2d 70 61 74 ame "/" item-pat
9f00: 68 29 29 29 0a 09 20 28 68 61 73 68 2d 74 61 62 h))).. (hash-tab
9f10: 6c 65 2d 73 65 74 21 20 63 75 72 72 2d 74 65 73 le-set! curr-tes
9f20: 74 73 2d 68 61 73 68 20 66 75 6c 6c 2d 6e 61 6d ts-hash full-nam
9f30: 65 20 74 65 73 74 64 61 74 29 29 29 0a 20 20 20 e testdat))).
9f40: 20 20 63 75 72 72 2d 74 65 73 74 73 29 0a 20 20 curr-tests).
9f50: 20 20 3b 3b 20 4e 4f 50 45 3a 20 4e 6f 6e 2d 6f ;; NOPE: Non-o
9f60: 70 74 69 6d 61 6c 20 61 70 70 72 6f 61 63 68 2e ptimal approach.
9f70: 20 54 72 79 20 74 68 69 73 20 69 6e 73 74 65 61 Try this instea
9f80: 64 2e 0a 20 20 20 20 3b 3b 20 20 20 31 2e 20 74 d.. ;; 1. t
9f90: 65 73 74 73 20 61 72 65 20 72 65 63 65 69 76 65 ests are receive
9fa0: 64 20 69 6e 20 61 20 6c 69 73 74 2c 20 6d 6f 73 d in a list, mos
9fb0: 74 20 72 65 63 65 6e 74 20 66 69 72 73 74 0a 20 t recent first.
9fc0: 20 20 20 3b 3b 20 20 20 32 2e 20 72 65 70 6c 61 ;; 2. repla
9fd0: 63 65 20 74 68 65 20 72 6f 6c 6c 75 70 20 74 65 ce the rollup te
9fe0: 73 74 20 77 69 74 68 20 74 68 65 20 6e 65 77 20 st with the new
9ff0: 2a 61 6c 77 61 79 73 2a 0a 20 20 20 20 28 66 6f *always*. (fo
a000: 72 2d 65 61 63 68 20 0a 20 20 20 20 20 28 6c 61 r-each . (la
a010: 6d 62 64 61 20 28 74 65 73 74 64 61 74 29 0a 20 mbda (testdat).
a020: 20 20 20 20 20 20 28 6c 65 74 2a 20 28 28 74 65 (let* ((te
a030: 73 74 6e 61 6d 65 20 20 28 64 62 3a 74 65 73 74 stname (db:test
a040: 2d 67 65 74 2d 74 65 73 74 6e 61 6d 65 20 74 65 -get-testname te
a050: 73 74 64 61 74 29 29 0a 09 20 20 20 20 20 20 28 stdat)).. (
a060: 69 74 65 6d 2d 70 61 74 68 20 28 64 62 3a 74 65 item-path (db:te
a070: 73 74 2d 67 65 74 2d 69 74 65 6d 2d 70 61 74 68 st-get-item-path
a080: 20 74 65 73 74 64 61 74 29 29 0a 09 20 20 20 20 testdat))..
a090: 20 20 28 66 75 6c 6c 2d 6e 61 6d 65 20 28 63 6f (full-name (co
a0a0: 6e 63 20 74 65 73 74 6e 61 6d 65 20 22 2f 22 20 nc testname "/"
a0b0: 69 74 65 6d 2d 70 61 74 68 29 29 0a 09 20 20 20 item-path))..
a0c0: 20 20 20 28 70 72 65 76 2d 74 65 73 74 2d 64 61 (prev-test-da
a0d0: 74 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 t (hash-table-re
a0e0: 66 2f 64 65 66 61 75 6c 74 20 63 75 72 72 2d 74 f/default curr-t
a0f0: 65 73 74 73 2d 68 61 73 68 20 66 75 6c 6c 2d 6e ests-hash full-n
a100: 61 6d 65 20 23 66 29 29 0a 09 20 20 20 20 20 20 ame #f))..
a110: 28 74 65 73 74 2d 73 74 65 70 73 20 20 20 20 20 (test-steps
a120: 20 28 64 62 3a 67 65 74 2d 73 74 65 70 73 2d 66 (db:get-steps-f
a130: 6f 72 2d 74 65 73 74 20 64 62 20 28 64 62 3a 74 or-test db (db:t
a140: 65 73 74 2d 67 65 74 2d 69 64 20 74 65 73 74 64 est-get-id testd
a150: 61 74 29 29 29 0a 09 20 20 20 20 20 20 28 6e 65 at))).. (ne
a160: 77 2d 74 65 73 74 2d 72 65 63 6f 72 64 20 23 66 w-test-record #f
a170: 29 29 0a 09 20 3b 3b 20 72 65 70 6c 61 63 65 20 )).. ;; replace
a180: 74 68 65 73 65 20 77 69 74 68 20 69 6e 73 65 72 these with inser
a190: 74 20 2e 2e 2e 20 73 65 6c 65 63 74 0a 09 20 28 t ... select.. (
a1a0: 61 70 70 6c 79 20 73 71 6c 69 74 65 33 3a 65 78 apply sqlite3:ex
a1b0: 65 63 75 74 65 20 0a 09 09 64 62 20 0a 09 09 28 ecute ...db ...(
a1c0: 63 6f 6e 63 20 22 49 4e 53 45 52 54 20 4f 52 20 conc "INSERT OR
a1d0: 52 45 50 4c 41 43 45 20 49 4e 54 4f 20 74 65 73 REPLACE INTO tes
a1e0: 74 73 20 28 72 75 6e 5f 69 64 2c 74 65 73 74 6e ts (run_id,testn
a1f0: 61 6d 65 2c 73 74 61 74 65 2c 73 74 61 74 75 73 ame,state,status
a200: 2c 65 76 65 6e 74 5f 74 69 6d 65 2c 68 6f 73 74 ,event_time,host
a210: 2c 63 70 75 6c 6f 61 64 2c 64 69 73 6b 66 72 65 ,cpuload,diskfre
a220: 65 2c 75 6e 61 6d 65 2c 72 75 6e 64 69 72 2c 69 e,uname,rundir,i
a230: 74 65 6d 5f 70 61 74 68 2c 72 75 6e 5f 64 75 72 tem_path,run_dur
a240: 61 74 69 6f 6e 2c 66 69 6e 61 6c 5f 6c 6f 67 66 ation,final_logf
a250: 2c 63 6f 6d 6d 65 6e 74 29 20 22 0a 09 09 20 20 ,comment) "...
a260: 20 20 20 20 22 56 41 4c 55 45 53 20 28 3f 2c 3f "VALUES (?,?
a270: 2c 3f 2c 3f 2c 3f 2c 3f 2c 3f 2c 3f 2c 3f 2c 3f ,?,?,?,?,?,?,?,?
a280: 2c 3f 2c 3f 2c 3f 2c 3f 29 3b 22 29 0a 09 09 6e ,?,?,?,?);")...n
a290: 65 77 2d 72 75 6e 2d 69 64 20 28 63 64 64 72 20 ew-run-id (cddr
a2a0: 28 76 65 63 74 6f 72 2d 3e 6c 69 73 74 20 74 65 (vector->list te
a2b0: 73 74 64 61 74 29 29 29 0a 09 20 28 73 65 74 21 stdat))).. (set!
a2c0: 20 6e 65 77 2d 74 65 73 74 64 61 74 20 28 63 61 new-testdat (ca
a2d0: 72 20 28 72 64 62 3a 67 65 74 2d 74 65 73 74 73 r (rdb:get-tests
a2e0: 2d 66 6f 72 2d 72 75 6e 20 64 62 20 6e 65 77 2d -for-run db new-
a2f0: 72 75 6e 2d 69 64 20 74 65 73 74 6e 61 6d 65 20 run-id testname
a300: 69 74 65 6d 2d 70 61 74 68 20 27 28 29 20 27 28 item-path '() '(
a310: 29 29 29 29 0a 09 20 28 68 61 73 68 2d 74 61 62 )))).. (hash-tab
a320: 6c 65 2d 73 65 74 21 20 63 75 72 72 2d 74 65 73 le-set! curr-tes
a330: 74 73 2d 68 61 73 68 20 66 75 6c 6c 2d 6e 61 6d ts-hash full-nam
a340: 65 20 6e 65 77 2d 74 65 73 74 64 61 74 29 20 3b e new-testdat) ;
a350: 3b 20 74 68 69 73 20 63 6f 75 6c 64 20 62 65 20 ; this could be
a360: 63 6f 6e 66 75 73 69 6e 67 2c 20 77 68 69 63 68 confusing, which
a370: 20 72 65 63 6f 72 64 20 73 68 6f 75 6c 64 20 67 record should g
a380: 6f 20 69 6e 74 6f 20 74 68 65 20 6c 6f 6f 6b 75 o into the looku
a390: 70 20 74 61 62 6c 65 3f 0a 09 20 3b 3b 20 4e 6f p table?.. ;; No
a3a0: 77 20 64 75 70 6c 69 63 61 74 65 20 74 68 65 20 w duplicate the
a3b0: 74 65 73 74 20 73 74 65 70 73 0a 09 20 28 64 65 test steps.. (de
a3c0: 62 75 67 3a 70 72 69 6e 74 20 34 20 22 43 6f 70 bug:print 4 "Cop
a3d0: 79 69 6e 67 20 72 65 63 6f 72 64 73 20 69 6e 20 ying records in
a3e0: 74 65 73 74 5f 73 74 65 70 73 20 66 72 6f 6d 20 test_steps from
a3f0: 74 65 73 74 5f 69 64 3d 22 20 28 64 62 3a 74 65 test_id=" (db:te
a400: 73 74 2d 67 65 74 2d 69 64 20 74 65 73 74 64 61 st-get-id testda
a410: 74 29 20 22 20 74 6f 20 22 20 28 64 62 3a 74 65 t) " to " (db:te
a420: 73 74 2d 67 65 74 2d 69 64 20 6e 65 77 2d 74 65 st-get-id new-te
a430: 73 74 64 61 74 29 29 0a 09 20 28 73 71 6c 69 74 stdat)).. (sqlit
a440: 65 33 3a 65 78 65 63 75 74 65 20 0a 09 20 20 64 e3:execute .. d
a450: 62 20 0a 09 20 20 28 63 6f 6e 63 20 22 49 4e 53 b .. (conc "INS
a460: 45 52 54 20 4f 52 20 52 45 50 4c 41 43 45 20 49 ERT OR REPLACE I
a470: 4e 54 4f 20 74 65 73 74 5f 73 74 65 70 73 20 28 NTO test_steps (
a480: 74 65 73 74 5f 69 64 2c 73 74 65 70 6e 61 6d 65 test_id,stepname
a490: 2c 73 74 61 74 65 2c 73 74 61 74 75 73 2c 65 76 ,state,status,ev
a4a0: 65 6e 74 5f 74 69 6d 65 2c 63 6f 6d 6d 65 6e 74 ent_time,comment
a4b0: 29 20 22 0a 09 09 22 53 45 4c 45 43 54 20 22 20 ) "..."SELECT "
a4c0: 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 69 64 20 (db:test-get-id
a4d0: 6e 65 77 2d 74 65 73 74 64 61 74 29 20 22 2c 73 new-testdat) ",s
a4e0: 74 65 70 6e 61 6d 65 2c 73 74 61 74 65 2c 73 74 tepname,state,st
a4f0: 61 74 75 73 2c 65 76 65 6e 74 5f 74 69 6d 65 2c atus,event_time,
a500: 63 6f 6d 6d 65 6e 74 20 46 52 4f 4d 20 74 65 73 comment FROM tes
a510: 74 5f 73 74 65 70 73 20 57 48 45 52 45 20 74 65 t_steps WHERE te
a520: 73 74 5f 69 64 3d 3f 3b 22 29 0a 09 20 20 28 64 st_id=?;").. (d
a530: 62 3a 74 65 73 74 2d 67 65 74 2d 69 64 20 74 65 b:test-get-id te
a540: 73 74 64 61 74 29 29 0a 09 20 3b 3b 20 4e 6f 77 stdat)).. ;; Now
a550: 20 64 75 70 6c 69 63 61 74 65 20 74 68 65 20 74 duplicate the t
a560: 65 73 74 20 64 61 74 61 0a 09 20 28 64 65 62 75 est data.. (debu
a570: 67 3a 70 72 69 6e 74 20 34 20 22 43 6f 70 79 69 g:print 4 "Copyi
a580: 6e 67 20 72 65 63 6f 72 64 73 20 69 6e 20 74 65 ng records in te
a590: 73 74 5f 64 61 74 61 20 66 72 6f 6d 20 74 65 73 st_data from tes
a5a0: 74 5f 69 64 3d 22 20 28 64 62 3a 74 65 73 74 2d t_id=" (db:test-
a5b0: 67 65 74 2d 69 64 20 74 65 73 74 64 61 74 29 20 get-id testdat)
a5c0: 22 20 74 6f 20 22 20 28 64 62 3a 74 65 73 74 2d " to " (db:test-
a5d0: 67 65 74 2d 69 64 20 6e 65 77 2d 74 65 73 74 64 get-id new-testd
a5e0: 61 74 29 29 0a 09 20 28 73 71 6c 69 74 65 33 3a at)).. (sqlite3:
a5f0: 65 78 65 63 75 74 65 20 0a 09 20 20 64 62 20 0a execute .. db .
a600: 09 20 20 28 63 6f 6e 63 20 22 49 4e 53 45 52 54 . (conc "INSERT
a610: 20 4f 52 20 52 45 50 4c 41 43 45 20 49 4e 54 4f OR REPLACE INTO
a620: 20 74 65 73 74 5f 64 61 74 61 20 28 74 65 73 74 test_data (test
a630: 5f 69 64 2c 63 61 74 65 67 6f 72 79 2c 76 61 72 _id,category,var
a640: 69 61 62 6c 65 2c 76 61 6c 75 65 2c 65 78 70 65 iable,value,expe
a650: 63 74 65 64 2c 74 6f 6c 2c 75 6e 69 74 73 2c 63 cted,tol,units,c
a660: 6f 6d 6d 65 6e 74 29 20 22 0a 09 09 22 53 45 4c omment) "..."SEL
a670: 45 43 54 20 22 20 28 64 62 3a 74 65 73 74 2d 67 ECT " (db:test-g
a680: 65 74 2d 69 64 20 6e 65 77 2d 74 65 73 74 64 61 et-id new-testda
a690: 74 29 20 22 2c 63 61 74 65 67 6f 72 79 2c 76 61 t) ",category,va
a6a0: 72 69 61 62 6c 65 2c 76 61 6c 75 65 2c 65 78 70 riable,value,exp
a6b0: 65 63 74 65 64 2c 74 6f 6c 2c 75 6e 69 74 73 2c ected,tol,units,
a6c0: 63 6f 6d 6d 65 6e 74 20 46 52 4f 4d 20 74 65 73 comment FROM tes
a6d0: 74 5f 64 61 74 61 20 57 48 45 52 45 20 74 65 73 t_data WHERE tes
a6e0: 74 5f 69 64 3d 3f 3b 22 29 0a 09 20 20 28 64 62 t_id=?;").. (db
a6f0: 3a 74 65 73 74 2d 67 65 74 2d 69 64 20 74 65 73 :test-get-id tes
a700: 74 64 61 74 29 29 0a 09 20 29 29 0a 20 20 20 20 tdat)).. )).
a710: 20 70 72 65 76 2d 74 65 73 74 73 29 29 29 0a 09 prev-tests)))..
a720: 20 0a 20 20 20 20 20 0a . .