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 32 2c 20 4d 61 74 74 68 65 77 06-2012, 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: 29 20 3b 3b 20 74 65 73 74 2d 6e 61 6d 65 29 0a ) ;; test-name).
0460: 20 20 28 6c 65 74 2a 20 28 28 6b 65 79 76 61 6c (let* ((keyval
0470: 6c 73 74 20 28 6b 65 79 73 2d 3e 76 61 6c 6c 69 lst (keys->valli
0480: 73 74 20 6b 65 79 73 29 29 0a 09 20 28 74 6d 70 st keys)).. (tmp
0490: 20 20 20 20 20 20 28 72 75 6e 73 3a 67 65 74 2d (runs:get-
04a0: 73 74 64 2d 72 75 6e 2d 66 69 65 6c 64 73 20 6b std-run-fields k
04b0: 65 79 73 20 27 28 22 69 64 22 20 22 72 75 6e 6e eys '("id" "runn
04c0: 61 6d 65 22 20 22 73 74 61 74 65 22 20 22 73 74 ame" "state" "st
04d0: 61 74 75 73 22 20 22 6f 77 6e 65 72 22 20 22 65 atus" "owner" "e
04e0: 76 65 6e 74 5f 74 69 6d 65 22 29 29 29 0a 09 20 vent_time")))..
04f0: 28 6b 65 79 73 74 72 20 20 20 28 63 61 72 20 74 (keystr (car t
0500: 6d 70 29 29 0a 09 20 28 68 65 61 64 65 72 20 20 mp)).. (header
0510: 20 28 63 61 64 72 20 74 6d 70 29 29 0a 09 20 28 (cadr tmp)).. (
0520: 72 65 73 20 20 20 20 20 27 28 29 29 0a 09 20 28 res '()).. (
0530: 6b 65 79 2d 70 61 74 74 20 22 22 29 0a 09 20 28 key-patt "").. (
0540: 72 75 6e 77 69 6c 64 74 79 70 65 20 28 69 66 20 runwildtype (if
0550: 28 73 75 62 73 74 72 69 6e 67 2d 69 6e 64 65 78 (substring-index
0560: 20 22 25 22 20 72 75 6e 6e 61 6d 65 70 61 74 74 "%" runnamepatt
0570: 29 20 22 6c 69 6b 65 22 20 22 67 6c 6f 62 22 29 ) "like" "glob")
0580: 29 0a 09 20 28 71 72 79 2d 73 74 72 20 20 23 66 ).. (qry-str #f
0590: 29 29 0a 20 20 20 20 28 66 6f 72 2d 65 61 63 68 )). (for-each
05a0: 20 28 6c 61 6d 62 64 61 20 28 6b 65 79 76 61 6c (lambda (keyval
05b0: 29 0a 09 09 28 6c 65 74 2a 20 28 28 6b 65 79 20 )...(let* ((key
05c0: 20 20 20 28 76 65 63 74 6f 72 2d 72 65 66 20 6b (vector-ref k
05d0: 65 79 76 61 6c 20 30 29 29 0a 09 09 20 20 20 20 eyval 0))...
05e0: 20 20 20 28 66 75 6c 6b 65 79 20 28 63 6f 6e 63 (fulkey (conc
05f0: 20 22 3a 22 20 6b 65 79 29 29 0a 09 09 20 20 20 ":" key))...
0600: 20 20 20 20 28 70 61 74 74 20 20 20 28 61 72 67 (patt (arg
0610: 73 3a 67 65 74 2d 61 72 67 20 66 75 6c 6b 65 79 s:get-arg fulkey
0620: 29 29 0a 09 09 20 20 20 20 20 20 20 28 77 69 6c ))... (wil
0630: 64 74 79 70 65 20 28 69 66 20 28 73 75 62 73 74 dtype (if (subst
0640: 72 69 6e 67 2d 69 6e 64 65 78 20 22 25 22 20 70 ring-index "%" p
0650: 61 74 74 29 20 22 6c 69 6b 65 22 20 22 67 6c 6f att) "like" "glo
0660: 62 22 29 29 29 0a 09 09 20 20 28 69 66 20 70 61 b")))... (if pa
0670: 74 74 0a 09 09 20 20 20 20 20 20 28 73 65 74 21 tt... (set!
0680: 20 6b 65 79 2d 70 61 74 74 20 28 63 6f 6e 63 20 key-patt (conc
0690: 6b 65 79 2d 70 61 74 74 20 22 20 41 4e 44 20 22 key-patt " AND "
06a0: 20 6b 65 79 20 22 20 22 20 77 69 6c 64 74 79 70 key " " wildtyp
06b0: 65 20 22 20 27 22 20 70 61 74 74 20 22 27 22 29 e " '" patt "'")
06c0: 29 0a 09 09 20 20 20 20 20 20 28 62 65 67 69 6e )... (begin
06d0: 0a 09 09 09 28 64 65 62 75 67 3a 70 72 69 6e 74 ....(debug:print
06e0: 20 30 20 22 45 52 52 4f 52 3a 20 73 65 61 72 63 0 "ERROR: searc
06f0: 68 69 6e 67 20 66 6f 72 20 72 75 6e 73 20 77 69 hing for runs wi
0700: 74 68 20 6e 6f 20 70 61 74 74 65 72 6e 20 73 65 th no pattern se
0710: 74 20 66 6f 72 20 22 20 66 75 6c 6b 65 79 29 0a t for " fulkey).
0720: 09 09 09 28 65 78 69 74 20 36 29 29 29 29 29 0a ...(exit 6))))).
0730: 09 20 20 20 20 20 20 6b 65 79 73 29 0a 20 20 20 . keys).
0740: 20 28 73 65 74 21 20 71 72 79 2d 73 74 72 20 28 (set! qry-str (
0750: 63 6f 6e 63 20 22 53 45 4c 45 43 54 20 22 20 6b conc "SELECT " k
0760: 65 79 73 74 72 20 22 20 46 52 4f 4d 20 72 75 6e eystr " FROM run
0770: 73 20 57 48 45 52 45 20 72 75 6e 6e 61 6d 65 20 s WHERE runname
0780: 22 20 72 75 6e 77 69 6c 64 74 79 70 65 20 22 20 " runwildtype "
0790: 3f 20 22 20 6b 65 79 2d 70 61 74 74 20 22 3b 22 ? " key-patt ";"
07a0: 29 29 0a 20 20 20 20 28 64 65 62 75 67 3a 70 72 )). (debug:pr
07b0: 69 6e 74 2d 69 6e 66 6f 20 34 20 22 72 75 6e 73 int-info 4 "runs
07c0: 3a 67 65 74 2d 72 75 6e 73 2d 62 79 2d 70 61 74 :get-runs-by-pat
07d0: 74 20 71 72 79 3d 22 20 71 72 79 2d 73 74 72 20 t qry=" qry-str
07e0: 22 20 22 20 72 75 6e 6e 61 6d 65 70 61 74 74 29 " " runnamepatt)
07f0: 0a 20 20 20 20 28 73 71 6c 69 74 65 33 3a 66 6f . (sqlite3:fo
0800: 72 2d 65 61 63 68 2d 72 6f 77 20 0a 20 20 20 20 r-each-row .
0810: 20 28 6c 61 6d 62 64 61 20 28 61 20 2e 20 72 29 (lambda (a . r)
0820: 0a 20 20 20 20 20 20 20 28 73 65 74 21 20 72 65 . (set! re
0830: 73 20 28 63 6f 6e 73 20 28 6c 69 73 74 2d 3e 76 s (cons (list->v
0840: 65 63 74 6f 72 20 28 63 6f 6e 73 20 61 20 72 29 ector (cons a r)
0850: 29 20 72 65 73 29 29 29 0a 20 20 20 20 20 64 62 ) res))). db
0860: 20 0a 20 20 20 20 20 71 72 79 2d 73 74 72 0a 20 . qry-str.
0870: 20 20 20 20 72 75 6e 6e 61 6d 65 70 61 74 74 29 runnamepatt)
0880: 0a 20 20 20 20 28 76 65 63 74 6f 72 20 68 65 61 . (vector hea
0890: 64 65 72 20 72 65 73 29 29 29 0a 0a 28 64 65 66 der res)))..(def
08a0: 69 6e 65 20 28 72 75 6e 73 3a 74 65 73 74 2d 67 ine (runs:test-g
08b0: 65 74 2d 66 75 6c 6c 2d 70 61 74 68 20 74 65 73 et-full-path tes
08c0: 74 29 0a 20 20 28 6c 65 74 2a 20 28 28 74 65 73 t). (let* ((tes
08d0: 74 6e 61 6d 65 20 28 64 62 3a 74 65 73 74 2d 67 tname (db:test-g
08e0: 65 74 2d 74 65 73 74 6e 61 6d 65 20 20 20 74 65 et-testname te
08f0: 73 74 29 29 0a 09 20 28 69 74 65 6d 70 61 74 68 st)).. (itempath
0900: 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 69 74 (db:test-get-it
0910: 65 6d 2d 70 61 74 68 20 74 65 73 74 29 29 29 0a em-path test))).
0920: 20 20 20 20 28 63 6f 6e 63 20 74 65 73 74 6e 61 (conc testna
0930: 6d 65 20 28 69 66 20 28 65 71 75 61 6c 3f 20 69 me (if (equal? i
0940: 74 65 6d 70 61 74 68 20 22 22 29 20 22 22 20 28 tempath "") "" (
0950: 63 6f 6e 63 20 22 28 22 20 69 74 65 6d 70 61 74 conc "(" itempat
0960: 68 20 22 29 22 29 29 29 29 29 0a 0a 28 64 65 66 h ")")))))..(def
0970: 69 6e 65 20 28 64 62 3a 67 65 74 2d 72 75 6e 2d ine (db:get-run-
0980: 6b 65 79 2d 76 61 6c 20 64 62 20 72 75 6e 2d 69 key-val db run-i
0990: 64 20 6b 65 79 29 0a 20 20 28 6c 65 74 20 28 28 d key). (let ((
09a0: 72 65 73 20 23 66 29 29 0a 20 20 20 20 28 73 71 res #f)). (sq
09b0: 6c 69 74 65 33 3a 66 6f 72 2d 65 61 63 68 2d 72 lite3:for-each-r
09c0: 6f 77 0a 20 20 20 20 20 28 6c 61 6d 62 64 61 20 ow. (lambda
09d0: 28 76 61 6c 29 0a 20 20 20 20 20 20 20 28 73 65 (val). (se
09e0: 74 21 20 72 65 73 20 76 61 6c 29 29 0a 20 20 20 t! res val)).
09f0: 20 20 64 62 20 0a 20 20 20 20 20 28 63 6f 6e 63 db . (conc
0a00: 20 22 53 45 4c 45 43 54 20 22 20 28 6b 65 79 3a "SELECT " (key:
0a10: 67 65 74 2d 66 69 65 6c 64 6e 61 6d 65 20 6b 65 get-fieldname ke
0a20: 79 29 20 22 20 46 52 4f 4d 20 72 75 6e 73 20 57 y) " FROM runs W
0a30: 48 45 52 45 20 69 64 3d 3f 3b 22 29 0a 20 20 20 HERE id=?;").
0a40: 20 20 72 75 6e 2d 69 64 29 0a 20 20 20 20 72 65 run-id). re
0a50: 73 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 64 62 s))..(define (db
0a60: 3a 67 65 74 2d 72 75 6e 2d 6e 61 6d 65 2d 66 72 :get-run-name-fr
0a70: 6f 6d 2d 69 64 20 64 62 20 72 75 6e 2d 69 64 29 om-id db run-id)
0a80: 0a 20 20 28 6c 65 74 20 28 28 72 65 73 20 23 66 . (let ((res #f
0a90: 29 29 0a 20 20 20 20 28 73 71 6c 69 74 65 33 3a )). (sqlite3:
0aa0: 66 6f 72 2d 65 61 63 68 2d 72 6f 77 0a 20 20 20 for-each-row.
0ab0: 20 20 28 6c 61 6d 62 64 61 20 28 72 75 6e 6e 61 (lambda (runna
0ac0: 6d 65 29 0a 20 20 20 20 20 20 20 28 73 65 74 21 me). (set!
0ad0: 20 72 65 73 20 72 75 6e 6e 61 6d 65 29 29 0a 20 res runname)).
0ae0: 20 20 20 20 64 62 0a 20 20 20 20 20 22 53 45 4c db. "SEL
0af0: 45 43 54 20 72 75 6e 6e 61 6d 65 20 46 52 4f 4d ECT runname FROM
0b00: 20 72 75 6e 73 20 57 48 45 52 45 20 69 64 3d 3f runs WHERE id=?
0b10: 3b 22 0a 20 20 20 20 20 72 75 6e 2d 69 64 29 0a ;". run-id).
0b20: 20 20 20 20 72 65 73 29 29 0a 0a 28 64 65 66 69 res))..(defi
0b30: 6e 65 20 28 73 65 74 2d 6d 65 67 61 74 65 73 74 ne (set-megatest
0b40: 2d 65 6e 76 2d 76 61 72 73 20 72 75 6e 2d 69 64 -env-vars run-id
0b50: 29 0a 20 20 28 6c 65 74 20 28 28 6b 65 79 73 20 ). (let ((keys
0b60: 28 63 64 62 3a 72 65 6d 6f 74 65 2d 72 75 6e 20 (cdb:remote-run
0b70: 64 62 3a 67 65 74 2d 6b 65 79 73 20 23 66 29 29 db:get-keys #f))
0b80: 0a 09 28 76 61 6c 73 20 28 68 61 73 68 2d 74 61 ..(vals (hash-ta
0b90: 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 ble-ref/default
0ba0: 2a 65 6e 76 2d 76 61 72 73 2d 62 79 2d 72 75 6e *env-vars-by-run
0bb0: 2d 69 64 2a 20 72 75 6e 2d 69 64 20 23 66 29 29 -id* run-id #f))
0bc0: 29 0a 20 20 20 20 3b 3b 20 67 65 74 20 74 68 65 ). ;; get the
0bd0: 20 69 6e 66 6f 20 66 72 6f 6d 20 74 68 65 20 64 info from the d
0be0: 62 20 61 6e 64 20 70 75 74 20 69 74 20 69 6e 20 b and put it in
0bf0: 74 68 65 20 63 61 63 68 65 0a 20 20 20 20 28 69 the cache. (i
0c00: 66 20 28 6e 6f 74 20 76 61 6c 73 29 0a 09 28 6c f (not vals)..(l
0c10: 65 74 20 28 28 68 74 20 28 6d 61 6b 65 2d 68 61 et ((ht (make-ha
0c20: 73 68 2d 74 61 62 6c 65 29 29 29 0a 09 20 20 28 sh-table))).. (
0c30: 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 hash-table-set!
0c40: 2a 65 6e 76 2d 76 61 72 73 2d 62 79 2d 72 75 6e *env-vars-by-run
0c50: 2d 69 64 2a 20 72 75 6e 2d 69 64 20 68 74 29 0a -id* run-id ht).
0c60: 09 20 20 28 73 65 74 21 20 76 61 6c 73 20 68 74 . (set! vals ht
0c70: 29 0a 09 20 20 28 66 6f 72 2d 65 61 63 68 0a 09 ).. (for-each..
0c80: 20 20 20 28 6c 61 6d 62 64 61 20 28 6b 65 79 29 (lambda (key)
0c90: 0a 09 20 20 20 20 20 28 68 61 73 68 2d 74 61 62 .. (hash-tab
0ca0: 6c 65 2d 73 65 74 21 20 76 61 6c 73 20 6b 65 79 le-set! vals key
0cb0: 20 28 63 64 62 3a 72 65 6d 6f 74 65 2d 72 75 6e (cdb:remote-run
0cc0: 20 64 62 3a 67 65 74 2d 72 75 6e 2d 6b 65 79 2d db:get-run-key-
0cd0: 76 61 6c 20 23 66 20 72 75 6e 2d 69 64 20 6b 65 val #f run-id ke
0ce0: 79 29 29 29 0a 09 20 20 20 6b 65 79 73 29 29 29 y))).. keys)))
0cf0: 0a 20 20 20 20 3b 3b 20 66 72 6f 6d 20 74 68 65 . ;; from the
0d00: 20 63 61 63 68 65 64 20 64 61 74 61 20 73 65 74 cached data set
0d10: 20 74 68 65 20 76 61 72 73 0a 20 20 20 20 28 68 the vars. (h
0d20: 61 73 68 2d 74 61 62 6c 65 2d 66 6f 72 2d 65 61 ash-table-for-ea
0d30: 63 68 0a 20 20 20 20 20 76 61 6c 73 0a 20 20 20 ch. vals.
0d40: 20 20 28 6c 61 6d 62 64 61 20 28 6b 65 79 20 76 (lambda (key v
0d50: 61 6c 29 0a 20 20 20 20 20 20 20 28 64 65 62 75 al). (debu
0d60: 67 3a 70 72 69 6e 74 20 32 20 22 73 65 74 65 6e g:print 2 "seten
0d70: 76 20 22 20 28 6b 65 79 3a 67 65 74 2d 66 69 65 v " (key:get-fie
0d80: 6c 64 6e 61 6d 65 20 6b 65 79 29 20 22 20 22 20 ldname key) " "
0d90: 76 61 6c 29 0a 20 20 20 20 20 20 20 28 73 65 74 val). (set
0da0: 65 6e 76 20 28 6b 65 79 3a 67 65 74 2d 66 69 65 env (key:get-fie
0db0: 6c 64 6e 61 6d 65 20 6b 65 79 29 20 76 61 6c 29 ldname key) val)
0dc0: 29 29 0a 20 20 20 20 28 61 6c 69 73 74 2d 3e 65 )). (alist->e
0dd0: 6e 76 2d 76 61 72 73 20 28 68 61 73 68 2d 74 61 nv-vars (hash-ta
0de0: 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 ble-ref/default
0df0: 2a 63 6f 6e 66 69 67 64 61 74 2a 20 22 65 6e 76 *configdat* "env
0e00: 2d 6f 76 65 72 72 69 64 65 22 20 27 28 29 29 29 -override" '()))
0e10: 0a 20 20 20 20 3b 3b 20 4c 65 74 73 20 75 73 65 . ;; Lets use
0e20: 20 74 68 69 73 20 61 73 20 61 6e 20 6f 70 70 6f this as an oppo
0e30: 72 74 75 6e 69 74 79 20 74 6f 20 70 75 74 20 4d rtunity to put M
0e40: 54 5f 52 55 4e 4e 41 4d 45 20 69 6e 20 74 68 65 T_RUNNAME in the
0e50: 20 65 6e 76 69 72 6f 6e 6d 65 6e 74 0a 20 20 20 environment.
0e60: 20 28 73 65 74 65 6e 76 20 22 4d 54 5f 52 55 4e (setenv "MT_RUN
0e70: 4e 41 4d 45 22 20 28 63 64 62 3a 72 65 6d 6f 74 NAME" (cdb:remot
0e80: 65 2d 72 75 6e 20 64 62 3a 67 65 74 2d 72 75 6e e-run db:get-run
0e90: 2d 6e 61 6d 65 2d 66 72 6f 6d 2d 69 64 20 23 66 -name-from-id #f
0ea0: 20 72 75 6e 2d 69 64 29 29 0a 20 20 20 20 28 73 run-id)). (s
0eb0: 65 74 65 6e 76 20 22 4d 54 5f 52 55 4e 5f 41 52 etenv "MT_RUN_AR
0ec0: 45 41 5f 48 4f 4d 45 22 20 2a 74 6f 70 70 61 74 EA_HOME" *toppat
0ed0: 68 2a 29 0a 20 20 20 20 29 29 0a 0a 28 64 65 66 h*). ))..(def
0ee0: 69 6e 65 20 28 73 65 74 2d 69 74 65 6d 2d 65 6e ine (set-item-en
0ef0: 76 2d 76 61 72 73 20 69 74 65 6d 64 61 74 29 0a v-vars itemdat).
0f00: 20 20 28 66 6f 72 2d 65 61 63 68 20 28 6c 61 6d (for-each (lam
0f10: 62 64 61 20 28 69 74 65 6d 29 0a 09 20 20 20 20 bda (item)..
0f20: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 32 (debug:print 2
0f30: 20 22 73 65 74 65 6e 76 20 22 20 28 63 61 72 20 "setenv " (car
0f40: 69 74 65 6d 29 20 22 20 22 20 28 63 61 64 72 20 item) " " (cadr
0f50: 69 74 65 6d 29 29 0a 09 20 20 20 20 20 20 28 73 item)).. (s
0f60: 65 74 65 6e 76 20 28 63 61 72 20 69 74 65 6d 29 etenv (car item)
0f70: 20 28 63 61 64 72 20 69 74 65 6d 29 29 29 0a 09 (cadr item)))..
0f80: 20 20 20 20 69 74 65 6d 64 61 74 29 29 0a 0a 28 itemdat))..(
0f90: 64 65 66 69 6e 65 20 2a 6c 61 73 74 2d 6e 75 6d define *last-num
0fa0: 2d 72 75 6e 6e 69 6e 67 2d 74 65 73 74 73 2a 20 -running-tests*
0fb0: 30 29 0a 28 64 65 66 69 6e 65 20 2a 72 75 6e 73 0).(define *runs
0fc0: 3a 63 61 6e 2d 72 75 6e 2d 6d 6f 72 65 2d 74 65 :can-run-more-te
0fd0: 73 74 73 2d 64 65 6c 61 79 2a 20 30 29 0a 28 64 sts-delay* 0).(d
0fe0: 65 66 69 6e 65 20 28 72 75 6e 73 3a 73 68 72 69 efine (runs:shri
0ff0: 6e 6b 2d 63 61 6e 2d 72 75 6e 2d 6d 6f 72 65 2d nk-can-run-more-
1000: 74 65 73 74 73 2d 64 65 6c 61 79 29 0a 20 20 28 tests-delay). (
1010: 73 65 74 21 20 2a 72 75 6e 73 3a 63 61 6e 2d 72 set! *runs:can-r
1020: 75 6e 2d 6d 6f 72 65 2d 74 65 73 74 73 2d 64 65 un-more-tests-de
1030: 6c 61 79 2a 20 30 29 29 20 3b 3b 20 28 2f 20 2a lay* 0)) ;; (/ *
1040: 72 75 6e 73 3a 63 61 6e 2d 72 75 6e 2d 6d 6f 72 runs:can-run-mor
1050: 65 2d 74 65 73 74 73 2d 64 65 6c 61 79 2a 20 32 e-tests-delay* 2
1060: 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 72 75 )))..(define (ru
1070: 6e 73 3a 63 61 6e 2d 72 75 6e 2d 6d 6f 72 65 2d ns:can-run-more-
1080: 74 65 73 74 73 20 74 65 73 74 2d 72 65 63 6f 72 tests test-recor
1090: 64 29 0a 20 20 28 74 68 72 65 61 64 2d 73 6c 65 d). (thread-sle
10a0: 65 70 21 20 2a 72 75 6e 73 3a 63 61 6e 2d 72 75 ep! *runs:can-ru
10b0: 6e 2d 6d 6f 72 65 2d 74 65 73 74 73 2d 64 65 6c n-more-tests-del
10c0: 61 79 2a 29 0a 20 20 28 6c 65 74 2a 20 28 28 74 ay*). (let* ((t
10d0: 63 6f 6e 66 69 67 20 20 20 20 20 20 20 20 20 20 config
10e0: 20 20 20 20 20 20 20 28 74 65 73 74 73 3a 74 65 (tests:te
10f0: 73 74 71 75 65 75 65 2d 67 65 74 2d 74 65 73 74 stqueue-get-test
1100: 63 6f 6e 66 69 67 20 74 65 73 74 2d 72 65 63 6f config test-reco
1110: 72 64 29 29 0a 09 20 28 6a 6f 62 67 72 6f 75 70 rd)).. (jobgroup
1120: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1130: 28 63 6f 6e 66 69 67 2d 6c 6f 6f 6b 75 70 20 74 (config-lookup t
1140: 63 6f 6e 66 69 67 20 22 72 65 71 75 69 72 65 6d config "requirem
1150: 65 6e 74 73 22 20 22 6a 6f 62 67 72 6f 75 70 22 ents" "jobgroup"
1160: 29 29 0a 09 20 3b 3b 20 48 65 75 72 69 73 74 69 )).. ;; Heuristi
1170: 63 20 66 69 78 2e 20 54 68 65 73 65 20 61 72 65 c fix. These are
1180: 20 67 65 74 74 69 6e 67 20 63 61 6c 6c 65 64 20 getting called
1190: 74 6f 6f 20 72 61 70 69 64 6c 79 20 77 68 65 6e too rapidly when
11a0: 20 6a 6f 62 73 20 61 72 65 20 72 75 6e 6e 69 6e jobs are runnin
11b0: 67 20 6f 72 20 73 74 75 63 6b 0a 09 20 3b 3b 20 g or stuck.. ;;
11c0: 73 6f 20 77 65 20 61 72 65 20 67 6f 69 6e 67 20 so we are going
11d0: 74 6f 20 69 6e 63 72 65 6d 65 6e 74 20 61 20 67 to increment a g
11e0: 6c 6f 62 61 6c 20 64 65 6c 61 79 20 62 79 20 30 lobal delay by 0
11f0: 2e 31 20 73 65 63 6f 6e 64 73 20 75 70 20 74 6f .1 seconds up to
1200: 20 31 30 20 73 65 63 6f 6e 64 73 0a 09 20 3b 3b 10 seconds.. ;;
1210: 20 65 76 65 72 79 20 74 69 6d 65 20 72 75 6e 73 every time runs
1220: 3a 63 61 6e 2d 72 75 6e 2d 6d 6f 72 65 2d 74 65 :can-run-more-te
1230: 73 74 73 20 69 73 20 63 61 6c 6c 65 64 2e 0a 09 sts is called...
1240: 20 3b 3b 20 77 68 65 6e 20 61 20 74 65 73 74 20 ;; when a test
1250: 69 73 20 6c 61 75 6e 63 68 65 64 20 6f 72 20 6f is launched or o
1260: 74 68 65 72 20 61 63 74 69 76 69 74 79 20 6f 63 ther activity oc
1270: 63 75 72 73 20 64 69 76 69 64 65 20 74 68 65 20 curs divide the
1280: 64 65 6c 61 79 20 62 79 20 32 0a 09 20 28 6e 75 delay by 2.. (nu
1290: 6d 2d 72 75 6e 6e 69 6e 67 20 20 20 20 20 20 20 m-running
12a0: 20 20 20 20 20 20 28 63 64 62 3a 72 65 6d 6f 74 (cdb:remot
12b0: 65 2d 72 75 6e 20 64 62 3a 67 65 74 2d 63 6f 75 e-run db:get-cou
12c0: 6e 74 2d 74 65 73 74 73 2d 72 75 6e 6e 69 6e 67 nt-tests-running
12d0: 20 23 66 29 29 0a 09 20 28 6e 75 6d 2d 72 75 6e #f)).. (num-run
12e0: 6e 69 6e 67 2d 69 6e 2d 6a 6f 62 67 72 6f 75 70 ning-in-jobgroup
12f0: 20 28 63 64 62 3a 72 65 6d 6f 74 65 2d 72 75 6e (cdb:remote-run
1300: 20 64 62 3a 67 65 74 2d 63 6f 75 6e 74 2d 74 65 db:get-count-te
1310: 73 74 73 2d 72 75 6e 6e 69 6e 67 2d 69 6e 2d 6a sts-running-in-j
1320: 6f 62 67 72 6f 75 70 20 23 66 20 6a 6f 62 67 72 obgroup #f jobgr
1330: 6f 75 70 29 29 0a 09 20 28 6d 61 78 2d 63 6f 6e oup)).. (max-con
1340: 63 75 72 72 65 6e 74 2d 6a 6f 62 73 20 20 20 20 current-jobs
1350: 20 28 6c 65 74 20 28 28 6d 63 6a 20 28 63 6f 6e (let ((mcj (con
1360: 66 69 67 2d 6c 6f 6f 6b 75 70 20 2a 63 6f 6e 66 fig-lookup *conf
1370: 69 67 64 61 74 2a 20 22 73 65 74 75 70 22 20 20 igdat* "setup"
1380: 20 20 20 22 6d 61 78 5f 63 6f 6e 63 75 72 72 65 "max_concurre
1390: 6e 74 5f 6a 6f 62 73 22 29 29 29 0a 09 09 09 09 nt_jobs"))).....
13a0: 20 20 20 20 28 69 66 20 28 61 6e 64 20 6d 63 6a (if (and mcj
13b0: 20 28 73 74 72 69 6e 67 2d 3e 6e 75 6d 62 65 72 (string->number
13c0: 20 6d 63 6a 29 29 0a 09 09 09 09 09 28 73 74 72 mcj))......(str
13d0: 69 6e 67 2d 3e 6e 75 6d 62 65 72 20 6d 63 6a 29 ing->number mcj)
13e0: 0a 09 09 09 09 09 31 29 29 29 0a 09 20 28 6a 6f ......1))).. (jo
13f0: 62 2d 67 72 6f 75 70 2d 6c 69 6d 69 74 20 20 20 b-group-limit
1400: 20 20 20 20 20 20 28 63 6f 6e 66 69 67 2d 6c 6f (config-lo
1410: 6f 6b 75 70 20 2a 63 6f 6e 66 69 67 64 61 74 2a okup *configdat*
1420: 20 22 6a 6f 62 67 72 6f 75 70 73 22 20 6a 6f 62 "jobgroups" job
1430: 67 72 6f 75 70 29 29 29 0a 20 20 20 20 28 69 66 group))). (if
1440: 20 28 61 6e 64 20 28 3e 20 28 2b 20 6e 75 6d 2d (and (> (+ num-
1450: 72 75 6e 6e 69 6e 67 20 6e 75 6d 2d 72 75 6e 6e running num-runn
1460: 69 6e 67 2d 69 6e 2d 6a 6f 62 67 72 6f 75 70 29 ing-in-jobgroup)
1470: 20 30 29 0a 09 20 20 20 20 20 28 3c 20 2a 72 75 0).. (< *ru
1480: 6e 73 3a 63 61 6e 2d 72 75 6e 2d 6d 6f 72 65 2d ns:can-run-more-
1490: 74 65 73 74 73 2d 64 65 6c 61 79 2a 20 31 30 29 tests-delay* 10)
14a0: 29 0a 09 28 62 65 67 69 6e 0a 09 20 20 28 73 65 )..(begin.. (se
14b0: 74 21 20 2a 72 75 6e 73 3a 63 61 6e 2d 72 75 6e t! *runs:can-run
14c0: 2d 6d 6f 72 65 2d 74 65 73 74 73 2d 64 65 6c 61 -more-tests-dela
14d0: 79 2a 20 28 2b 20 2a 72 75 6e 73 3a 63 61 6e 2d y* (+ *runs:can-
14e0: 72 75 6e 2d 6d 6f 72 65 2d 74 65 73 74 73 2d 64 run-more-tests-d
14f0: 65 6c 61 79 2a 20 31 29 29 20 3b 3b 20 30 2e 31 elay* 1)) ;; 0.1
1500: 29 29 0a 09 20 20 28 64 65 62 75 67 3a 70 72 69 )).. (debug:pri
1510: 6e 74 2d 69 6e 66 6f 20 31 34 20 22 63 61 6e 2d nt-info 14 "can-
1520: 72 75 6e 2d 6d 6f 72 65 2d 74 65 73 74 73 2d 64 run-more-tests-d
1530: 65 6c 61 79 3a 20 22 20 2a 72 75 6e 73 3a 63 61 elay: " *runs:ca
1540: 6e 2d 72 75 6e 2d 6d 6f 72 65 2d 74 65 73 74 73 n-run-more-tests
1550: 2d 64 65 6c 61 79 2a 29 29 29 0a 20 20 20 20 28 -delay*))). (
1560: 69 66 20 28 6e 6f 74 20 28 65 71 3f 20 2a 6c 61 if (not (eq? *la
1570: 73 74 2d 6e 75 6d 2d 72 75 6e 6e 69 6e 67 2d 74 st-num-running-t
1580: 65 73 74 73 2a 20 6e 75 6d 2d 72 75 6e 6e 69 6e ests* num-runnin
1590: 67 29 29 0a 09 28 62 65 67 69 6e 0a 09 20 20 28 g))..(begin.. (
15a0: 64 65 62 75 67 3a 70 72 69 6e 74 20 32 20 22 6d debug:print 2 "m
15b0: 61 78 2d 63 6f 6e 63 75 72 72 65 6e 74 2d 6a 6f ax-concurrent-jo
15c0: 62 73 3a 20 22 20 6d 61 78 2d 63 6f 6e 63 75 72 bs: " max-concur
15d0: 72 65 6e 74 2d 6a 6f 62 73 20 22 2c 20 6e 75 6d rent-jobs ", num
15e0: 2d 72 75 6e 6e 69 6e 67 3a 20 22 20 6e 75 6d 2d -running: " num-
15f0: 72 75 6e 6e 69 6e 67 29 0a 09 20 20 28 73 65 74 running).. (set
1600: 21 20 2a 6c 61 73 74 2d 6e 75 6d 2d 72 75 6e 6e ! *last-num-runn
1610: 69 6e 67 2d 74 65 73 74 73 2a 20 6e 75 6d 2d 72 ing-tests* num-r
1620: 75 6e 6e 69 6e 67 29 29 29 0a 20 20 20 20 28 69 unning))). (i
1630: 66 20 28 6e 6f 74 20 28 65 71 3f 20 30 20 2a 67 f (not (eq? 0 *g
1640: 6c 6f 62 61 6c 65 78 69 74 73 74 61 74 75 73 2a lobalexitstatus*
1650: 29 29 0a 09 28 6c 69 73 74 20 23 66 20 6e 75 6d ))..(list #f num
1660: 2d 72 75 6e 6e 69 6e 67 20 6e 75 6d 2d 72 75 6e -running num-run
1670: 6e 69 6e 67 2d 69 6e 2d 6a 6f 62 67 72 6f 75 70 ning-in-jobgroup
1680: 20 6d 61 78 2d 63 6f 6e 63 75 72 72 65 6e 74 2d max-concurrent-
1690: 6a 6f 62 73 20 6a 6f 62 2d 67 72 6f 75 70 2d 6c jobs job-group-l
16a0: 69 6d 69 74 29 0a 09 28 6c 65 74 20 28 28 63 61 imit)..(let ((ca
16b0: 6e 2d 6e 6f 74 2d 72 75 6e 2d 6d 6f 72 65 20 28 n-not-run-more (
16c0: 63 6f 6e 64 0a 09 09 09 09 20 3b 3b 20 69 66 20 cond..... ;; if
16d0: 6d 61 78 2d 63 6f 6e 63 75 72 72 65 6e 74 2d 6a max-concurrent-j
16e0: 6f 62 73 20 69 73 20 73 65 74 20 61 6e 64 20 74 obs is set and t
16f0: 68 65 20 6e 75 6d 62 65 72 20 72 75 6e 6e 69 6e he number runnin
1700: 67 20 69 73 20 67 72 65 61 74 65 72 20 0a 09 09 g is greater ...
1710: 09 09 20 3b 3b 20 74 68 61 6e 20 69 74 20 74 68 .. ;; than it th
1720: 61 6e 20 63 61 6e 6e 6f 74 20 72 75 6e 20 6d 6f an cannot run mo
1730: 72 65 20 6a 6f 62 73 0a 09 09 09 09 20 28 28 61 re jobs..... ((a
1740: 6e 64 20 6d 61 78 2d 63 6f 6e 63 75 72 72 65 6e nd max-concurren
1750: 74 2d 6a 6f 62 73 20 28 3e 3d 20 6e 75 6d 2d 72 t-jobs (>= num-r
1760: 75 6e 6e 69 6e 67 20 6d 61 78 2d 63 6f 6e 63 75 unning max-concu
1770: 72 72 65 6e 74 2d 6a 6f 62 73 29 29 0a 09 09 09 rrent-jobs))....
1780: 09 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 . (debug:print
1790: 30 20 22 57 41 52 4e 49 4e 47 3a 20 4d 61 78 20 0 "WARNING: Max
17a0: 72 75 6e 6e 69 6e 67 20 6a 6f 62 73 20 65 78 63 running jobs exc
17b0: 65 65 64 65 64 2c 20 63 75 72 72 65 6e 74 20 6e eeded, current n
17c0: 75 6d 62 65 72 20 72 75 6e 6e 69 6e 67 3a 20 22 umber running: "
17d0: 20 6e 75 6d 2d 72 75 6e 6e 69 6e 67 20 0a 09 09 num-running ...
17e0: 09 09 09 20 20 20 20 20 20 20 22 2c 20 6d 61 78 ... ", max
17f0: 5f 63 6f 6e 63 75 72 72 65 6e 74 5f 6a 6f 62 73 _concurrent_jobs
1800: 3a 20 22 20 6d 61 78 2d 63 6f 6e 63 75 72 72 65 : " max-concurre
1810: 6e 74 2d 6a 6f 62 73 29 0a 09 09 09 09 20 20 23 nt-jobs)..... #
1820: 74 29 0a 09 09 09 09 20 3b 3b 20 69 66 20 6a 6f t)..... ;; if jo
1830: 62 2d 67 72 6f 75 70 2d 6c 69 6d 69 74 20 69 73 b-group-limit is
1840: 20 73 65 74 20 61 6e 64 20 6e 75 6d 62 65 72 20 set and number
1850: 6f 66 20 6a 6f 62 73 20 69 6e 20 74 68 65 20 67 of jobs in the g
1860: 72 6f 75 70 20 69 73 20 67 72 65 61 74 65 72 0a roup is greater.
1870: 09 09 09 09 20 3b 3b 20 74 68 61 6e 20 74 68 65 .... ;; than the
1880: 20 6c 69 6d 69 74 20 74 68 65 6e 20 63 61 6e 6e limit then cann
1890: 6f 74 20 72 75 6e 20 6d 6f 72 65 20 6a 6f 62 73 ot run more jobs
18a0: 20 6f 66 20 74 68 69 73 20 6b 69 6e 64 0a 09 09 of this kind...
18b0: 09 09 20 28 28 61 6e 64 20 6a 6f 62 2d 67 72 6f .. ((and job-gro
18c0: 75 70 2d 6c 69 6d 69 74 0a 09 09 09 09 20 20 20 up-limit.....
18d0: 20 20 20 20 28 3e 3d 20 6e 75 6d 2d 72 75 6e 6e (>= num-runn
18e0: 69 6e 67 2d 69 6e 2d 6a 6f 62 67 72 6f 75 70 20 ing-in-jobgroup
18f0: 6a 6f 62 2d 67 72 6f 75 70 2d 6c 69 6d 69 74 29 job-group-limit)
1900: 29 0a 09 09 09 09 20 20 28 64 65 62 75 67 3a 70 )..... (debug:p
1910: 72 69 6e 74 20 31 20 22 57 41 52 4e 49 4e 47 3a rint 1 "WARNING:
1920: 20 6e 75 6d 62 65 72 20 6f 66 20 6a 6f 62 73 20 number of jobs
1930: 22 20 6e 75 6d 2d 72 75 6e 6e 69 6e 67 2d 69 6e " num-running-in
1940: 2d 6a 6f 62 67 72 6f 75 70 20 0a 09 09 09 09 09 -jobgroup ......
1950: 20 20 20 20 20 20 20 22 20 69 6e 20 22 20 6a 6f " in " jo
1960: 62 67 72 6f 75 70 20 22 20 65 78 63 65 65 64 65 bgroup " exceede
1970: 64 2c 20 77 69 6c 6c 20 6e 6f 74 20 72 75 6e 20 d, will not run
1980: 22 20 28 74 65 73 74 73 3a 74 65 73 74 71 75 65 " (tests:testque
1990: 75 65 2d 67 65 74 2d 74 65 73 74 6e 61 6d 65 20 ue-get-testname
19a0: 74 65 73 74 2d 72 65 63 6f 72 64 29 29 0a 09 09 test-record))...
19b0: 09 09 20 20 23 74 29 0a 09 09 09 09 20 28 65 6c .. #t)..... (el
19c0: 73 65 20 23 66 29 29 29 29 0a 09 20 20 28 6c 69 se #f)))).. (li
19d0: 73 74 20 28 6e 6f 74 20 63 61 6e 2d 6e 6f 74 2d st (not can-not-
19e0: 72 75 6e 2d 6d 6f 72 65 29 20 6e 75 6d 2d 72 75 run-more) num-ru
19f0: 6e 6e 69 6e 67 20 6e 75 6d 2d 72 75 6e 6e 69 6e nning num-runnin
1a00: 67 2d 69 6e 2d 6a 6f 62 67 72 6f 75 70 20 6d 61 g-in-jobgroup ma
1a10: 78 2d 63 6f 6e 63 75 72 72 65 6e 74 2d 6a 6f 62 x-concurrent-job
1a20: 73 20 6a 6f 62 2d 67 72 6f 75 70 2d 6c 69 6d 69 s job-group-limi
1a30: 74 29 29 29 29 29 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d t)))))..;;======
1a40: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1a50: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1a60: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1a70: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1a80: 0a 3b 3b 20 4e 65 77 20 6d 65 74 68 6f 64 6f 6c .;; New methodol
1a90: 6f 67 79 2e 20 54 68 65 73 65 20 72 6f 75 74 69 ogy. These routi
1aa0: 6e 65 73 20 77 69 6c 6c 20 72 65 70 6c 61 63 65 nes will replace
1ab0: 20 74 68 65 20 61 62 6f 76 65 20 69 6e 20 74 69 the above in ti
1ac0: 6d 65 2e 20 46 6f 72 0a 3b 3b 20 6e 6f 77 20 74 me. For.;; now t
1ad0: 68 65 20 63 6f 64 65 20 69 73 20 64 75 70 6c 69 he code is dupli
1ae0: 63 61 74 65 64 2e 20 54 68 69 73 20 73 74 75 66 cated. This stuf
1af0: 66 20 69 73 20 69 6e 69 74 69 61 6c 6c 79 20 75 f is initially u
1b00: 73 65 64 20 69 6e 20 74 68 65 20 6d 6f 6e 69 74 sed in the monit
1b10: 6f 72 0a 3b 3b 20 62 61 73 65 64 20 63 6f 64 65 or.;; based code
1b20: 2e 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ..;;============
1b30: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1b40: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1b50: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1b60: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 3b 3b 20 72 ==========..;; r
1b70: 65 67 69 73 74 65 72 20 61 20 74 65 73 74 20 72 egister a test r
1b80: 75 6e 20 77 69 74 68 20 74 68 65 20 64 62 0a 28 un with the db.(
1b90: 64 65 66 69 6e 65 20 28 72 75 6e 73 3a 72 65 67 define (runs:reg
1ba0: 69 73 74 65 72 2d 72 75 6e 20 64 62 20 6b 65 79 ister-run db key
1bb0: 73 20 6b 65 79 76 61 6c 6c 73 74 20 72 75 6e 6e s keyvallst runn
1bc0: 61 6d 65 20 73 74 61 74 65 20 73 74 61 74 75 73 ame state status
1bd0: 20 75 73 65 72 29 0a 20 20 28 64 65 62 75 67 3a user). (debug:
1be0: 70 72 69 6e 74 20 33 20 22 72 75 6e 73 3a 72 65 print 3 "runs:re
1bf0: 67 69 73 74 65 72 2d 72 75 6e 2c 20 6b 65 79 73 gister-run, keys
1c00: 3a 20 22 20 6b 65 79 73 20 22 20 6b 65 79 76 61 : " keys " keyva
1c10: 6c 6c 73 74 3a 20 22 20 6b 65 79 76 61 6c 6c 73 llst: " keyvalls
1c20: 74 20 22 20 72 75 6e 6e 61 6d 65 3a 20 22 20 72 t " runname: " r
1c30: 75 6e 6e 61 6d 65 20 22 20 73 74 61 74 65 3a 20 unname " state:
1c40: 22 20 73 74 61 74 65 20 22 20 73 74 61 74 75 73 " state " status
1c50: 3a 20 22 20 73 74 61 74 75 73 20 22 20 75 73 65 : " status " use
1c60: 72 3a 20 22 20 75 73 65 72 29 0a 20 20 28 6c 65 r: " user). (le
1c70: 74 2a 20 28 28 6b 65 79 73 74 72 20 20 20 20 28 t* ((keystr (
1c80: 6b 65 79 73 2d 3e 6b 65 79 73 74 72 20 6b 65 79 keys->keystr key
1c90: 73 29 29 0a 09 20 28 63 6f 6d 6d 61 20 20 20 20 s)).. (comma
1ca0: 20 28 69 66 20 28 3e 20 28 6c 65 6e 67 74 68 20 (if (> (length
1cb0: 6b 65 79 73 29 20 30 29 20 22 2c 22 20 22 22 29 keys) 0) "," "")
1cc0: 29 0a 09 20 28 61 6e 64 73 74 72 20 20 20 20 28 ).. (andstr (
1cd0: 69 66 20 28 3e 20 28 6c 65 6e 67 74 68 20 6b 65 if (> (length ke
1ce0: 79 73 29 20 30 29 20 22 20 41 4e 44 20 22 20 22 ys) 0) " AND " "
1cf0: 22 29 29 0a 09 20 28 76 61 6c 73 6c 6f 74 73 20 ")).. (valslots
1d00: 20 28 6b 65 79 73 2d 3e 76 61 6c 73 6c 6f 74 73 (keys->valslots
1d10: 20 6b 65 79 73 29 29 20 3b 3b 20 3f 2c 3f 2c 3f keys)) ;; ?,?,?
1d20: 20 2e 2e 2e 0a 09 20 28 6b 65 79 76 61 6c 73 20 ..... (keyvals
1d30: 20 20 28 6d 61 70 20 63 61 64 72 20 6b 65 79 76 (map cadr keyv
1d40: 61 6c 6c 73 74 29 29 0a 09 20 28 61 6c 6c 76 61 allst)).. (allva
1d50: 6c 73 20 20 20 28 61 70 70 65 6e 64 20 28 6c 69 ls (append (li
1d60: 73 74 20 72 75 6e 6e 61 6d 65 20 73 74 61 74 65 st runname state
1d70: 20 73 74 61 74 75 73 20 75 73 65 72 29 20 6b 65 status user) ke
1d80: 79 76 61 6c 73 29 29 0a 09 20 28 71 72 79 76 61 yvals)).. (qryva
1d90: 6c 73 20 20 20 28 61 70 70 65 6e 64 20 28 6c 69 ls (append (li
1da0: 73 74 20 72 75 6e 6e 61 6d 65 29 20 6b 65 79 76 st runname) keyv
1db0: 61 6c 73 29 29 0a 09 20 28 6b 65 79 3d 3f 73 74 als)).. (key=?st
1dc0: 72 20 20 28 73 74 72 69 6e 67 2d 69 6e 74 65 72 r (string-inter
1dd0: 73 70 65 72 73 65 20 28 6d 61 70 20 28 6c 61 6d sperse (map (lam
1de0: 62 64 61 20 28 6b 29 28 63 6f 6e 63 20 28 6b 65 bda (k)(conc (ke
1df0: 79 3a 67 65 74 2d 66 69 65 6c 64 6e 61 6d 65 20 y:get-fieldname
1e00: 6b 29 20 22 3d 3f 22 29 29 20 6b 65 79 73 29 20 k) "=?")) keys)
1e10: 22 20 41 4e 44 20 22 29 29 29 0a 20 20 20 20 28 " AND "))). (
1e20: 64 65 62 75 67 3a 70 72 69 6e 74 20 33 20 22 6b debug:print 3 "k
1e30: 65 79 73 3a 20 22 20 6b 65 79 73 20 22 20 61 6c eys: " keys " al
1e40: 6c 76 61 6c 73 3a 20 22 20 61 6c 6c 76 61 6c 73 lvals: " allvals
1e50: 20 22 20 6b 65 79 76 61 6c 73 3a 20 22 20 6b 65 " keyvals: " ke
1e60: 79 76 61 6c 73 29 0a 20 20 20 20 28 64 65 62 75 yvals). (debu
1e70: 67 3a 70 72 69 6e 74 20 32 20 22 4e 4f 54 45 3a g:print 2 "NOTE:
1e80: 20 75 73 69 6e 67 20 74 61 72 67 65 74 20 22 20 using target "
1e90: 28 73 74 72 69 6e 67 2d 69 6e 74 65 72 73 70 65 (string-interspe
1ea0: 72 73 65 20 6b 65 79 76 61 6c 73 20 22 2f 22 29 rse keyvals "/")
1eb0: 20 22 20 66 6f 72 20 74 68 69 73 20 72 75 6e 22 " for this run"
1ec0: 29 0a 20 20 20 20 28 69 66 20 28 61 6e 64 20 72 ). (if (and r
1ed0: 75 6e 6e 61 6d 65 20 28 6e 75 6c 6c 3f 20 28 66 unname (null? (f
1ee0: 69 6c 74 65 72 20 28 6c 61 6d 62 64 61 20 28 78 ilter (lambda (x
1ef0: 29 28 6e 6f 74 20 78 29 29 20 6b 65 79 76 61 6c )(not x)) keyval
1f00: 73 29 29 29 20 3b 3b 20 74 68 65 72 65 20 6d 75 s))) ;; there mu
1f10: 73 74 20 62 65 20 61 20 62 65 74 74 65 72 20 77 st be a better w
1f20: 61 79 20 74 6f 20 22 61 70 70 6c 79 20 61 6e 64 ay to "apply and
1f30: 22 0a 09 28 6c 65 74 20 28 28 72 65 73 20 23 66 "..(let ((res #f
1f40: 29 29 0a 09 20 20 28 61 70 70 6c 79 20 73 71 6c )).. (apply sql
1f50: 69 74 65 33 3a 65 78 65 63 75 74 65 20 64 62 20 ite3:execute db
1f60: 28 63 6f 6e 63 20 22 49 4e 53 45 52 54 20 4f 52 (conc "INSERT OR
1f70: 20 49 47 4e 4f 52 45 20 49 4e 54 4f 20 72 75 6e IGNORE INTO run
1f80: 73 20 28 72 75 6e 6e 61 6d 65 2c 73 74 61 74 65 s (runname,state
1f90: 2c 73 74 61 74 75 73 2c 6f 77 6e 65 72 2c 65 76 ,status,owner,ev
1fa0: 65 6e 74 5f 74 69 6d 65 22 20 63 6f 6d 6d 61 20 ent_time" comma
1fb0: 6b 65 79 73 74 72 20 22 29 20 56 41 4c 55 45 53 keystr ") VALUES
1fc0: 20 28 3f 2c 3f 2c 3f 2c 3f 2c 73 74 72 66 74 69 (?,?,?,?,strfti
1fd0: 6d 65 28 27 25 73 27 2c 27 6e 6f 77 27 29 22 20 me('%s','now')"
1fe0: 63 6f 6d 6d 61 20 76 61 6c 73 6c 6f 74 73 20 22 comma valslots "
1ff0: 29 3b 22 29 0a 09 09 20 61 6c 6c 76 61 6c 73 29 );")... allvals)
2000: 0a 09 20 20 28 61 70 70 6c 79 20 73 71 6c 69 74 .. (apply sqlit
2010: 65 33 3a 66 6f 72 2d 65 61 63 68 2d 72 6f 77 20 e3:for-each-row
2020: 0a 09 20 20 20 28 6c 61 6d 62 64 61 20 28 69 64 .. (lambda (id
2030: 29 0a 09 20 20 20 20 20 28 73 65 74 21 20 72 65 ).. (set! re
2040: 73 20 69 64 29 29 0a 09 20 20 20 64 62 0a 09 20 s id)).. db..
2050: 20 20 28 6c 65 74 20 28 28 71 72 79 20 28 63 6f (let ((qry (co
2060: 6e 63 20 22 53 45 4c 45 43 54 20 69 64 20 46 52 nc "SELECT id FR
2070: 4f 4d 20 72 75 6e 73 20 57 48 45 52 45 20 28 72 OM runs WHERE (r
2080: 75 6e 6e 61 6d 65 3d 3f 20 22 20 61 6e 64 73 74 unname=? " andst
2090: 72 20 6b 65 79 3d 3f 73 74 72 20 22 29 3b 22 29 r key=?str ");")
20a0: 29 29 0a 09 20 20 20 20 20 3b 28 64 65 62 75 67 )).. ;(debug
20b0: 3a 70 72 69 6e 74 20 34 20 22 71 72 79 3a 20 22 :print 4 "qry: "
20c0: 20 71 72 79 29 20 0a 09 20 20 20 20 20 71 72 79 qry) .. qry
20d0: 29 0a 09 20 20 20 71 72 79 76 61 6c 73 29 0a 09 ).. qryvals)..
20e0: 20 20 28 73 71 6c 69 74 65 33 3a 65 78 65 63 75 (sqlite3:execu
20f0: 74 65 20 64 62 20 22 55 50 44 41 54 45 20 72 75 te db "UPDATE ru
2100: 6e 73 20 53 45 54 20 73 74 61 74 65 3d 3f 2c 73 ns SET state=?,s
2110: 74 61 74 75 73 3d 3f 20 57 48 45 52 45 20 69 64 tatus=? WHERE id
2120: 3d 3f 3b 22 20 73 74 61 74 65 20 73 74 61 74 75 =?;" state statu
2130: 73 20 72 65 73 29 0a 09 20 20 72 65 73 29 20 0a s res).. res) .
2140: 09 28 62 65 67 69 6e 0a 09 20 20 28 64 65 62 75 .(begin.. (debu
2150: 67 3a 70 72 69 6e 74 20 30 20 22 45 52 52 4f 52 g:print 0 "ERROR
2160: 3a 20 43 61 6c 6c 65 64 20 77 69 74 68 6f 75 74 : Called without
2170: 20 61 6c 6c 20 6e 65 63 65 73 73 61 72 79 20 6b all necessary k
2180: 65 79 73 22 29 0a 09 20 20 23 66 29 29 29 29 0a eys").. #f)))).
2190: 0a 3b 3b 20 54 68 69 73 20 69 73 20 61 20 64 75 .;; This is a du
21a0: 70 6c 69 63 61 74 65 20 6f 66 20 72 75 6e 2d 74 plicate of run-t
21b0: 65 73 74 73 20 28 77 68 69 63 68 20 68 61 73 20 ests (which has
21c0: 62 65 65 6e 20 64 65 70 72 65 63 61 74 65 64 29 been deprecated)
21d0: 2e 20 55 73 65 20 74 68 69 73 20 6f 6e 65 20 69 . Use this one i
21e0: 6e 73 74 65 61 64 20 6f 66 20 72 75 6e 20 74 65 nstead of run te
21f0: 73 74 73 2e 0a 3b 3b 20 6b 65 79 76 61 6c 73 2e sts..;; keyvals.
2200: 0a 3b 3b 0a 3b 3b 20 20 74 65 73 74 2d 6e 61 6d .;;.;; test-nam
2210: 65 73 3a 20 43 6f 6d 6d 61 20 73 65 70 61 72 61 es: Comma separa
2220: 74 65 64 20 70 61 74 74 65 72 6e 73 20 73 61 6d ted patterns sam
2230: 65 20 61 73 20 74 65 73 74 2d 70 61 74 74 73 20 e as test-patts
2240: 62 75 74 20 75 73 65 64 20 69 6e 20 73 65 6c 65 but used in sele
2250: 63 74 69 6f 6e 20 0a 3b 3b 20 20 20 20 20 20 20 ction .;;
2260: 20 20 20 20 20 20 20 6f 66 20 74 65 73 74 73 20 of tests
2270: 74 6f 20 72 75 6e 2e 20 54 68 65 20 69 74 65 6d to run. The item
2280: 20 70 6f 72 74 69 6f 6e 73 20 61 72 65 20 6e 6f portions are no
2290: 74 20 72 65 73 70 65 63 74 65 64 2e 0a 3b 3b 20 t respected..;;
22a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 46 49 58 FIX
22b0: 4d 45 3a 20 65 72 72 6f 72 20 6f 75 74 20 69 66 ME: error out if
22c0: 20 2f 70 61 74 74 20 73 70 65 63 69 66 69 65 64 /patt specified
22d0: 0a 3b 3b 20 20 20 20 20 20 20 20 20 20 20 20 0a .;; .
22e0: 28 64 65 66 69 6e 65 20 28 72 75 6e 73 3a 72 75 (define (runs:ru
22f0: 6e 2d 74 65 73 74 73 20 74 61 72 67 65 74 20 72 n-tests target r
2300: 75 6e 6e 61 6d 65 20 74 65 73 74 2d 6e 61 6d 65 unname test-name
2310: 73 20 74 65 73 74 2d 70 61 74 74 73 20 75 73 65 s test-patts use
2320: 72 20 66 6c 61 67 73 29 0a 20 20 28 63 6f 6d 6d r flags). (comm
2330: 6f 6e 3a 63 6c 65 61 72 2d 63 61 63 68 65 73 29 on:clear-caches)
2340: 20 3b 3b 20 63 6c 65 61 72 20 61 6c 6c 20 63 61 ;; clear all ca
2350: 63 68 65 73 0a 20 20 28 6c 65 74 2a 20 28 28 64 ches. (let* ((d
2360: 62 20 20 20 20 20 20 20 20 20 20 23 66 29 0a 09 b #f)..
2370: 20 28 6b 65 79 73 20 20 20 20 20 20 20 20 28 63 (keys (c
2380: 64 62 3a 72 65 6d 6f 74 65 2d 72 75 6e 20 64 62 db:remote-run db
2390: 3a 67 65 74 2d 6b 65 79 73 20 23 66 29 29 0a 09 :get-keys #f))..
23a0: 20 28 6b 65 79 76 61 6c 6c 73 74 20 20 20 28 6b (keyvallst (k
23b0: 65 79 73 3a 74 61 72 67 65 74 2d 3e 6b 65 79 76 eys:target->keyv
23c0: 61 6c 20 6b 65 79 73 20 74 61 72 67 65 74 29 29 al keys target))
23d0: 0a 09 20 28 72 75 6e 2d 69 64 20 20 20 20 20 20 .. (run-id
23e0: 28 63 64 62 3a 72 65 6d 6f 74 65 2d 72 75 6e 20 (cdb:remote-run
23f0: 72 75 6e 73 3a 72 65 67 69 73 74 65 72 2d 72 75 runs:register-ru
2400: 6e 20 23 66 20 6b 65 79 73 20 6b 65 79 76 61 6c n #f keys keyval
2410: 6c 73 74 20 72 75 6e 6e 61 6d 65 20 22 6e 65 77 lst runname "new
2420: 22 20 22 6e 2f 61 22 20 75 73 65 72 29 29 20 20 " "n/a" user))
2430: 3b 3b 20 20 74 65 73 74 2d 6e 61 6d 65 29 29 29 ;; test-name)))
2440: 0a 09 20 28 6b 65 79 76 61 6c 73 20 20 20 20 20 .. (keyvals
2450: 28 69 66 20 72 75 6e 2d 69 64 20 28 63 64 62 3a (if run-id (cdb:
2460: 72 65 6d 6f 74 65 2d 72 75 6e 20 64 62 3a 67 65 remote-run db:ge
2470: 74 2d 6b 65 79 2d 76 61 6c 73 20 23 66 20 72 75 t-key-vals #f ru
2480: 6e 2d 69 64 29 20 23 66 29 29 0a 09 20 28 64 65 n-id) #f)).. (de
2490: 66 65 72 72 65 64 20 20 20 20 27 28 29 29 20 3b ferred '()) ;
24a0: 3b 20 64 65 6c 61 79 20 72 75 6e 6e 69 6e 67 20 ; delay running
24b0: 74 68 65 73 65 20 73 69 6e 63 65 20 74 68 65 79 these since they
24c0: 20 68 61 76 65 20 61 20 77 61 69 74 6f 6e 20 63 have a waiton c
24d0: 6c 61 75 73 65 0a 09 20 3b 3b 20 6b 65 65 70 67 lause.. ;; keepg
24e0: 6f 69 6e 67 20 69 73 20 74 68 65 20 64 65 66 61 oing is the defa
24f0: 63 74 6f 20 6d 6f 64 61 6c 69 74 79 20 6e 6f 77 cto modality now
2500: 2c 20 77 69 6c 6c 20 61 64 64 20 68 69 74 2d 6e , will add hit-n
2510: 2d 72 75 6e 20 61 20 62 69 74 20 6c 61 74 65 72 -run a bit later
2520: 0a 09 20 3b 3b 20 28 6b 65 65 70 67 6f 69 6e 67 .. ;; (keepgoing
2530: 20 20 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 (hash-table-r
2540: 65 66 2f 64 65 66 61 75 6c 74 20 66 6c 61 67 73 ef/default flags
2550: 20 22 2d 6b 65 65 70 67 6f 69 6e 67 22 20 23 66 "-keepgoing" #f
2560: 29 29 0a 09 20 28 72 75 6e 63 6f 6e 66 69 67 66 )).. (runconfigf
2570: 20 20 20 28 63 6f 6e 63 20 20 2a 74 6f 70 70 61 (conc *toppa
2580: 74 68 2a 20 22 2f 72 75 6e 63 6f 6e 66 69 67 73 th* "/runconfigs
2590: 2e 63 6f 6e 66 69 67 22 29 29 0a 09 20 28 72 65 .config")).. (re
25a0: 71 75 69 72 65 64 2d 74 65 73 74 73 20 27 28 29 quired-tests '()
25b0: 29 0a 09 20 28 74 65 73 74 2d 72 65 63 6f 72 64 ).. (test-record
25c0: 73 20 28 6d 61 6b 65 2d 68 61 73 68 2d 74 61 62 s (make-hash-tab
25d0: 6c 65 29 29 29 0a 0a 20 20 20 20 28 73 65 74 2d le))).. (set-
25e0: 6d 65 67 61 74 65 73 74 2d 65 6e 76 2d 76 61 72 megatest-env-var
25f0: 73 20 72 75 6e 2d 69 64 29 20 3b 3b 20 74 68 65 s run-id) ;; the
2600: 73 65 20 6d 61 79 20 62 65 20 6e 65 65 64 65 64 se may be needed
2610: 20 62 79 20 74 68 65 20 6c 61 75 6e 63 68 69 6e by the launchin
2620: 67 20 70 72 6f 63 65 73 73 0a 0a 20 20 20 20 28 g process.. (
2630: 69 66 20 28 66 69 6c 65 2d 65 78 69 73 74 73 3f if (file-exists?
2640: 20 72 75 6e 63 6f 6e 66 69 67 66 29 0a 09 28 73 runconfigf)..(s
2650: 65 74 75 70 2d 65 6e 76 2d 64 65 66 61 75 6c 74 etup-env-default
2660: 73 20 72 75 6e 63 6f 6e 66 69 67 66 20 72 75 6e s runconfigf run
2670: 2d 69 64 20 2a 61 6c 72 65 61 64 79 2d 73 65 65 -id *already-see
2680: 6e 2d 72 75 6e 63 6f 6e 66 69 67 2d 69 6e 66 6f n-runconfig-info
2690: 2a 20 6b 65 79 73 20 6b 65 79 76 61 6c 73 20 22 * keys keyvals "
26a0: 70 72 65 2d 6c 61 75 6e 63 68 2d 65 6e 76 2d 76 pre-launch-env-v
26b0: 61 72 73 22 29 0a 09 28 64 65 62 75 67 3a 70 72 ars")..(debug:pr
26c0: 69 6e 74 20 30 20 22 57 41 52 4e 49 4e 47 3a 20 int 0 "WARNING:
26d0: 59 6f 75 20 64 6f 20 6e 6f 74 20 68 61 76 65 20 You do not have
26e0: 61 20 72 75 6e 20 63 6f 6e 66 69 67 20 66 69 6c a run config fil
26f0: 65 3a 20 22 20 72 75 6e 63 6f 6e 66 69 67 66 29 e: " runconfigf)
2700: 29 0a 20 20 20 20 0a 20 20 20 20 3b 3b 20 6c 6f ). . ;; lo
2710: 6f 6b 20 75 70 20 61 6c 6c 20 74 65 73 74 73 20 ok up all tests
2720: 6d 61 74 63 68 69 6e 67 20 74 68 65 20 63 6f 6d matching the com
2730: 6d 61 20 73 65 70 61 72 61 74 65 64 20 6c 69 73 ma separated lis
2740: 74 20 6f 66 20 67 6c 6f 62 73 20 69 6e 0a 20 20 t of globs in.
2750: 20 20 3b 3b 20 74 65 73 74 2d 70 61 74 74 73 20 ;; test-patts
2760: 28 75 73 69 6e 67 20 25 20 61 73 20 77 69 6c 64 (using % as wild
2770: 63 61 72 64 29 0a 0a 20 20 20 20 28 73 65 74 21 card).. (set!
2780: 20 74 65 73 74 2d 6e 61 6d 65 73 20 28 74 65 73 test-names (tes
2790: 74 73 3a 67 65 74 2d 76 61 6c 69 64 2d 74 65 73 ts:get-valid-tes
27a0: 74 73 20 2a 74 6f 70 70 61 74 68 2a 20 74 65 73 ts *toppath* tes
27b0: 74 2d 6e 61 6d 65 73 29 29 0a 20 20 20 20 28 73 t-names)). (s
27c0: 65 74 21 20 74 65 73 74 2d 6e 61 6d 65 73 20 28 et! test-names (
27d0: 64 65 6c 65 74 65 2d 64 75 70 6c 69 63 61 74 65 delete-duplicate
27e0: 73 20 74 65 73 74 2d 6e 61 6d 65 73 29 29 0a 0a s test-names))..
27f0: 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 (debug:print
2800: 2d 69 6e 66 6f 20 30 20 22 74 65 73 74 20 6e 61 -info 0 "test na
2810: 6d 65 73 20 22 20 74 65 73 74 2d 6e 61 6d 65 73 mes " test-names
2820: 29 0a 0a 20 20 20 20 3b 3b 20 6f 6e 20 74 68 65 ).. ;; on the
2830: 20 66 69 72 73 74 20 70 61 73 73 20 6f 72 20 63 first pass or c
2840: 61 6c 6c 20 74 6f 20 72 75 6e 2d 74 65 73 74 73 all to run-tests
2850: 20 73 65 74 20 46 41 49 4c 53 20 74 6f 20 4e 4f set FAILS to NO
2860: 54 5f 53 54 41 52 54 45 44 20 69 66 0a 20 20 20 T_STARTED if.
2870: 20 3b 3b 20 2d 6b 65 65 70 67 6f 69 6e 67 20 69 ;; -keepgoing i
2880: 73 20 73 70 65 63 69 66 69 65 64 0a 20 20 20 20 s specified.
2890: 28 69 66 20 28 65 71 3f 20 2a 70 61 73 73 6e 75 (if (eq? *passnu
28a0: 6d 2a 20 30 29 0a 09 28 62 65 67 69 6e 0a 09 20 m* 0)..(begin..
28b0: 20 3b 3b 20 68 61 76 65 20 74 6f 20 64 65 6c 65 ;; have to dele
28c0: 74 65 20 74 65 73 74 20 72 65 63 6f 72 64 73 20 te test records
28d0: 77 68 65 72 65 20 4e 4f 54 5f 53 54 41 52 54 45 where NOT_STARTE
28e0: 44 20 73 69 6e 63 65 20 74 68 65 79 20 63 61 6e D since they can
28f0: 20 63 61 75 73 65 20 2d 6b 65 65 70 67 6f 69 6e cause -keepgoin
2900: 67 20 74 6f 20 0a 09 20 20 3b 3b 20 67 65 74 20 g to .. ;; get
2910: 73 74 75 63 6b 20 64 75 65 20 74 6f 20 62 65 63 stuck due to bec
2920: 6f 6d 69 6e 67 20 69 6e 61 63 63 65 73 73 69 62 oming inaccessib
2930: 6c 65 20 66 72 6f 6d 20 61 20 66 61 69 6c 65 64 le from a failed
2940: 20 74 65 73 74 2e 20 49 2e 65 2e 20 69 66 20 74 test. I.e. if t
2950: 65 73 74 20 42 20 64 65 70 65 6e 64 73 20 0a 09 est B depends ..
2960: 20 20 3b 3b 20 6f 6e 20 74 65 73 74 20 41 20 62 ;; on test A b
2970: 75 74 20 74 65 73 74 20 42 20 72 65 61 63 68 65 ut test B reache
2980: 64 20 74 68 65 20 70 6f 69 6e 74 20 6f 6e 20 62 d the point on b
2990: 65 69 6e 67 20 72 65 67 69 73 74 65 72 65 64 20 eing registered
29a0: 61 73 20 4e 4f 54 5f 53 54 41 52 54 45 44 20 61 as NOT_STARTED a
29b0: 6e 64 20 74 65 73 74 0a 09 20 20 3b 3b 20 41 20 nd test.. ;; A
29c0: 66 61 69 6c 65 64 20 66 6f 72 20 73 6f 6d 65 20 failed for some
29d0: 72 65 61 73 6f 6e 20 74 68 65 6e 20 6f 6e 20 72 reason then on r
29e0: 65 2d 72 75 6e 20 75 73 69 6e 67 20 2d 6b 65 65 e-run using -kee
29f0: 70 67 6f 69 6e 67 20 74 68 65 20 72 75 6e 20 63 pgoing the run c
2a00: 61 6e 20 6e 65 76 65 72 20 63 6f 6d 70 6c 65 74 an never complet
2a10: 65 2e 0a 09 20 20 28 63 64 62 3a 64 65 6c 65 74 e... (cdb:delet
2a20: 65 2d 74 65 73 74 73 2d 69 6e 2d 73 74 61 74 65 e-tests-in-state
2a30: 20 2a 72 75 6e 72 65 6d 6f 74 65 2a 20 72 75 6e *runremote* run
2a40: 2d 69 64 20 22 4e 4f 54 5f 53 54 41 52 54 45 44 -id "NOT_STARTED
2a50: 22 29 0a 09 20 20 28 63 64 62 3a 72 65 6d 6f 74 ").. (cdb:remot
2a60: 65 2d 72 75 6e 20 64 62 3a 73 65 74 2d 74 65 73 e-run db:set-tes
2a70: 74 73 2d 73 74 61 74 65 2d 73 74 61 74 75 73 20 ts-state-status
2a80: 23 66 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 6e #f run-id test-n
2a90: 61 6d 65 73 20 23 66 20 22 46 41 49 4c 22 20 22 ames #f "FAIL" "
2aa0: 4e 4f 54 5f 53 54 41 52 54 45 44 22 20 22 46 41 NOT_STARTED" "FA
2ab0: 49 4c 22 29 29 29 0a 0a 20 20 20 20 3b 3b 20 66 IL"))).. ;; f
2ac0: 72 6f 6d 20 68 65 72 65 20 6f 6e 20 6f 75 74 20 rom here on out
2ad0: 74 68 65 20 64 62 20 77 69 6c 6c 20 62 65 20 6f the db will be o
2ae0: 70 65 6e 65 64 20 61 6e 64 20 63 6c 6f 73 65 64 pened and closed
2af0: 20 6f 6e 20 65 76 65 72 79 20 63 61 6c 6c 20 72 on every call r
2b00: 75 6e 73 3a 72 75 6e 2d 74 65 73 74 73 2d 71 75 uns:run-tests-qu
2b10: 65 75 65 0a 20 20 20 20 3b 3b 20 28 73 71 6c 69 eue. ;; (sqli
2b20: 74 65 33 3a 66 69 6e 61 6c 69 7a 65 21 20 64 62 te3:finalize! db
2b30: 29 20 0a 20 20 20 20 3b 3b 20 6e 6f 77 20 61 64 ) . ;; now ad
2b40: 64 20 6e 6f 6e 2d 64 69 72 65 63 74 6c 79 20 72 d non-directly r
2b50: 65 66 65 72 65 6e 63 65 64 20 64 65 70 65 6e 64 eferenced depend
2b60: 65 6e 63 69 65 73 20 28 69 2e 65 2e 20 77 61 69 encies (i.e. wai
2b70: 74 6f 6e 29 0a 20 20 20 20 28 69 66 20 28 6e 6f ton). (if (no
2b80: 74 20 28 6e 75 6c 6c 3f 20 74 65 73 74 2d 6e 61 t (null? test-na
2b90: 6d 65 73 29 29 0a 09 28 6c 65 74 20 6c 6f 6f 70 mes))..(let loop
2ba0: 20 28 28 68 65 64 20 28 63 61 72 20 74 65 73 74 ((hed (car test
2bb0: 2d 6e 61 6d 65 73 29 29 0a 09 09 20 20 20 28 74 -names))... (t
2bc0: 61 6c 20 28 63 64 72 20 74 65 73 74 2d 6e 61 6d al (cdr test-nam
2bd0: 65 73 29 29 29 20 20 20 20 20 20 20 20 20 3b 3b es))) ;;
2be0: 20 27 72 65 74 75 72 6e 2d 70 72 6f 63 73 20 74 'return-procs t
2bf0: 65 6c 6c 73 20 74 68 65 20 63 6f 6e 66 69 67 20 ells the config
2c00: 72 65 61 64 65 72 20 74 6f 20 70 72 65 70 20 72 reader to prep r
2c10: 75 6e 6e 69 6e 67 20 73 79 73 74 65 6d 20 62 75 unning system bu
2c20: 74 20 72 65 74 75 72 6e 20 61 20 70 72 6f 63 0a t return a proc.
2c30: 09 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d . (debug:print-
2c40: 69 6e 66 6f 20 34 20 22 68 65 64 3d 22 20 68 65 info 4 "hed=" he
2c50: 64 20 22 20 61 74 20 74 6f 70 20 6f 66 20 6c 6f d " at top of lo
2c60: 6f 70 22 29 0a 09 20 20 28 6c 65 74 2a 20 28 28 op").. (let* ((
2c70: 63 6f 6e 66 69 67 20 20 28 74 65 73 74 73 3a 67 config (tests:g
2c80: 65 74 2d 74 65 73 74 63 6f 6e 66 69 67 20 68 65 et-testconfig he
2c90: 64 20 27 72 65 74 75 72 6e 2d 70 72 6f 63 73 29 d 'return-procs)
2ca0: 29 0a 09 09 20 28 77 61 69 74 6f 6e 73 20 28 6c )... (waitons (l
2cb0: 65 74 20 28 28 69 6e 73 74 72 20 28 69 66 20 63 et ((instr (if c
2cc0: 6f 6e 66 69 67 20 0a 09 09 09 09 09 20 20 20 28 onfig ...... (
2cd0: 63 6f 6e 66 69 67 2d 6c 6f 6f 6b 75 70 20 63 6f config-lookup co
2ce0: 6e 66 69 67 20 22 72 65 71 75 69 72 65 6d 65 6e nfig "requiremen
2cf0: 74 73 22 20 22 77 61 69 74 6f 6e 22 29 0a 09 09 ts" "waiton")...
2d00: 09 09 09 20 20 20 28 62 65 67 69 6e 20 3b 3b 20 ... (begin ;;
2d10: 4e 6f 20 63 6f 6e 66 69 67 20 6d 65 61 6e 73 20 No config means
2d20: 74 68 69 73 20 69 73 20 61 20 6e 6f 6e 2d 65 78 this is a non-ex
2d30: 69 73 74 61 6e 74 20 74 65 73 74 0a 09 09 09 09 istant test.....
2d40: 09 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 . (debug:pri
2d50: 6e 74 20 30 20 22 45 52 52 4f 52 3a 20 6e 6f 6e nt 0 "ERROR: non
2d60: 2d 65 78 69 73 74 65 6e 74 20 72 65 71 75 69 72 -existent requir
2d70: 65 64 20 74 65 73 74 20 5c 22 22 20 68 65 64 20 ed test \"" hed
2d80: 22 5c 22 22 29 0a 09 09 09 09 09 20 20 20 20 20 "\"")......
2d90: 28 69 66 20 64 62 20 28 73 71 6c 69 74 65 33 3a (if db (sqlite3:
2da0: 66 69 6e 61 6c 69 7a 65 21 20 64 62 29 29 0a 09 finalize! db))..
2db0: 09 09 09 09 20 20 20 20 20 28 65 78 69 74 20 31 .... (exit 1
2dc0: 29 29 29 29 29 0a 09 09 09 20 20 20 20 28 64 65 ))))).... (de
2dd0: 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 38 bug:print-info 8
2de0: 20 22 77 61 69 74 6f 6e 73 20 73 74 72 69 6e 67 "waitons string
2df0: 20 69 73 20 22 20 69 6e 73 74 72 29 0a 09 09 09 is " instr)....
2e00: 20 20 20 20 28 73 74 72 69 6e 67 2d 73 70 6c 69 (string-spli
2e10: 74 20 28 63 6f 6e 64 0a 09 09 09 09 09 20 20 20 t (cond......
2e20: 28 28 70 72 6f 63 65 64 75 72 65 3f 20 69 6e 73 ((procedure? ins
2e30: 74 72 29 0a 09 09 09 09 09 20 20 20 20 28 6c 65 tr)...... (le
2e40: 74 20 28 28 72 65 73 20 28 69 6e 73 74 72 29 29 t ((res (instr))
2e50: 29 0a 09 09 09 09 09 20 20 20 20 20 20 28 64 65 )...... (de
2e60: 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 38 bug:print-info 8
2e70: 20 22 77 61 69 74 6f 6e 20 70 72 6f 63 65 64 75 "waiton procedu
2e80: 72 65 20 72 65 73 75 6c 74 73 20 69 6e 20 73 74 re results in st
2e90: 72 69 6e 67 20 22 20 72 65 73 20 22 20 66 6f 72 ring " res " for
2ea0: 20 74 65 73 74 20 22 20 68 65 64 29 0a 09 09 09 test " hed)....
2eb0: 09 09 20 20 20 20 20 20 72 65 73 29 29 0a 09 09 .. res))...
2ec0: 09 09 09 20 20 20 28 28 73 74 72 69 6e 67 3f 20 ... ((string?
2ed0: 69 6e 73 74 72 29 20 20 20 20 20 69 6e 73 74 72 instr) instr
2ee0: 29 0a 09 09 09 09 09 20 20 20 28 65 6c 73 65 20 )...... (else
2ef0: 0a 09 09 09 09 09 20 20 20 20 3b 3b 20 4e 4f 54 ...... ;; NOT
2f00: 45 3a 20 54 68 69 73 20 69 73 20 61 63 74 75 61 E: This is actua
2f10: 6c 6c 79 20 74 68 65 20 63 61 73 65 20 6f 66 20 lly the case of
2f20: 2a 6e 6f 2a 20 77 61 69 74 6f 6e 73 21 20 3b 3b *no* waitons! ;;
2f30: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 (debug:print 0
2f40: 22 45 52 52 4f 52 3a 20 73 6f 6d 65 74 68 69 6e "ERROR: somethin
2f50: 67 20 77 65 6e 74 20 77 72 6f 6e 67 20 69 6e 20 g went wrong in
2f60: 70 72 6f 63 65 73 73 69 6e 67 20 77 61 69 74 6f processing waito
2f70: 6e 73 20 66 6f 72 20 74 65 73 74 20 22 20 68 65 ns for test " he
2f80: 64 29 0a 09 09 09 09 09 20 20 20 20 22 22 29 29 d)...... ""))
2f90: 29 29 29 29 0a 09 20 20 20 20 28 64 65 62 75 67 )))).. (debug
2fa0: 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 38 20 22 77 :print-info 8 "w
2fb0: 61 69 74 6f 6e 73 3a 20 22 20 77 61 69 74 6f 6e aitons: " waiton
2fc0: 73 29 0a 09 20 20 20 20 3b 3b 20 63 68 65 63 6b s).. ;; check
2fd0: 20 66 6f 72 20 68 65 64 20 69 6e 20 77 61 69 74 for hed in wait
2fe0: 6f 6e 73 20 3d 3e 20 74 68 69 73 20 77 6f 75 6c ons => this woul
2ff0: 64 20 62 65 20 63 69 72 63 75 6c 61 72 2c 20 72 d be circular, r
3000: 65 6d 6f 76 65 20 69 74 20 61 6e 64 20 69 73 73 emove it and iss
3010: 75 65 20 61 6e 0a 09 20 20 20 20 3b 3b 20 65 72 ue an.. ;; er
3020: 72 6f 72 0a 09 20 20 20 20 28 69 66 20 28 6d 65 ror.. (if (me
3030: 6d 62 65 72 20 68 65 64 20 77 61 69 74 6f 6e 73 mber hed waitons
3040: 29 0a 09 09 28 62 65 67 69 6e 0a 09 09 20 20 28 )...(begin... (
3050: 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 22 45 debug:print 0 "E
3060: 52 52 4f 52 3a 20 74 65 73 74 20 22 20 68 65 64 RROR: test " hed
3070: 20 22 20 68 61 73 20 6c 69 73 74 65 64 20 69 74 " has listed it
3080: 73 65 6c 66 20 61 73 20 61 20 77 61 69 74 6f 6e self as a waiton
3090: 2c 20 70 6c 65 61 73 65 20 63 6f 72 72 65 63 74 , please correct
30a0: 20 74 68 69 73 21 22 29 0a 09 09 20 20 28 73 65 this!")... (se
30b0: 74 21 20 77 61 69 74 6f 6e 73 20 28 66 69 6c 74 t! waitons (filt
30c0: 65 72 20 28 6c 61 6d 62 64 61 20 28 78 29 28 6e er (lambda (x)(n
30d0: 6f 74 20 28 65 71 75 61 6c 3f 20 78 20 68 65 64 ot (equal? x hed
30e0: 29 29 29 20 77 61 69 74 6f 6e 73 29 29 29 29 0a ))) waitons)))).
30f0: 09 20 20 20 20 0a 09 20 20 20 20 3b 3b 20 28 69 . .. ;; (i
3100: 74 65 6d 73 20 20 20 28 69 74 65 6d 73 3a 67 65 tems (items:ge
3110: 74 2d 69 74 65 6d 73 2d 66 72 6f 6d 2d 63 6f 6e t-items-from-con
3120: 66 69 67 20 63 6f 6e 66 69 67 29 29 29 0a 09 20 fig config)))..
3130: 20 20 20 28 69 66 20 28 6e 6f 74 20 28 68 61 73 (if (not (has
3140: 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 h-table-ref/defa
3150: 75 6c 74 20 74 65 73 74 2d 72 65 63 6f 72 64 73 ult test-records
3160: 20 68 65 64 20 23 66 29 29 0a 09 09 28 68 61 73 hed #f))...(has
3170: 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 74 65 73 h-table-set! tes
3180: 74 2d 72 65 63 6f 72 64 73 0a 09 09 09 09 20 68 t-records..... h
3190: 65 64 20 28 76 65 63 74 6f 72 20 68 65 64 20 20 ed (vector hed
31a0: 20 20 20 3b 3b 20 30 0a 09 09 09 09 09 20 20 20 ;; 0......
31b0: 20 20 63 6f 6e 66 69 67 20 20 3b 3b 20 31 0a 09 config ;; 1..
31c0: 09 09 09 09 20 20 20 20 20 77 61 69 74 6f 6e 73 .... waitons
31d0: 20 3b 3b 20 32 0a 09 09 09 09 09 20 20 20 20 20 ;; 2......
31e0: 28 63 6f 6e 66 69 67 2d 6c 6f 6f 6b 75 70 20 63 (config-lookup c
31f0: 6f 6e 66 69 67 20 22 72 65 71 75 69 72 65 6d 65 onfig "requireme
3200: 6e 74 73 22 20 22 70 72 69 6f 72 69 74 79 22 29 nts" "priority")
3210: 20 20 20 20 20 3b 3b 20 70 72 69 6f 72 69 74 79 ;; priority
3220: 20 33 0a 09 09 09 09 09 20 20 20 20 20 28 6c 65 3...... (le
3230: 74 20 28 28 69 74 65 6d 73 20 20 20 20 20 20 28 t ((items (
3240: 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 hash-table-ref/d
3250: 65 66 61 75 6c 74 20 63 6f 6e 66 69 67 20 22 69 efault config "i
3260: 74 65 6d 73 22 20 23 66 29 29 20 3b 3b 20 69 74 tems" #f)) ;; it
3270: 65 6d 73 20 34 0a 09 09 09 09 09 09 20 20 20 28 ems 4....... (
3280: 69 74 65 6d 73 74 61 62 6c 65 20 28 68 61 73 68 itemstable (hash
3290: 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 -table-ref/defau
32a0: 6c 74 20 63 6f 6e 66 69 67 20 22 69 74 65 6d 73 lt config "items
32b0: 74 61 62 6c 65 22 20 23 66 29 29 29 20 0a 09 09 table" #f))) ...
32c0: 09 09 09 20 20 20 20 20 20 20 3b 3b 20 69 66 20 ... ;; if
32d0: 65 69 74 68 65 72 20 69 74 65 6d 73 20 6f 72 20 either items or
32e0: 69 74 65 6d 73 20 74 61 62 6c 65 20 69 73 20 61 items table is a
32f0: 20 70 72 6f 63 20 72 65 74 75 72 6e 20 69 74 20 proc return it
3300: 73 6f 20 74 65 73 74 20 72 75 6e 6e 69 6e 67 0a so test running.
3310: 09 09 09 09 09 20 20 20 20 20 20 20 3b 3b 20 70 ..... ;; p
3320: 72 6f 63 65 73 73 20 63 61 6e 20 6b 6e 6f 77 20 rocess can know
3330: 74 6f 20 63 61 6c 6c 20 69 74 65 6d 73 3a 67 65 to call items:ge
3340: 74 2d 69 74 65 6d 73 2d 66 72 6f 6d 2d 63 6f 6e t-items-from-con
3350: 66 69 67 0a 09 09 09 09 09 20 20 20 20 20 20 20 fig......
3360: 3b 3b 20 69 66 20 65 69 74 68 65 72 20 69 73 20 ;; if either is
3370: 61 20 6c 69 73 74 20 61 6e 64 20 6e 6f 6e 65 20 a list and none
3380: 69 73 20 61 20 70 72 6f 63 20 67 6f 20 61 68 65 is a proc go ahe
3390: 61 64 20 61 6e 64 20 63 61 6c 6c 20 67 65 74 2d ad and call get-
33a0: 69 74 65 6d 73 0a 09 09 09 09 09 20 20 20 20 20 items......
33b0: 20 20 3b 3b 20 6f 74 68 65 72 77 69 73 65 20 72 ;; otherwise r
33c0: 65 74 75 72 6e 20 23 66 20 2d 20 74 68 69 73 20 eturn #f - this
33d0: 69 73 20 6e 6f 74 20 61 6e 20 69 74 65 72 61 74 is not an iterat
33e0: 65 64 20 74 65 73 74 0a 09 09 09 09 09 20 20 20 ed test......
33f0: 20 20 20 20 28 63 6f 6e 64 0a 09 09 09 09 09 09 (cond.......
3400: 28 28 70 72 6f 63 65 64 75 72 65 3f 20 69 74 65 ((procedure? ite
3410: 6d 73 29 20 20 20 20 20 20 0a 09 09 09 09 09 09 ms) .......
3420: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e (debug:print-in
3430: 66 6f 20 34 20 22 69 74 65 6d 73 20 69 73 20 61 fo 4 "items is a
3440: 20 70 72 6f 63 65 64 75 72 65 2c 20 77 69 6c 6c procedure, will
3450: 20 63 61 6c 63 20 6c 61 74 65 72 22 29 0a 09 09 calc later")...
3460: 09 09 09 09 20 69 74 65 6d 73 29 20 20 20 20 20 .... items)
3470: 20 20 20 20 20 20 20 3b 3b 20 63 61 6c 63 20 6c ;; calc l
3480: 61 74 65 72 0a 09 09 09 09 09 09 28 28 70 72 6f ater.......((pro
3490: 63 65 64 75 72 65 3f 20 69 74 65 6d 73 74 61 62 cedure? itemstab
34a0: 6c 65 29 0a 09 09 09 09 09 09 20 28 64 65 62 75 le)....... (debu
34b0: 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 34 20 22 g:print-info 4 "
34c0: 69 74 65 6d 73 74 61 62 6c 65 20 69 73 20 61 20 itemstable is a
34d0: 70 72 6f 63 65 64 75 72 65 2c 20 77 69 6c 6c 20 procedure, will
34e0: 63 61 6c 63 20 6c 61 74 65 72 22 29 0a 09 09 09 calc later")....
34f0: 09 09 09 20 69 74 65 6d 73 74 61 62 6c 65 29 20 ... itemstable)
3500: 20 20 20 20 20 20 3b 3b 20 63 61 6c 63 20 6c 61 ;; calc la
3510: 74 65 72 0a 09 09 09 09 09 09 28 28 66 69 6c 74 ter.......((filt
3520: 65 72 20 28 6c 61 6d 62 64 61 20 28 78 29 0a 09 er (lambda (x)..
3530: 09 09 09 09 09 09 20 20 20 28 6c 65 74 20 28 28 ...... (let ((
3540: 76 61 6c 20 28 63 61 72 20 78 29 29 29 0a 09 09 val (car x)))...
3550: 09 09 09 09 09 20 20 20 20 20 28 69 66 20 28 70 ..... (if (p
3560: 72 6f 63 65 64 75 72 65 3f 20 76 61 6c 29 20 76 rocedure? val) v
3570: 61 6c 20 23 66 29 29 29 0a 09 09 09 09 09 09 09 al #f)))........
3580: 20 28 61 70 70 65 6e 64 20 28 69 66 20 28 6c 69 (append (if (li
3590: 73 74 3f 20 69 74 65 6d 73 29 20 69 74 65 6d 73 st? items) items
35a0: 20 27 28 29 29 0a 09 09 09 09 09 09 09 09 20 28 '())......... (
35b0: 69 66 20 28 6c 69 73 74 3f 20 69 74 65 6d 73 74 if (list? itemst
35c0: 61 62 6c 65 29 20 69 74 65 6d 73 74 61 62 6c 65 able) itemstable
35d0: 20 27 28 29 29 29 29 0a 09 09 09 09 09 09 20 27 '())))....... '
35e0: 68 61 76 65 2d 70 72 6f 63 65 64 75 72 65 29 0a have-procedure).
35f0: 09 09 09 09 09 09 28 28 6f 72 20 28 6c 69 73 74 ......((or (list
3600: 3f 20 69 74 65 6d 73 29 28 6c 69 73 74 3f 20 69 ? items)(list? i
3610: 74 65 6d 73 74 61 62 6c 65 29 29 20 3b 3b 20 63 temstable)) ;; c
3620: 61 6c 63 20 6e 6f 77 0a 09 09 09 09 09 09 20 28 alc now....... (
3630: 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f debug:print-info
3640: 20 34 20 22 69 74 65 6d 73 20 61 6e 64 20 69 74 4 "items and it
3650: 65 6d 73 74 61 62 6c 65 20 61 72 65 20 6c 69 73 emstable are lis
3660: 74 73 2c 20 63 61 6c 63 20 6e 6f 77 5c 6e 22 0a ts, calc now\n".
3670: 09 09 09 09 09 09 09 20 20 20 20 20 20 22 20 20 ....... "
3680: 20 20 69 74 65 6d 73 3a 20 22 20 69 74 65 6d 73 items: " items
3690: 20 22 20 69 74 65 6d 73 74 61 62 6c 65 3a 20 22 " itemstable: "
36a0: 20 69 74 65 6d 73 74 61 62 6c 65 29 0a 09 09 09 itemstable)....
36b0: 09 09 09 20 28 69 74 65 6d 73 3a 67 65 74 2d 69 ... (items:get-i
36c0: 74 65 6d 73 2d 66 72 6f 6d 2d 63 6f 6e 66 69 67 tems-from-config
36d0: 20 63 6f 6e 66 69 67 29 29 0a 09 09 09 09 09 09 config)).......
36e0: 28 65 6c 73 65 20 23 66 29 29 29 20 20 20 20 20 (else #f)))
36f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3700: 20 20 20 20 20 20 3b 3b 20 6e 6f 74 20 69 74 65 ;; not ite
3710: 72 61 74 65 64 0a 09 09 09 09 09 20 20 20 20 20 rated......
3720: 23 66 20 20 20 20 20 20 3b 3b 20 69 74 65 6d 73 #f ;; items
3730: 64 61 74 20 35 0a 09 09 09 09 09 20 20 20 20 20 dat 5......
3740: 23 66 20 20 20 20 20 20 3b 3b 20 73 70 61 72 65 #f ;; spare
3750: 20 2d 20 75 73 65 64 20 66 6f 72 20 69 74 65 6d - used for item
3760: 2d 70 61 74 68 0a 09 09 09 09 09 20 20 20 20 20 -path......
3770: 29 29 29 0a 09 20 20 20 20 28 66 6f 72 2d 65 61 ))).. (for-ea
3780: 63 68 20 0a 09 20 20 20 20 20 28 6c 61 6d 62 64 ch .. (lambd
3790: 61 20 28 77 61 69 74 6f 6e 29 0a 09 20 20 20 20 a (waiton)..
37a0: 20 20 20 28 69 66 20 28 61 6e 64 20 77 61 69 74 (if (and wait
37b0: 6f 6e 20 28 6e 6f 74 20 28 6d 65 6d 62 65 72 20 on (not (member
37c0: 77 61 69 74 6f 6e 20 74 65 73 74 2d 6e 61 6d 65 waiton test-name
37d0: 73 29 29 29 0a 09 09 20 20 20 28 62 65 67 69 6e s)))... (begin
37e0: 0a 09 09 20 20 20 20 20 28 73 65 74 21 20 72 65 ... (set! re
37f0: 71 75 69 72 65 64 2d 74 65 73 74 73 20 28 63 6f quired-tests (co
3800: 6e 73 20 77 61 69 74 6f 6e 20 72 65 71 75 69 72 ns waiton requir
3810: 65 64 2d 74 65 73 74 73 29 29 0a 09 09 20 20 20 ed-tests))...
3820: 20 20 28 73 65 74 21 20 74 65 73 74 2d 6e 61 6d (set! test-nam
3830: 65 73 20 28 63 6f 6e 73 20 77 61 69 74 6f 6e 20 es (cons waiton
3840: 74 65 73 74 2d 6e 61 6d 65 73 29 29 29 29 29 20 test-names)))))
3850: 3b 3b 20 77 61 73 20 61 6e 20 61 70 70 65 6e 64 ;; was an append
3860: 2c 20 6e 6f 77 20 61 20 63 6f 6e 73 0a 09 20 20 , now a cons..
3870: 20 20 20 77 61 69 74 6f 6e 73 29 0a 09 20 20 20 waitons)..
3880: 20 28 6c 65 74 20 28 28 72 65 6d 74 65 73 74 73 (let ((remtests
3890: 20 28 64 65 6c 65 74 65 2d 64 75 70 6c 69 63 61 (delete-duplica
38a0: 74 65 73 20 28 61 70 70 65 6e 64 20 77 61 69 74 tes (append wait
38b0: 6f 6e 73 20 74 61 6c 29 29 29 29 0a 09 20 20 20 ons tal))))..
38c0: 20 20 20 28 69 66 20 28 6e 6f 74 20 28 6e 75 6c (if (not (nul
38d0: 6c 3f 20 72 65 6d 74 65 73 74 73 29 29 0a 09 09 l? remtests))...
38e0: 20 20 28 6c 6f 6f 70 20 28 63 61 72 20 72 65 6d (loop (car rem
38f0: 74 65 73 74 73 29 28 63 64 72 20 72 65 6d 74 65 tests)(cdr remte
3900: 73 74 73 29 29 29 29 29 29 29 0a 0a 20 20 20 20 sts)))))))..
3910: 28 69 66 20 28 6e 6f 74 20 28 6e 75 6c 6c 3f 20 (if (not (null?
3920: 72 65 71 75 69 72 65 64 2d 74 65 73 74 73 29 29 required-tests))
3930: 0a 09 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 ..(debug:print-i
3940: 6e 66 6f 20 31 20 22 41 64 64 69 6e 67 20 22 20 nfo 1 "Adding "
3950: 72 65 71 75 69 72 65 64 2d 74 65 73 74 73 20 22 required-tests "
3960: 20 74 6f 20 74 68 65 20 72 75 6e 20 71 75 65 75 to the run queu
3970: 65 22 29 29 0a 20 20 20 20 3b 3b 20 4e 4f 54 45 e")). ;; NOTE
3980: 3a 20 74 68 65 73 65 20 61 72 65 20 61 6c 6c 20 : these are all
3990: 70 61 72 65 6e 74 20 74 65 73 74 73 2c 20 69 74 parent tests, it
39a0: 65 6d 73 20 61 72 65 20 6e 6f 74 20 65 78 70 61 ems are not expa
39b0: 6e 64 65 64 20 79 65 74 2e 0a 20 20 20 20 28 64 nded yet.. (d
39c0: 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 ebug:print-info
39d0: 34 20 22 74 65 73 74 2d 72 65 63 6f 72 64 73 3d 4 "test-records=
39e0: 22 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 3e 61 " (hash-table->a
39f0: 6c 69 73 74 20 74 65 73 74 2d 72 65 63 6f 72 64 list test-record
3a00: 73 29 29 0a 20 20 20 20 28 72 75 6e 73 3a 72 75 s)). (runs:ru
3a10: 6e 2d 74 65 73 74 73 2d 71 75 65 75 65 20 72 75 n-tests-queue ru
3a20: 6e 2d 69 64 20 72 75 6e 6e 61 6d 65 20 74 65 73 n-id runname tes
3a30: 74 2d 72 65 63 6f 72 64 73 20 6b 65 79 76 61 6c t-records keyval
3a40: 6c 73 74 20 66 6c 61 67 73 20 74 65 73 74 2d 70 lst flags test-p
3a50: 61 74 74 73 29 0a 20 20 20 20 28 64 65 62 75 67 atts). (debug
3a60: 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 34 20 22 41 :print-info 4 "A
3a70: 6c 6c 20 64 6f 6e 65 20 62 79 20 68 65 72 65 22 ll done by here"
3a80: 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 72 75 )))..(define (ru
3a90: 6e 73 3a 63 61 6c 63 2d 66 61 69 6c 73 20 70 72 ns:calc-fails pr
3aa0: 65 72 65 71 73 2d 6e 6f 74 2d 6d 65 74 29 0a 20 ereqs-not-met).
3ab0: 20 28 66 69 6c 74 65 72 20 28 6c 61 6d 62 64 61 (filter (lambda
3ac0: 20 28 74 65 73 74 29 0a 09 20 20 20 20 28 61 6e (test).. (an
3ad0: 64 20 28 76 65 63 74 6f 72 3f 20 74 65 73 74 29 d (vector? test)
3ae0: 20 3b 3b 20 6e 6f 74 20 28 73 74 72 69 6e 67 3f ;; not (string?
3af0: 20 74 65 73 74 29 29 0a 09 09 20 28 65 71 75 61 test))... (equa
3b00: 6c 3f 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d l? (db:test-get-
3b10: 73 74 61 74 65 20 74 65 73 74 29 20 22 43 4f 4d state test) "COM
3b20: 50 4c 45 54 45 44 22 29 0a 09 09 20 28 6e 6f 74 PLETED")... (not
3b30: 20 28 6d 65 6d 62 65 72 20 28 64 62 3a 74 65 73 (member (db:tes
3b40: 74 2d 67 65 74 2d 73 74 61 74 75 73 20 74 65 73 t-get-status tes
3b50: 74 29 0a 09 09 09 20 20 20 20 20 20 27 28 22 50 t).... '("P
3b60: 41 53 53 22 20 22 57 41 52 4e 22 20 22 43 48 45 ASS" "WARN" "CHE
3b70: 43 4b 22 20 22 57 41 49 56 45 44 22 29 29 29 29 CK" "WAIVED"))))
3b80: 29 0a 09 20 20 70 72 65 72 65 71 73 2d 6e 6f 74 ).. prereqs-not
3b90: 2d 6d 65 74 29 29 0a 0a 28 64 65 66 69 6e 65 20 -met))..(define
3ba0: 28 72 75 6e 73 3a 63 61 6c 63 2d 6e 6f 74 2d 63 (runs:calc-not-c
3bb0: 6f 6d 70 6c 65 74 65 64 20 70 72 65 72 65 71 73 ompleted prereqs
3bc0: 2d 6e 6f 74 2d 6d 65 74 29 0a 20 20 28 66 69 6c -not-met). (fil
3bd0: 74 65 72 0a 20 20 20 28 6c 61 6d 62 64 61 20 28 ter. (lambda (
3be0: 74 29 0a 20 20 20 20 20 28 6f 72 20 28 6e 6f 74 t). (or (not
3bf0: 20 28 76 65 63 74 6f 72 3f 20 74 29 29 0a 09 20 (vector? t))..
3c00: 28 6e 6f 74 20 28 65 71 75 61 6c 3f 20 22 43 4f (not (equal? "CO
3c10: 4d 50 4c 45 54 45 44 22 20 28 64 62 3a 74 65 73 MPLETED" (db:tes
3c20: 74 2d 67 65 74 2d 73 74 61 74 65 20 74 29 29 29 t-get-state t)))
3c30: 29 29 0a 20 20 20 70 72 65 72 65 71 73 2d 6e 6f )). prereqs-no
3c40: 74 2d 6d 65 74 29 29 0a 0a 28 64 65 66 69 6e 65 t-met))..(define
3c50: 20 28 72 75 6e 73 3a 70 72 65 74 74 79 2d 73 74 (runs:pretty-st
3c60: 72 69 6e 67 20 6c 73 74 29 0a 20 20 28 6d 61 70 ring lst). (map
3c70: 20 28 6c 61 6d 62 64 61 20 28 74 29 0a 09 20 28 (lambda (t).. (
3c80: 69 66 20 28 6e 6f 74 20 28 76 65 63 74 6f 72 3f if (not (vector?
3c90: 20 74 29 29 0a 09 20 20 20 20 20 28 63 6f 6e 63 t)).. (conc
3ca0: 20 74 29 0a 09 20 20 20 20 20 28 63 6f 6e 63 20 t).. (conc
3cb0: 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 74 65 73 (db:test-get-tes
3cc0: 74 6e 61 6d 65 20 74 29 20 22 3a 22 20 28 64 62 tname t) ":" (db
3cd0: 3a 74 65 73 74 2d 67 65 74 2d 73 74 61 74 65 20 :test-get-state
3ce0: 74 29 20 22 2f 22 20 28 64 62 3a 74 65 73 74 2d t) "/" (db:test-
3cf0: 67 65 74 2d 73 74 61 74 75 73 20 74 29 29 29 29 get-status t))))
3d00: 0a 20 20 20 20 20 20 20 6c 73 74 29 29 0a 0a 28 . lst))..(
3d10: 64 65 66 69 6e 65 20 28 72 75 6e 73 3a 6d 61 6b define (runs:mak
3d20: 65 2d 66 75 6c 6c 2d 74 65 73 74 2d 6e 61 6d 65 e-full-test-name
3d30: 20 74 65 73 74 6e 61 6d 65 20 69 74 65 6d 70 61 testname itempa
3d40: 74 68 29 0a 20 20 28 69 66 20 28 65 71 75 61 6c th). (if (equal
3d50: 3f 20 69 74 65 6d 70 61 74 68 20 22 22 29 20 74 ? itempath "") t
3d60: 65 73 74 6e 61 6d 65 20 28 63 6f 6e 63 20 74 65 estname (conc te
3d70: 73 74 6e 61 6d 65 20 22 2f 22 20 69 74 65 6d 70 stname "/" itemp
3d80: 61 74 68 29 29 29 0a 0a 3b 3b 20 74 65 73 74 2d ath)))..;; test-
3d90: 72 65 63 6f 72 64 73 20 69 73 20 61 20 68 61 73 records is a has
3da0: 68 20 74 61 62 6c 65 20 74 65 73 74 6e 61 6d 65 h table testname
3db0: 3a 69 74 65 6d 5f 70 61 74 68 20 3d 3e 20 76 65 :item_path => ve
3dc0: 63 74 6f 72 20 3c 20 74 65 73 74 6e 61 6d 65 20 ctor < testname
3dd0: 74 65 73 74 63 6f 6e 66 69 67 20 77 61 69 74 6f testconfig waito
3de0: 6e 73 20 70 72 69 6f 72 69 74 79 20 69 74 65 6d ns priority item
3df0: 73 2d 69 6e 66 6f 20 2e 2e 2e 20 3e 0a 28 64 65 s-info ... >.(de
3e00: 66 69 6e 65 20 28 72 75 6e 73 3a 72 75 6e 2d 74 fine (runs:run-t
3e10: 65 73 74 73 2d 71 75 65 75 65 20 72 75 6e 2d 69 ests-queue run-i
3e20: 64 20 72 75 6e 6e 61 6d 65 20 74 65 73 74 2d 72 d runname test-r
3e30: 65 63 6f 72 64 73 20 6b 65 79 76 61 6c 6c 73 74 ecords keyvallst
3e40: 20 66 6c 61 67 73 20 74 65 73 74 2d 70 61 74 74 flags test-patt
3e50: 73 29 0a 20 20 20 20 3b 3b 20 41 74 20 74 68 69 s). ;; At thi
3e60: 73 20 70 6f 69 6e 74 20 74 68 65 20 6c 69 73 74 s point the list
3e70: 20 6f 66 20 70 61 72 65 6e 74 20 74 65 73 74 73 of parent tests
3e80: 20 69 73 20 65 78 70 61 6e 64 65 64 20 0a 20 20 is expanded .
3e90: 20 20 3b 3b 20 4e 42 2f 2f 20 53 68 6f 75 6c 64 ;; NB// Should
3ea0: 20 65 78 70 61 6e 64 20 69 74 65 6d 73 20 68 65 expand items he
3eb0: 72 65 20 61 6e 64 20 74 68 65 6e 20 69 6e 73 65 re and then inse
3ec0: 72 74 20 69 6e 74 6f 20 74 68 65 20 72 75 6e 20 rt into the run
3ed0: 71 75 65 75 65 2e 0a 20 20 28 64 65 62 75 67 3a queue.. (debug:
3ee0: 70 72 69 6e 74 20 35 20 22 74 65 73 74 2d 72 65 print 5 "test-re
3ef0: 63 6f 72 64 73 3a 20 22 20 74 65 73 74 2d 72 65 cords: " test-re
3f00: 63 6f 72 64 73 20 22 2c 20 6b 65 79 76 61 6c 6c cords ", keyvall
3f10: 73 74 3a 20 22 20 6b 65 79 76 61 6c 6c 73 74 20 st: " keyvallst
3f20: 22 20 66 6c 61 67 73 3a 20 22 20 28 68 61 73 68 " flags: " (hash
3f30: 2d 74 61 62 6c 65 2d 3e 61 6c 69 73 74 20 66 6c -table->alist fl
3f40: 61 67 73 29 29 0a 20 20 28 6c 65 74 20 28 28 73 ags)). (let ((s
3f50: 6f 72 74 65 64 2d 74 65 73 74 2d 6e 61 6d 65 73 orted-test-names
3f60: 20 28 74 65 73 74 73 3a 73 6f 72 74 2d 62 79 2d (tests:sort-by-
3f70: 70 72 69 6f 72 69 74 79 2d 61 6e 64 2d 77 61 69 priority-and-wai
3f80: 74 6f 6e 20 74 65 73 74 2d 72 65 63 6f 72 64 73 ton test-records
3f90: 29 29 0a 09 28 74 65 73 74 2d 72 65 67 69 73 74 ))..(test-regist
3fa0: 65 72 79 20 20 20 20 28 6d 61 6b 65 2d 68 61 73 ery (make-has
3fb0: 68 2d 74 61 62 6c 65 29 29 0a 09 28 6e 75 6d 2d h-table))..(num-
3fc0: 72 65 74 72 69 65 73 20 20 20 20 20 20 20 20 30 retries 0
3fd0: 29 0a 09 28 6d 61 78 2d 72 65 74 72 69 65 73 20 )..(max-retries
3fe0: 20 20 20 20 20 20 28 63 6f 6e 66 69 67 2d 6c 6f (config-lo
3ff0: 6f 6b 75 70 20 2a 63 6f 6e 66 69 67 64 61 74 2a okup *configdat*
4000: 20 22 73 65 74 75 70 22 20 22 6d 61 78 72 65 74 "setup" "maxret
4010: 72 69 65 73 22 29 29 29 0a 20 20 20 20 28 73 65 ries"))). (se
4020: 74 21 20 6d 61 78 2d 72 65 74 72 69 65 73 20 28 t! max-retries (
4030: 69 66 20 28 61 6e 64 20 6d 61 78 2d 72 65 74 72 if (and max-retr
4040: 69 65 73 20 28 73 74 72 69 6e 67 2d 3e 6e 75 6d ies (string->num
4050: 62 65 72 20 6d 61 78 2d 72 65 74 72 69 65 73 29 ber max-retries)
4060: 29 28 73 74 72 69 6e 67 2d 3e 6e 75 6d 62 65 72 )(string->number
4070: 20 6d 61 78 2d 72 65 74 72 69 65 73 29 20 31 30 max-retries) 10
4080: 30 29 29 0a 20 20 20 20 28 69 66 20 28 6e 6f 74 0)). (if (not
4090: 20 28 6e 75 6c 6c 3f 20 73 6f 72 74 65 64 2d 74 (null? sorted-t
40a0: 65 73 74 2d 6e 61 6d 65 73 29 29 0a 09 28 6c 65 est-names))..(le
40b0: 74 20 6c 6f 6f 70 20 28 28 68 65 64 20 20 20 20 t loop ((hed
40c0: 20 20 20 20 20 28 63 61 72 20 73 6f 72 74 65 64 (car sorted
40d0: 2d 74 65 73 74 2d 6e 61 6d 65 73 29 29 0a 09 09 -test-names))...
40e0: 20 20 20 28 74 61 6c 20 20 20 20 20 20 20 20 20 (tal
40f0: 28 63 64 72 20 73 6f 72 74 65 64 2d 74 65 73 74 (cdr sorted-test
4100: 2d 6e 61 6d 65 73 29 29 0a 09 09 20 20 20 28 72 -names))... (r
4110: 65 72 75 6e 73 20 20 20 20 20 20 27 28 29 29 29 eruns '()))
4120: 0a 09 20 20 28 69 66 20 28 6e 6f 74 20 28 6e 75 .. (if (not (nu
4130: 6c 6c 3f 20 72 65 72 75 6e 73 29 29 28 64 65 62 ll? reruns))(deb
4140: 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 34 20 ug:print-info 4
4150: 22 72 65 72 75 6e 73 3d 22 20 72 65 72 75 6e 73 "reruns=" reruns
4160: 29 29 0a 09 20 20 3b 3b 20 28 70 72 69 6e 74 20 )).. ;; (print
4170: 22 54 6f 70 20 6f 66 20 6c 6f 6f 70 2c 20 68 65 "Top of loop, he
4180: 64 3d 22 20 68 65 64 20 22 2c 20 74 61 6c 3d 22 d=" hed ", tal="
4190: 20 74 61 6c 20 22 20 2c 72 65 72 75 6e 73 3d 22 tal " ,reruns="
41a0: 20 72 65 72 75 6e 73 29 0a 09 20 20 28 6c 65 74 reruns).. (let
41b0: 2a 20 28 28 74 65 73 74 2d 72 65 63 6f 72 64 20 * ((test-record
41c0: 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 20 (hash-table-ref
41d0: 74 65 73 74 2d 72 65 63 6f 72 64 73 20 68 65 64 test-records hed
41e0: 29 29 0a 09 09 20 28 74 65 73 74 2d 6e 61 6d 65 ))... (test-name
41f0: 20 20 20 28 74 65 73 74 73 3a 74 65 73 74 71 75 (tests:testqu
4200: 65 75 65 2d 67 65 74 2d 74 65 73 74 6e 61 6d 65 eue-get-testname
4210: 20 74 65 73 74 2d 72 65 63 6f 72 64 29 29 0a 09 test-record))..
4220: 09 20 28 74 63 6f 6e 66 69 67 20 20 20 20 20 28 . (tconfig (
4230: 74 65 73 74 73 3a 74 65 73 74 71 75 65 75 65 2d tests:testqueue-
4240: 67 65 74 2d 74 65 73 74 63 6f 6e 66 69 67 20 74 get-testconfig t
4250: 65 73 74 2d 72 65 63 6f 72 64 29 29 0a 09 09 20 est-record))...
4260: 28 74 65 73 74 6d 6f 64 65 20 20 20 20 28 6c 65 (testmode (le
4270: 74 20 28 28 6d 20 28 63 6f 6e 66 69 67 2d 6c 6f t ((m (config-lo
4280: 6f 6b 75 70 20 74 63 6f 6e 66 69 67 20 22 72 65 okup tconfig "re
4290: 71 75 69 72 65 6d 65 6e 74 73 22 20 22 6d 6f 64 quirements" "mod
42a0: 65 22 29 29 29 0a 09 09 09 09 28 69 66 20 6d 20 e"))).....(if m
42b0: 28 73 74 72 69 6e 67 2d 3e 73 79 6d 62 6f 6c 20 (string->symbol
42c0: 6d 29 20 27 6e 6f 72 6d 61 6c 29 29 29 0a 09 09 m) 'normal)))...
42d0: 20 28 77 61 69 74 6f 6e 73 20 20 20 20 20 28 74 (waitons (t
42e0: 65 73 74 73 3a 74 65 73 74 71 75 65 75 65 2d 67 ests:testqueue-g
42f0: 65 74 2d 77 61 69 74 6f 6e 73 20 20 20 20 74 65 et-waitons te
4300: 73 74 2d 72 65 63 6f 72 64 29 29 0a 09 09 20 28 st-record))... (
4310: 70 72 69 6f 72 69 74 79 20 20 20 20 28 74 65 73 priority (tes
4320: 74 73 3a 74 65 73 74 71 75 65 75 65 2d 67 65 74 ts:testqueue-get
4330: 2d 70 72 69 6f 72 69 74 79 20 20 20 74 65 73 74 -priority test
4340: 2d 72 65 63 6f 72 64 29 29 0a 09 09 20 28 69 74 -record))... (it
4350: 65 6d 64 61 74 20 20 20 20 20 28 74 65 73 74 73 emdat (tests
4360: 3a 74 65 73 74 71 75 65 75 65 2d 67 65 74 2d 69 :testqueue-get-i
4370: 74 65 6d 64 61 74 20 20 20 20 74 65 73 74 2d 72 temdat test-r
4380: 65 63 6f 72 64 29 29 20 3b 3b 20 69 74 65 6d 64 ecord)) ;; itemd
4390: 61 74 20 63 61 6e 20 62 65 20 61 20 73 74 72 69 at can be a stri
43a0: 6e 67 2c 20 6c 69 73 74 20 6f 72 20 23 66 0a 09 ng, list or #f..
43b0: 09 20 28 69 74 65 6d 73 20 20 20 20 20 20 20 28 . (items (
43c0: 74 65 73 74 73 3a 74 65 73 74 71 75 65 75 65 2d tests:testqueue-
43d0: 67 65 74 2d 69 74 65 6d 73 20 20 20 20 20 20 74 get-items t
43e0: 65 73 74 2d 72 65 63 6f 72 64 29 29 0a 09 09 20 est-record))...
43f0: 28 69 74 65 6d 2d 70 61 74 68 20 20 20 28 69 74 (item-path (it
4400: 65 6d 2d 6c 69 73 74 2d 3e 70 61 74 68 20 69 74 em-list->path it
4410: 65 6d 64 61 74 29 29 0a 09 09 20 28 6e 65 77 74 emdat))... (newt
4420: 61 6c 20 20 20 20 20 20 28 61 70 70 65 6e 64 20 al (append
4430: 74 61 6c 20 28 6c 69 73 74 20 68 65 64 29 29 29 tal (list hed)))
4440: 29 0a 09 20 20 20 20 0a 09 20 20 20 20 28 64 65 ).. .. (de
4450: 62 75 67 3a 70 72 69 6e 74 20 36 0a 09 09 09 20 bug:print 6....
4460: 22 74 65 73 74 2d 6e 61 6d 65 3a 20 22 20 74 65 "test-name: " te
4470: 73 74 2d 6e 61 6d 65 0a 09 09 09 20 22 5c 6e 20 st-name.... "\n
4480: 20 68 65 64 3a 20 20 20 20 20 20 20 20 20 22 20 hed: "
4490: 68 65 64 0a 09 09 09 20 22 5c 6e 20 20 69 74 65 hed.... "\n ite
44a0: 6d 64 61 74 3a 20 20 20 20 20 22 20 69 74 65 6d mdat: " item
44b0: 64 61 74 0a 09 09 09 20 22 5c 6e 20 20 69 74 65 dat.... "\n ite
44c0: 6d 73 3a 20 20 20 20 20 20 20 22 20 69 74 65 6d ms: " item
44d0: 73 0a 09 09 09 20 22 5c 6e 20 20 69 74 65 6d 2d s.... "\n item-
44e0: 70 61 74 68 3a 20 20 20 22 20 69 74 65 6d 2d 70 path: " item-p
44f0: 61 74 68 0a 09 09 09 20 22 5c 6e 20 20 77 61 69 ath.... "\n wai
4500: 74 6f 6e 73 3a 20 20 20 20 20 22 20 77 61 69 74 tons: " wait
4510: 6f 6e 73 0a 09 09 09 20 22 5c 6e 20 20 6e 75 6d ons.... "\n num
4520: 2d 72 65 74 72 69 65 73 3a 20 22 20 6e 75 6d 2d -retries: " num-
4530: 72 65 74 72 69 65 73 0a 09 09 09 20 22 5c 6e 20 retries.... "\n
4540: 20 74 61 6c 3a 20 20 20 20 20 20 20 20 20 22 20 tal: "
4550: 74 61 6c 0a 09 09 09 20 22 5c 6e 20 20 72 65 72 tal.... "\n rer
4560: 75 6e 73 3a 20 20 20 20 20 20 22 20 72 65 72 75 uns: " reru
4570: 6e 73 29 0a 0a 09 20 20 20 20 3b 3b 20 63 68 65 ns)... ;; che
4580: 63 6b 20 66 6f 72 20 68 65 64 20 69 6e 20 77 61 ck for hed in wa
4590: 69 74 6f 6e 73 20 3d 3e 20 74 68 69 73 20 77 6f itons => this wo
45a0: 75 6c 64 20 62 65 20 63 69 72 63 75 6c 61 72 2c uld be circular,
45b0: 20 72 65 6d 6f 76 65 20 69 74 20 61 6e 64 20 69 remove it and i
45c0: 73 73 75 65 20 61 6e 0a 09 20 20 20 20 3b 3b 20 ssue an.. ;;
45d0: 65 72 72 6f 72 0a 09 20 20 20 20 28 69 66 20 28 error.. (if (
45e0: 6d 65 6d 62 65 72 20 74 65 73 74 2d 6e 61 6d 65 member test-name
45f0: 20 77 61 69 74 6f 6e 73 29 0a 09 09 28 62 65 67 waitons)...(beg
4600: 69 6e 0a 09 09 20 20 28 64 65 62 75 67 3a 70 72 in... (debug:pr
4610: 69 6e 74 20 30 20 22 45 52 52 4f 52 3a 20 74 65 int 0 "ERROR: te
4620: 73 74 20 22 20 74 65 73 74 2d 6e 61 6d 65 20 22 st " test-name "
4630: 20 68 61 73 20 6c 69 73 74 65 64 20 69 74 73 65 has listed itse
4640: 6c 66 20 61 73 20 61 20 77 61 69 74 6f 6e 2c 20 lf as a waiton,
4650: 70 6c 65 61 73 65 20 63 6f 72 72 65 63 74 20 74 please correct t
4660: 68 69 73 21 22 29 0a 09 09 20 20 28 73 65 74 21 his!")... (set!
4670: 20 77 61 69 74 6f 6e 20 28 66 69 6c 74 65 72 20 waiton (filter
4680: 28 6c 61 6d 62 64 61 20 28 78 29 28 6e 6f 74 20 (lambda (x)(not
4690: 28 65 71 75 61 6c 3f 20 78 20 68 65 64 29 29 29 (equal? x hed)))
46a0: 20 77 61 69 74 6f 6e 73 29 29 29 29 0a 0a 09 20 waitons))))...
46b0: 20 20 20 28 63 6f 6e 64 20 3b 3b 20 4f 55 54 45 (cond ;; OUTE
46c0: 52 20 43 4f 4e 44 0a 09 20 20 20 20 20 28 28 6e R COND.. ((n
46d0: 6f 74 20 69 74 65 6d 73 29 20 3b 3b 20 77 68 65 ot items) ;; whe
46e0: 6e 20 66 61 6c 73 65 20 74 68 65 20 74 65 73 74 n false the test
46f0: 20 69 73 20 6f 6b 20 74 6f 20 62 65 20 68 61 6e is ok to be han
4700: 64 65 64 20 6f 66 66 20 74 6f 20 6c 61 75 6e 63 ded off to launc
4710: 68 20 28 62 75 74 20 6e 6f 74 20 62 65 66 6f 72 h (but not befor
4720: 65 29 0a 09 20 20 20 20 20 20 28 6c 65 74 2a 20 e).. (let*
4730: 28 28 72 75 6e 2d 6c 69 6d 69 74 73 2d 69 6e 66 ((run-limits-inf
4740: 6f 20 20 20 20 20 20 20 20 20 28 6f 70 65 6e 2d o (open-
4750: 72 75 6e 2d 63 6c 6f 73 65 20 72 75 6e 73 3a 63 run-close runs:c
4760: 61 6e 2d 72 75 6e 2d 6d 6f 72 65 2d 74 65 73 74 an-run-more-test
4770: 73 20 74 65 73 74 2d 72 65 63 6f 72 64 29 29 20 s test-record))
4780: 3b 3b 20 6c 6f 6f 6b 20 61 74 20 74 68 65 20 74 ;; look at the t
4790: 65 73 74 20 6a 6f 62 67 72 6f 75 70 20 61 6e 64 est jobgroup and
47a0: 20 74 6f 74 20 6a 6f 62 73 20 72 75 6e 6e 69 6e tot jobs runnin
47b0: 67 0a 09 09 20 20 20 20 20 28 68 61 76 65 2d 72 g... (have-r
47c0: 65 73 6f 75 72 63 65 73 20 20 20 20 20 20 20 20 esources
47d0: 20 20 28 63 61 72 20 72 75 6e 2d 6c 69 6d 69 74 (car run-limit
47e0: 73 2d 69 6e 66 6f 29 29 0a 09 09 20 20 20 20 20 s-info))...
47f0: 28 6e 75 6d 2d 72 75 6e 6e 69 6e 67 20 20 20 20 (num-running
4800: 20 20 20 20 20 20 20 20 20 28 6c 69 73 74 2d 72 (list-r
4810: 65 66 20 72 75 6e 2d 6c 69 6d 69 74 73 2d 69 6e ef run-limits-in
4820: 66 6f 20 31 29 29 0a 09 09 20 20 20 20 20 28 6e fo 1))... (n
4830: 75 6d 2d 72 75 6e 6e 69 6e 67 2d 69 6e 2d 6a 6f um-running-in-jo
4840: 62 67 72 6f 75 70 20 28 6c 69 73 74 2d 72 65 66 bgroup (list-ref
4850: 20 72 75 6e 2d 6c 69 6d 69 74 73 2d 69 6e 66 6f run-limits-info
4860: 20 32 29 29 0a 09 09 20 20 20 20 20 28 6d 61 78 2))... (max
4870: 2d 63 6f 6e 63 75 72 72 65 6e 74 2d 6a 6f 62 73 -concurrent-jobs
4880: 20 20 20 20 20 28 6c 69 73 74 2d 72 65 66 20 72 (list-ref r
4890: 75 6e 2d 6c 69 6d 69 74 73 2d 69 6e 66 6f 20 33 un-limits-info 3
48a0: 29 29 0a 09 09 20 20 20 20 20 28 6a 6f 62 2d 67 ))... (job-g
48b0: 72 6f 75 70 2d 6c 69 6d 69 74 20 20 20 20 20 20 roup-limit
48c0: 20 20 20 28 6c 69 73 74 2d 72 65 66 20 72 75 6e (list-ref run
48d0: 2d 6c 69 6d 69 74 73 2d 69 6e 66 6f 20 34 29 29 -limits-info 4))
48e0: 0a 09 09 20 20 20 20 20 28 70 72 65 72 65 71 73 ... (prereqs
48f0: 2d 6e 6f 74 2d 6d 65 74 20 20 20 20 20 20 20 20 -not-met
4900: 20 28 6f 70 65 6e 2d 72 75 6e 2d 63 6c 6f 73 65 (open-run-close
4910: 20 64 62 3a 67 65 74 2d 70 72 65 72 65 71 73 2d db:get-prereqs-
4920: 6e 6f 74 2d 6d 65 74 20 23 66 20 72 75 6e 2d 69 not-met #f run-i
4930: 64 20 77 61 69 74 6f 6e 73 20 69 74 65 6d 2d 70 d waitons item-p
4940: 61 74 68 20 6d 6f 64 65 3a 20 74 65 73 74 6d 6f ath mode: testmo
4950: 64 65 29 29 0a 09 09 20 20 20 20 20 28 66 61 69 de))... (fai
4960: 6c 73 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ls
4970: 20 20 20 20 20 28 72 75 6e 73 3a 63 61 6c 63 2d (runs:calc-
4980: 66 61 69 6c 73 20 70 72 65 72 65 71 73 2d 6e 6f fails prereqs-no
4990: 74 2d 6d 65 74 29 29 0a 09 09 20 20 20 20 20 28 t-met))... (
49a0: 6e 6f 6e 2d 63 6f 6d 70 6c 65 74 65 64 20 20 20 non-completed
49b0: 20 20 20 20 20 20 20 20 28 72 75 6e 73 3a 63 61 (runs:ca
49c0: 6c 63 2d 6e 6f 74 2d 63 6f 6d 70 6c 65 74 65 64 lc-not-completed
49d0: 20 70 72 65 72 65 71 73 2d 6e 6f 74 2d 6d 65 74 prereqs-not-met
49e0: 29 29 29 0a 09 09 28 64 65 62 75 67 3a 70 72 69 )))...(debug:pri
49f0: 6e 74 2d 69 6e 66 6f 20 38 20 22 68 61 76 65 2d nt-info 8 "have-
4a00: 72 65 73 6f 75 72 63 65 73 3a 20 22 20 68 61 76 resources: " hav
4a10: 65 2d 72 65 73 6f 75 72 63 65 73 20 22 20 70 72 e-resources " pr
4a20: 65 72 65 71 73 2d 6e 6f 74 2d 6d 65 74 3a 20 22 ereqs-not-met: "
4a30: 20 0a 09 09 09 20 20 20 20 20 28 73 74 72 69 6e .... (strin
4a40: 67 2d 69 6e 74 65 72 73 70 65 72 73 65 20 0a 09 g-intersperse ..
4a50: 09 09 20 20 20 20 20 20 28 6d 61 70 20 28 6c 61 .. (map (la
4a60: 6d 62 64 61 20 28 74 29 0a 09 09 09 09 20 20 20 mbda (t).....
4a70: 20 20 28 69 66 20 28 76 65 63 74 6f 72 3f 20 74 (if (vector? t
4a80: 29 0a 09 09 09 09 09 20 28 63 6f 6e 63 20 28 64 )...... (conc (d
4a90: 62 3a 74 65 73 74 2d 67 65 74 2d 73 74 61 74 65 b:test-get-state
4aa0: 20 74 29 20 22 2f 22 20 28 64 62 3a 74 65 73 74 t) "/" (db:test
4ab0: 2d 67 65 74 2d 73 74 61 74 75 73 20 74 29 29 0a -get-status t)).
4ac0: 09 09 09 09 09 20 28 63 6f 6e 63 20 22 20 57 41 ..... (conc " WA
4ad0: 52 4e 49 4e 47 3a 20 74 20 69 73 20 6e 6f 74 20 RNING: t is not
4ae0: 61 20 76 65 63 74 6f 72 3d 22 20 74 20 29 29 29 a vector=" t )))
4af0: 0a 09 09 09 09 20 20 20 70 72 65 72 65 71 73 2d ..... prereqs-
4b00: 6e 6f 74 2d 6d 65 74 29 20 22 2c 20 22 29 20 22 not-met) ", ") "
4b10: 20 66 61 69 6c 73 3a 20 22 20 66 61 69 6c 73 29 fails: " fails)
4b20: 0a 09 09 28 64 65 62 75 67 3a 70 72 69 6e 74 2d ...(debug:print-
4b30: 69 6e 66 6f 20 34 20 22 68 65 64 3d 22 20 68 65 info 4 "hed=" he
4b40: 64 20 22 5c 6e 20 20 74 65 73 74 2d 72 65 63 6f d "\n test-reco
4b50: 72 64 3d 22 20 74 65 73 74 2d 72 65 63 6f 72 64 rd=" test-record
4b60: 20 22 5c 6e 20 20 74 65 73 74 2d 6e 61 6d 65 3a "\n test-name:
4b70: 20 22 20 74 65 73 74 2d 6e 61 6d 65 20 22 5c 6e " test-name "\n
4b80: 20 20 69 74 65 6d 2d 70 61 74 68 3a 20 22 20 69 item-path: " i
4b90: 74 65 6d 2d 70 61 74 68 20 22 5c 6e 20 20 74 65 tem-path "\n te
4ba0: 73 74 2d 70 61 74 74 73 3a 20 22 20 74 65 73 74 st-patts: " test
4bb0: 2d 70 61 74 74 73 29 0a 0a 09 09 3b 3b 20 44 6f -patts)....;; Do
4bc0: 6e 27 74 20 6b 6e 6f 77 20 61 74 20 74 68 69 73 n't know at this
4bd0: 20 74 69 6d 65 20 69 66 20 74 68 65 20 74 65 73 time if the tes
4be0: 74 20 68 61 76 65 20 62 65 65 6e 20 6c 61 75 6e t have been laun
4bf0: 63 68 65 64 20 61 74 20 73 6f 6d 65 20 74 69 6d ched at some tim
4c00: 65 20 69 6e 20 74 68 65 20 70 61 73 74 0a 09 09 e in the past...
4c10: 3b 3b 20 69 2e 65 2e 20 69 73 20 74 68 69 73 20 ;; i.e. is this
4c20: 61 20 72 65 2d 6c 61 75 6e 63 68 3f 0a 09 09 28 a re-launch?...(
4c30: 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f debug:print-info
4c40: 20 34 20 22 72 75 6e 2d 6c 69 6d 69 74 73 2d 69 4 "run-limits-i
4c50: 6e 66 6f 20 3d 20 22 20 72 75 6e 2d 6c 69 6d 69 nfo = " run-limi
4c60: 74 73 2d 69 6e 66 6f 29 0a 09 09 28 63 6f 6e 64 ts-info)...(cond
4c70: 20 3b 3b 20 49 4e 4e 45 52 20 43 4f 4e 44 20 23 ;; INNER COND #
4c80: 31 20 66 6f 72 20 61 20 6c 61 75 6e 63 68 61 62 1 for a launchab
4c90: 6c 65 20 74 65 73 74 0a 09 09 20 3b 3b 20 43 68 le test... ;; Ch
4ca0: 65 63 6b 20 69 74 65 6d 20 70 61 74 68 20 61 67 eck item path ag
4cb0: 61 69 6e 73 74 20 69 74 65 6d 2d 70 61 74 74 73 ainst item-patts
4cc0: 0a 09 09 20 28 28 6e 6f 74 20 28 74 65 73 74 73 ... ((not (tests
4cd0: 3a 6d 61 74 63 68 20 74 65 73 74 2d 70 61 74 74 :match test-patt
4ce0: 73 20 28 74 65 73 74 73 3a 74 65 73 74 71 75 65 s (tests:testque
4cf0: 75 65 2d 67 65 74 2d 74 65 73 74 6e 61 6d 65 20 ue-get-testname
4d00: 74 65 73 74 2d 72 65 63 6f 72 64 29 20 69 74 65 test-record) ite
4d10: 6d 2d 70 61 74 68 29 29 20 3b 3b 20 54 68 69 73 m-path)) ;; This
4d20: 20 74 65 73 74 2f 69 74 65 6d 70 61 74 68 20 69 test/itempath i
4d30: 73 20 6e 6f 74 20 74 6f 20 62 65 20 72 75 6e 0a s not to be run.
4d40: 09 09 20 20 3b 3b 20 65 6c 73 65 20 74 68 65 20 .. ;; else the
4d50: 72 75 6e 20 69 73 20 73 74 75 63 6b 2c 20 74 65 run is stuck, te
4d60: 6d 70 6f 72 61 72 69 6c 79 20 6f 72 20 70 65 72 mporarily or per
4d70: 6d 61 6e 65 6e 74 6c 79 0a 09 09 20 20 3b 3b 20 manently... ;;
4d80: 62 75 74 20 73 68 6f 75 6c 64 20 63 68 65 63 6b but should check
4d90: 20 69 66 20 69 74 20 69 73 20 64 75 65 20 74 6f if it is due to
4da0: 20 6c 61 63 6b 20 6f 66 20 72 65 73 6f 75 72 63 lack of resourc
4db0: 65 73 20 76 73 2e 20 70 72 65 72 65 71 75 69 73 es vs. prerequis
4dc0: 69 74 65 73 0a 09 09 20 20 28 64 65 62 75 67 3a ites... (debug:
4dd0: 70 72 69 6e 74 2d 69 6e 66 6f 20 31 20 22 53 6b print-info 1 "Sk
4de0: 69 70 70 69 6e 67 20 22 20 28 74 65 73 74 73 3a ipping " (tests:
4df0: 74 65 73 74 71 75 65 75 65 2d 67 65 74 2d 74 65 testqueue-get-te
4e00: 73 74 6e 61 6d 65 20 74 65 73 74 2d 72 65 63 6f stname test-reco
4e10: 72 64 29 20 22 20 22 20 69 74 65 6d 2d 70 61 74 rd) " " item-pat
4e20: 68 20 22 20 61 73 20 69 74 20 64 6f 65 73 6e 27 h " as it doesn'
4e30: 74 20 6d 61 74 63 68 20 22 20 74 65 73 74 2d 70 t match " test-p
4e40: 61 74 74 73 29 0a 09 09 20 20 28 74 68 72 65 61 atts)... (threa
4e50: 64 2d 73 6c 65 65 70 21 20 2a 67 6c 6f 62 61 6c d-sleep! *global
4e60: 2d 64 65 6c 74 61 2a 29 0a 09 09 20 20 28 69 66 -delta*)... (if
4e70: 20 28 6e 6f 74 20 28 6e 75 6c 6c 3f 20 74 61 6c (not (null? tal
4e80: 29 29 0a 09 09 20 20 20 20 20 20 28 6c 6f 6f 70 ))... (loop
4e90: 20 28 63 61 72 20 74 61 6c 29 28 63 64 72 20 74 (car tal)(cdr t
4ea0: 61 6c 29 20 72 65 72 75 6e 73 29 29 29 0a 09 09 al) reruns)))...
4eb0: 20 28 20 3b 3b 20 28 61 6e 64 0a 09 09 20 20 28 ( ;; (and... (
4ec0: 6e 6f 74 20 28 68 61 73 68 2d 74 61 62 6c 65 2d not (hash-table-
4ed0: 72 65 66 2f 64 65 66 61 75 6c 74 20 74 65 73 74 ref/default test
4ee0: 2d 72 65 67 69 73 74 65 72 79 20 28 72 75 6e 73 -registery (runs
4ef0: 3a 6d 61 6b 65 2d 66 75 6c 6c 2d 74 65 73 74 2d :make-full-test-
4f00: 6e 61 6d 65 20 74 65 73 74 2d 6e 61 6d 65 20 69 name test-name i
4f10: 74 65 6d 2d 70 61 74 68 29 20 23 66 29 29 0a 09 tem-path) #f))..
4f20: 09 20 20 20 20 20 20 3b 3b 20 28 61 6e 64 20 6d . ;; (and m
4f30: 61 78 2d 63 6f 6e 63 75 72 72 65 6e 74 2d 6a 6f ax-concurrent-jo
4f40: 62 73 20 28 3e 20 28 2d 20 6d 61 78 2d 63 6f 6e bs (> (- max-con
4f50: 63 75 72 72 65 6e 74 2d 6a 6f 62 73 20 6e 75 6d current-jobs num
4f60: 2d 72 75 6e 6e 69 6e 67 29 20 35 29 29 29 0a 09 -running) 5)))..
4f70: 09 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d . (debug:print-
4f80: 69 6e 66 6f 20 34 20 22 50 72 65 2d 72 65 67 69 info 4 "Pre-regi
4f90: 73 74 65 72 69 6e 67 20 74 65 73 74 20 22 20 74 stering test " t
4fa0: 65 73 74 2d 6e 61 6d 65 20 22 2f 22 20 69 74 65 est-name "/" ite
4fb0: 6d 2d 70 61 74 68 20 22 20 74 6f 20 63 72 65 61 m-path " to crea
4fc0: 74 65 20 70 6c 61 63 65 68 6f 6c 64 65 72 22 20 te placeholder"
4fd0: 29 0a 09 09 20 20 28 6f 70 65 6e 2d 72 75 6e 2d )... (open-run-
4fe0: 63 6c 6f 73 65 20 64 62 3a 74 65 73 74 73 2d 72 close db:tests-r
4ff0: 65 67 69 73 74 65 72 2d 74 65 73 74 20 23 66 20 egister-test #f
5000: 72 75 6e 2d 69 64 20 74 65 73 74 2d 6e 61 6d 65 run-id test-name
5010: 20 69 74 65 6d 2d 70 61 74 68 29 0a 09 09 20 20 item-path)...
5020: 28 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 (hash-table-set!
5030: 20 74 65 73 74 2d 72 65 67 69 73 74 65 72 79 20 test-registery
5040: 28 72 75 6e 73 3a 6d 61 6b 65 2d 66 75 6c 6c 2d (runs:make-full-
5050: 74 65 73 74 2d 6e 61 6d 65 20 74 65 73 74 2d 6e test-name test-n
5060: 61 6d 65 20 69 74 65 6d 2d 70 61 74 68 29 20 23 ame item-path) #
5070: 74 29 0a 09 09 20 20 28 74 68 72 65 61 64 2d 73 t)... (thread-s
5080: 6c 65 65 70 21 20 2a 67 6c 6f 62 61 6c 2d 64 65 leep! *global-de
5090: 6c 74 61 2a 29 0a 28 72 75 6e 73 3a 73 68 72 69 lta*).(runs:shri
50a0: 6e 6b 2d 63 61 6e 2d 72 75 6e 2d 6d 6f 72 65 2d nk-can-run-more-
50b0: 74 65 73 74 73 2d 64 65 6c 61 79 29 0a 09 09 20 tests-delay)...
50c0: 20 28 6c 6f 6f 70 20 28 63 61 72 20 6e 65 77 74 (loop (car newt
50d0: 61 6c 29 28 63 64 72 20 6e 65 77 74 61 6c 29 20 al)(cdr newtal)
50e0: 72 65 72 75 6e 73 29 29 0a 09 09 20 28 28 6e 6f reruns))... ((no
50f0: 74 20 68 61 76 65 2d 72 65 73 6f 75 72 63 65 73 t have-resources
5100: 29 20 3b 3b 20 73 69 6d 70 6c 79 20 74 72 79 20 ) ;; simply try
5110: 61 67 61 69 6e 20 61 66 74 65 72 20 77 61 69 74 again after wait
5120: 69 6e 67 20 61 20 73 65 63 6f 6e 64 0a 09 09 20 ing a second...
5130: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e (debug:print-in
5140: 66 6f 20 31 20 22 6e 6f 20 72 65 73 6f 75 72 63 fo 1 "no resourc
5150: 65 73 20 74 6f 20 72 75 6e 20 6e 65 77 20 74 65 es to run new te
5160: 73 74 73 2c 20 77 61 69 74 69 6e 67 20 2e 2e 2e sts, waiting ...
5170: 22 29 0a 09 09 20 20 28 74 68 72 65 61 64 2d 73 ")... (thread-s
5180: 6c 65 65 70 21 20 28 2b 20 32 20 2a 67 6c 6f 62 leep! (+ 2 *glob
5190: 61 6c 2d 64 65 6c 74 61 2a 29 29 0a 09 09 20 20 al-delta*))...
51a0: 3b 3b 20 63 6f 75 6c 64 20 68 61 76 65 20 64 6f ;; could have do
51b0: 6e 65 20 68 65 64 20 74 61 6c 20 68 65 72 65 20 ne hed tal here
51c0: 62 75 74 20 64 6f 69 6e 67 20 63 61 72 2f 63 64 but doing car/cd
51d0: 72 20 6f 66 20 6e 65 77 74 61 6c 20 74 6f 20 72 r of newtal to r
51e0: 6f 74 61 74 65 20 74 65 73 74 73 0a 09 09 20 20 otate tests...
51f0: 28 6c 6f 6f 70 20 28 63 61 72 20 6e 65 77 74 61 (loop (car newta
5200: 6c 29 28 63 64 72 20 6e 65 77 74 61 6c 29 20 72 l)(cdr newtal) r
5210: 65 72 75 6e 73 29 29 0a 09 09 20 28 28 61 6e 64 eruns))... ((and
5220: 20 68 61 76 65 2d 72 65 73 6f 75 72 63 65 73 0a have-resources.
5230: 09 09 20 20 20 20 20 20 20 28 6f 72 20 28 6e 75 .. (or (nu
5240: 6c 6c 3f 20 70 72 65 72 65 71 73 2d 6e 6f 74 2d ll? prereqs-not-
5250: 6d 65 74 29 0a 09 09 09 20 20 20 28 61 6e 64 20 met).... (and
5260: 28 65 71 3f 20 74 65 73 74 6d 6f 64 65 20 27 74 (eq? testmode 't
5270: 6f 70 6c 65 76 65 6c 29 0a 09 09 09 09 28 6e 75 oplevel).....(nu
5280: 6c 6c 3f 20 6e 6f 6e 2d 63 6f 6d 70 6c 65 74 65 ll? non-complete
5290: 64 29 29 29 29 0a 09 09 20 20 28 72 75 6e 3a 74 d))))... (run:t
52a0: 65 73 74 20 72 75 6e 2d 69 64 20 72 75 6e 6e 61 est run-id runna
52b0: 6d 65 20 6b 65 79 76 61 6c 6c 73 74 20 74 65 73 me keyvallst tes
52c0: 74 2d 72 65 63 6f 72 64 20 66 6c 61 67 73 20 23 t-record flags #
52d0: 66 29 0a 28 72 75 6e 73 3a 73 68 72 69 6e 6b 2d f).(runs:shrink-
52e0: 63 61 6e 2d 72 75 6e 2d 6d 6f 72 65 2d 74 65 73 can-run-more-tes
52f0: 74 73 2d 64 65 6c 61 79 29 0a 09 09 20 20 28 74 ts-delay)... (t
5300: 68 72 65 61 64 2d 73 6c 65 65 70 21 20 2a 67 6c hread-sleep! *gl
5310: 6f 62 61 6c 2d 64 65 6c 74 61 2a 29 0a 09 09 20 obal-delta*)...
5320: 20 28 69 66 20 28 6e 6f 74 20 28 6e 75 6c 6c 3f (if (not (null?
5330: 20 74 61 6c 29 29 0a 09 09 20 20 20 20 20 20 28 tal))... (
5340: 6c 6f 6f 70 20 28 63 61 72 20 74 61 6c 29 28 63 loop (car tal)(c
5350: 64 72 20 74 61 6c 29 20 72 65 72 75 6e 73 29 29 dr tal) reruns))
5360: 29 0a 09 09 20 28 65 6c 73 65 20 3b 3b 20 6d 75 )... (else ;; mu
5370: 73 74 20 62 65 20 77 65 20 68 61 76 65 20 75 6e st be we have un
5380: 6d 65 74 20 70 72 65 72 65 71 75 69 73 69 74 65 met prerequisite
5390: 73 0a 09 09 20 20 20 20 28 64 65 62 75 67 3a 70 s... (debug:p
53a0: 72 69 6e 74 20 34 20 22 46 41 49 4c 53 3a 20 22 rint 4 "FAILS: "
53b0: 20 66 61 69 6c 73 29 0a 09 09 20 20 20 20 3b 3b fails)... ;;
53c0: 20 49 66 20 6f 6e 65 20 6f 72 20 6d 6f 72 65 20 If one or more
53d0: 6f 66 20 74 68 65 20 70 72 65 72 65 71 73 2d 6e of the prereqs-n
53e0: 6f 74 2d 6d 65 74 20 61 72 65 20 46 41 49 4c 20 ot-met are FAIL
53f0: 74 68 65 6e 20 77 65 20 63 61 6e 20 69 73 73 75 then we can issu
5400: 65 0a 09 09 20 20 20 20 3b 3b 20 61 20 6d 65 73 e... ;; a mes
5410: 73 61 67 65 20 61 6e 64 20 64 72 6f 70 20 68 65 sage and drop he
5420: 64 20 66 72 6f 6d 20 74 68 65 20 69 74 65 6d 73 d from the items
5430: 20 74 6f 20 62 65 20 70 72 6f 63 65 73 73 65 64 to be processed
5440: 2e 0a 09 09 20 20 20 20 28 69 66 20 28 6e 75 6c .... (if (nul
5450: 6c 3f 20 66 61 69 6c 73 29 0a 09 09 09 28 62 65 l? fails)....(be
5460: 67 69 6e 0a 09 09 09 20 20 3b 3b 20 63 6f 75 6c gin.... ;; coul
5470: 64 6e 27 74 20 72 75 6e 2c 20 74 61 6b 65 20 61 dn't run, take a
5480: 20 62 72 65 61 74 68 65 72 0a 09 09 09 20 20 28 breather.... (
5490: 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f debug:print-info
54a0: 20 34 20 22 53 68 6f 75 6c 64 6e 27 74 20 72 65 4 "Shouldn't re
54b0: 61 6c 6c 79 20 67 65 74 20 68 65 72 65 2c 20 72 ally get here, r
54c0: 61 63 65 20 63 6f 6e 64 69 74 69 6f 6e 3f 20 55 ace condition? U
54d0: 6e 61 62 6c 65 20 74 6f 20 6c 61 75 6e 63 68 20 nable to launch
54e0: 6d 6f 72 65 20 74 65 73 74 73 20 61 74 20 74 68 more tests at th
54f0: 69 73 20 6d 6f 6d 65 6e 74 2c 20 6b 69 6c 6c 69 is moment, killi
5500: 6e 67 20 74 69 6d 65 20 2e 2e 2e 22 29 0a 09 09 ng time ...")...
5510: 09 20 20 28 74 68 72 65 61 64 2d 73 6c 65 65 70 . (thread-sleep
5520: 21 20 28 2b 20 30 2e 30 31 20 2a 67 6c 6f 62 61 ! (+ 0.01 *globa
5530: 6c 2d 64 65 6c 74 61 2a 29 29 20 3b 3b 20 6c 6f l-delta*)) ;; lo
5540: 6e 67 20 73 6c 65 65 70 20 68 65 72 65 20 2d 20 ng sleep here -
5550: 6e 6f 20 72 65 73 6f 75 72 63 65 73 2c 20 6d 61 no resources, ma
5560: 79 20 61 73 20 77 65 6c 6c 20 62 65 20 70 61 74 y as well be pat
5570: 69 65 6e 74 0a 09 09 09 20 20 3b 3b 20 77 65 20 ient.... ;; we
5580: 6d 61 64 65 20 6e 65 77 20 74 61 6c 20 62 79 20 made new tal by
5590: 73 74 69 63 6b 69 6e 67 20 68 65 64 20 61 74 20 sticking hed at
55a0: 74 68 65 20 62 61 63 6b 20 6f 66 20 74 68 65 20 the back of the
55b0: 6c 69 73 74 0a 09 09 09 20 20 28 6c 6f 6f 70 20 list.... (loop
55c0: 28 63 61 72 20 6e 65 77 74 61 6c 29 28 63 64 72 (car newtal)(cdr
55d0: 20 6e 65 77 74 61 6c 29 20 72 65 72 75 6e 73 29 newtal) reruns)
55e0: 29 0a 09 09 09 3b 3b 20 74 68 65 20 77 61 69 74 )....;; the wait
55f0: 6f 6e 20 69 73 20 46 41 49 4c 20 73 6f 20 6e 6f on is FAIL so no
5600: 20 70 6f 69 6e 74 20 69 6e 20 74 72 79 69 6e 67 point in trying
5610: 20 74 6f 20 72 75 6e 20 68 65 64 20 65 76 65 72 to run hed ever
5620: 20 61 67 61 69 6e 0a 09 09 09 28 69 66 20 28 6e again....(if (n
5630: 6f 74 20 28 6e 75 6c 6c 3f 20 74 61 6c 29 29 0a ot (null? tal)).
5640: 09 09 09 20 20 20 20 28 69 66 20 28 76 65 63 74 ... (if (vect
5650: 6f 72 3f 20 68 65 64 29 0a 09 09 09 09 28 62 65 or? hed).....(be
5660: 67 69 6e 20 28 64 65 62 75 67 3a 70 72 69 6e 74 gin (debug:print
5670: 20 31 20 22 57 41 52 4e 3a 20 44 72 6f 70 70 69 1 "WARN: Droppi
5680: 6e 67 20 74 65 73 74 20 22 20 28 64 62 3a 74 65 ng test " (db:te
5690: 73 74 2d 67 65 74 2d 74 65 73 74 6e 61 6d 65 20 st-get-testname
56a0: 68 65 64 29 20 22 2f 22 20 28 64 62 3a 74 65 73 hed) "/" (db:tes
56b0: 74 2d 67 65 74 2d 69 74 65 6d 2d 70 61 74 68 20 t-get-item-path
56c0: 68 65 64 29 0a 09 09 09 09 09 09 20 20 20 20 22 hed)....... "
56d0: 20 66 72 6f 6d 20 74 68 65 20 6c 61 75 6e 63 68 from the launch
56e0: 20 6c 69 73 74 20 61 73 20 69 74 20 68 61 73 20 list as it has
56f0: 70 72 65 72 65 71 75 69 73 74 65 73 20 74 68 61 prerequistes tha
5700: 74 20 61 72 65 20 46 41 49 4c 22 29 0a 28 72 75 t are FAIL").(ru
5710: 6e 73 3a 73 68 72 69 6e 6b 2d 63 61 6e 2d 72 75 ns:shrink-can-ru
5720: 6e 2d 6d 6f 72 65 2d 74 65 73 74 73 2d 64 65 6c n-more-tests-del
5730: 61 79 29 0a 09 09 09 09 20 20 20 20 20 20 20 28 ay)..... (
5740: 74 68 72 65 61 64 2d 73 6c 65 65 70 21 20 2a 67 thread-sleep! *g
5750: 6c 6f 62 61 6c 2d 64 65 6c 74 61 2a 29 0a 09 09 lobal-delta*)...
5760: 09 09 20 20 20 20 20 20 20 28 6c 6f 6f 70 20 28 .. (loop (
5770: 63 61 72 20 74 61 6c 29 28 63 64 72 20 74 61 6c car tal)(cdr tal
5780: 29 20 28 63 6f 6e 73 20 68 65 64 20 72 65 72 75 ) (cons hed reru
5790: 6e 73 29 29 29 0a 09 09 09 09 28 62 65 67 69 6e ns))).....(begin
57a0: 0a 09 09 09 09 20 20 28 64 65 62 75 67 3a 70 72 ..... (debug:pr
57b0: 69 6e 74 20 31 20 22 57 41 52 4e 3a 20 54 65 73 int 1 "WARN: Tes
57c0: 74 20 6e 6f 74 20 70 72 6f 63 65 73 73 65 64 20 t not processed
57d0: 63 6f 72 72 65 63 74 6c 79 2e 20 43 6f 75 6c 64 correctly. Could
57e0: 20 62 65 20 61 20 72 61 63 65 20 63 6f 6e 64 69 be a race condi
57f0: 74 69 6f 6e 20 69 6e 20 79 6f 75 72 20 74 65 73 tion in your tes
5800: 74 20 69 6d 70 6c 65 6d 65 6e 74 61 74 69 6f 6e t implementation
5810: 3f 20 22 20 68 65 64 29 20 3b 3b 20 20 22 20 61 ? " hed) ;; " a
5820: 73 20 69 74 20 68 61 73 20 70 72 65 72 65 71 75 s it has prerequ
5830: 69 73 74 65 73 20 74 68 61 74 20 61 72 65 20 46 istes that are F
5840: 41 49 4c 2e 20 28 4e 4f 54 45 3a 20 68 65 64 20 AIL. (NOTE: hed
5850: 69 73 20 6e 6f 74 20 61 20 76 65 63 74 6f 72 29 is not a vector)
5860: 22 29 0a 28 72 75 6e 73 3a 73 68 72 69 6e 6b 2d ").(runs:shrink-
5870: 63 61 6e 2d 72 75 6e 2d 6d 6f 72 65 2d 74 65 73 can-run-more-tes
5880: 74 73 2d 64 65 6c 61 79 29 0a 09 09 09 09 20 20 ts-delay).....
5890: 28 74 68 72 65 61 64 2d 73 6c 65 65 70 21 20 28 (thread-sleep! (
58a0: 2b 20 30 2e 30 31 20 2a 67 6c 6f 62 61 6c 2d 64 + 0.01 *global-d
58b0: 65 6c 74 61 2a 29 29 0a 09 09 09 09 20 20 28 6c elta*))..... (l
58c0: 6f 6f 70 20 68 65 64 20 74 61 6c 20 72 65 72 75 oop hed tal reru
58d0: 6e 73 29 29 29 29 29 29 29 29 29 20 3b 3b 20 45 ns))))))))) ;; E
58e0: 4e 44 20 4f 46 20 49 4e 4e 45 52 20 43 4f 4e 44 ND OF INNER COND
58f0: 0a 09 20 20 20 20 20 0a 09 20 20 20 20 20 3b 3b .. .. ;;
5900: 20 63 61 73 65 20 77 68 65 72 65 20 61 6e 20 69 case where an i
5910: 74 65 6d 73 20 63 61 6d 65 20 69 6e 20 61 73 20 tems came in as
5920: 61 20 6c 69 73 74 20 62 65 65 6e 20 70 72 6f 63 a list been proc
5930: 65 73 73 65 64 0a 09 20 20 20 20 20 28 28 61 6e essed.. ((an
5940: 64 20 28 6c 69 73 74 3f 20 69 74 65 6d 73 29 20 d (list? items)
5950: 20 20 20 20 3b 3b 20 74 68 75 73 20 77 65 20 6b ;; thus we k
5960: 6e 6f 77 20 6f 75 72 20 69 74 65 6d 73 20 61 72 now our items ar
5970: 65 20 61 6c 72 65 61 64 79 20 63 61 6c 63 75 6c e already calcul
5980: 61 74 65 64 0a 09 09 20 20 20 28 6e 6f 74 20 20 ated... (not
5990: 20 69 74 65 6d 64 61 74 29 29 20 3b 3b 20 61 6e itemdat)) ;; an
59a0: 64 20 6e 6f 74 20 79 65 74 20 65 78 70 61 6e 64 d not yet expand
59b0: 65 64 20 69 6e 74 6f 20 74 68 65 20 6c 69 73 74 ed into the list
59c0: 20 6f 66 20 74 68 69 6e 67 73 20 74 6f 20 62 65 of things to be
59d0: 20 64 6f 6e 65 0a 09 20 20 20 20 20 20 28 69 66 done.. (if
59e0: 20 28 61 6e 64 20 28 64 65 62 75 67 3a 64 65 62 (and (debug:deb
59f0: 75 67 2d 6d 6f 64 65 20 31 29 20 3b 3b 20 28 3e ug-mode 1) ;; (>
5a00: 3d 20 2a 76 65 72 62 6f 73 69 74 79 2a 20 31 29 = *verbosity* 1)
5a10: 0a 09 09 20 20 20 20 20 20 20 28 3e 20 28 6c 65 ... (> (le
5a20: 6e 67 74 68 20 69 74 65 6d 73 29 20 30 29 0a 09 ngth items) 0)..
5a30: 09 20 20 20 20 20 20 20 28 3e 20 28 6c 65 6e 67 . (> (leng
5a40: 74 68 20 28 63 61 72 20 69 74 65 6d 73 29 29 20 th (car items))
5a50: 30 29 29 0a 09 09 20 20 28 70 70 20 69 74 65 6d 0))... (pp item
5a60: 73 29 29 0a 09 20 20 20 20 20 20 28 66 6f 72 2d s)).. (for-
5a70: 65 61 63 68 0a 09 20 20 20 20 20 20 20 28 6c 61 each.. (la
5a80: 6d 62 64 61 20 28 6d 79 2d 69 74 65 6d 64 61 74 mbda (my-itemdat
5a90: 29 0a 09 09 20 28 6c 65 74 2a 20 28 28 6e 65 77 )... (let* ((new
5aa0: 2d 74 65 73 74 2d 72 65 63 6f 72 64 20 28 6c 65 -test-record (le
5ab0: 74 20 28 28 6e 65 77 72 65 63 20 28 6d 61 6b 65 t ((newrec (make
5ac0: 2d 74 65 73 74 73 3a 74 65 73 74 71 75 65 75 65 -tests:testqueue
5ad0: 29 29 29 0a 09 09 09 09 09 20 20 20 28 76 65 63 )))...... (vec
5ae0: 74 6f 72 2d 63 6f 70 79 21 20 74 65 73 74 2d 72 tor-copy! test-r
5af0: 65 63 6f 72 64 20 6e 65 77 72 65 63 29 0a 09 09 ecord newrec)...
5b00: 09 09 09 20 20 20 6e 65 77 72 65 63 29 29 0a 09 ... newrec))..
5b10: 09 09 28 6d 79 2d 69 74 65 6d 2d 70 61 74 68 20 ..(my-item-path
5b20: 28 69 74 65 6d 2d 6c 69 73 74 2d 3e 70 61 74 68 (item-list->path
5b30: 20 6d 79 2d 69 74 65 6d 64 61 74 29 29 29 0a 09 my-itemdat)))..
5b40: 09 20 20 20 28 69 66 20 28 74 65 73 74 73 3a 6d . (if (tests:m
5b50: 61 74 63 68 20 74 65 73 74 2d 70 61 74 74 73 20 atch test-patts
5b60: 68 65 64 20 6d 79 2d 69 74 65 6d 2d 70 61 74 68 hed my-item-path
5b70: 29 20 3b 3b 20 28 70 61 74 74 2d 6c 69 73 74 2d ) ;; (patt-list-
5b80: 6d 61 74 63 68 20 6d 79 2d 69 74 65 6d 2d 70 61 match my-item-pa
5b90: 74 68 20 69 74 65 6d 2d 70 61 74 74 73 29 20 20 th item-patts)
5ba0: 20 20 20 20 20 20 20 20 20 3b 3b 20 79 65 73 2c ;; yes,
5bb0: 20 77 65 20 77 61 6e 74 20 74 6f 20 70 72 6f 63 we want to proc
5bc0: 65 73 73 20 74 68 69 73 20 69 74 65 6d 2c 20 4e ess this item, N
5bd0: 4f 54 45 3a 20 53 68 6f 75 6c 64 20 6e 6f 74 20 OTE: Should not
5be0: 6e 65 65 64 20 74 68 69 73 20 63 68 65 63 6b 20 need this check
5bf0: 68 65 72 65 21 0a 09 09 20 20 20 20 20 20 20 28 here!... (
5c00: 6c 65 74 20 28 28 6e 65 77 74 65 73 74 6e 61 6d let ((newtestnam
5c10: 65 20 28 72 75 6e 73 3a 6d 61 6b 65 2d 66 75 6c e (runs:make-ful
5c20: 6c 2d 74 65 73 74 2d 6e 61 6d 65 20 68 65 64 20 l-test-name hed
5c30: 6d 79 2d 69 74 65 6d 2d 70 61 74 68 29 29 29 20 my-item-path)))
5c40: 20 20 20 3b 3b 20 74 65 73 74 20 6e 61 6d 65 73 ;; test names
5c50: 20 61 72 65 20 75 6e 69 71 75 65 20 6f 6e 20 74 are unique on t
5c60: 65 73 74 6e 61 6d 65 2f 69 74 65 6d 2d 70 61 74 estname/item-pat
5c70: 68 0a 09 09 09 20 28 74 65 73 74 73 3a 74 65 73 h.... (tests:tes
5c80: 74 71 75 65 75 65 2d 73 65 74 2d 69 74 65 6d 73 tqueue-set-items
5c90: 21 20 20 20 20 20 6e 65 77 2d 74 65 73 74 2d 72 ! new-test-r
5ca0: 65 63 6f 72 64 20 23 66 29 0a 09 09 09 20 28 74 ecord #f).... (t
5cb0: 65 73 74 73 3a 74 65 73 74 71 75 65 75 65 2d 73 ests:testqueue-s
5cc0: 65 74 2d 69 74 65 6d 64 61 74 21 20 20 20 6e 65 et-itemdat! ne
5cd0: 77 2d 74 65 73 74 2d 72 65 63 6f 72 64 20 6d 79 w-test-record my
5ce0: 2d 69 74 65 6d 64 61 74 29 0a 09 09 09 20 28 74 -itemdat).... (t
5cf0: 65 73 74 73 3a 74 65 73 74 71 75 65 75 65 2d 73 ests:testqueue-s
5d00: 65 74 2d 69 74 65 6d 5f 70 61 74 68 21 20 6e 65 et-item_path! ne
5d10: 77 2d 74 65 73 74 2d 72 65 63 6f 72 64 20 6d 79 w-test-record my
5d20: 2d 69 74 65 6d 2d 70 61 74 68 29 0a 09 09 09 20 -item-path)....
5d30: 28 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 (hash-table-set!
5d40: 20 74 65 73 74 2d 72 65 63 6f 72 64 73 20 6e 65 test-records ne
5d50: 77 74 65 73 74 6e 61 6d 65 20 6e 65 77 2d 74 65 wtestname new-te
5d60: 73 74 2d 72 65 63 6f 72 64 29 0a 09 09 09 20 28 st-record).... (
5d70: 73 65 74 21 20 74 61 6c 20 28 63 6f 6e 73 20 6e set! tal (cons n
5d80: 65 77 74 65 73 74 6e 61 6d 65 20 74 61 6c 29 29 ewtestname tal))
5d90: 29 29 29 29 20 3b 3b 20 73 69 6e 63 65 20 74 68 )))) ;; since th
5da0: 65 73 65 20 61 72 65 20 69 74 65 6d 69 7a 65 64 ese are itemized
5db0: 20 63 72 65 61 74 65 20 6e 65 77 20 74 65 73 74 create new test
5dc0: 20 6e 61 6d 65 73 20 74 65 73 74 6e 61 6d 65 2f names testname/
5dd0: 69 74 65 6d 70 61 74 68 0a 09 20 20 20 20 20 20 itempath..
5de0: 20 69 74 65 6d 73 29 0a 09 20 20 20 20 20 20 28 items).. (
5df0: 69 66 20 28 6e 6f 74 20 28 6e 75 6c 6c 3f 20 74 if (not (null? t
5e00: 61 6c 29 29 0a 09 09 20 20 28 62 65 67 69 6e 0a al))... (begin.
5e10: 09 09 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 .. (debug:pri
5e20: 6e 74 2d 69 6e 66 6f 20 34 20 22 45 6e 64 20 6f nt-info 4 "End o
5e30: 66 20 69 74 65 6d 73 20 6c 69 73 74 2c 20 6c 6f f items list, lo
5e40: 6f 70 69 6e 67 20 77 69 74 68 20 6e 65 78 74 20 oping with next
5e50: 61 66 74 65 72 20 73 68 6f 72 74 20 64 65 6c 61 after short dela
5e60: 79 22 29 0a 09 09 20 20 20 20 28 74 68 72 65 61 y")... (threa
5e70: 64 2d 73 6c 65 65 70 21 20 28 2b 20 30 2e 30 31 d-sleep! (+ 0.01
5e80: 20 2a 67 6c 6f 62 61 6c 2d 64 65 6c 74 61 2a 29 *global-delta*)
5e90: 29 0a 09 09 20 20 20 20 28 6c 6f 6f 70 20 28 63 )... (loop (c
5ea0: 61 72 20 74 61 6c 29 28 63 64 72 20 74 61 6c 29 ar tal)(cdr tal)
5eb0: 20 72 65 72 75 6e 73 29 29 29 29 0a 0a 09 20 20 reruns))))...
5ec0: 20 20 20 3b 3b 20 69 66 20 69 74 65 6d 73 20 69 ;; if items i
5ed0: 73 20 61 20 70 72 6f 63 20 74 68 65 6e 20 6e 65 s a proc then ne
5ee0: 65 64 20 74 6f 20 72 75 6e 20 69 74 65 6d 73 3a ed to run items:
5ef0: 67 65 74 2d 69 74 65 6d 73 2d 66 72 6f 6d 2d 63 get-items-from-c
5f00: 6f 6e 66 69 67 2c 20 67 65 74 20 74 68 65 20 6c onfig, get the l
5f10: 69 73 74 20 61 6e 64 20 6c 6f 6f 70 20 0a 09 20 ist and loop ..
5f20: 20 20 20 20 3b 3b 20 20 20 20 2d 20 62 75 74 20 ;; - but
5f30: 6f 6e 6c 79 20 64 6f 20 74 68 61 74 20 69 66 20 only do that if
5f40: 72 65 73 6f 75 72 63 65 73 20 65 78 69 73 74 20 resources exist
5f50: 74 6f 20 6b 69 63 6b 20 6f 66 66 20 74 68 65 20 to kick off the
5f60: 6a 6f 62 0a 09 20 20 20 20 20 28 28 6f 72 20 28 job.. ((or (
5f70: 70 72 6f 63 65 64 75 72 65 3f 20 69 74 65 6d 73 procedure? items
5f80: 29 28 65 71 3f 20 69 74 65 6d 73 20 27 68 61 76 )(eq? items 'hav
5f90: 65 2d 70 72 6f 63 65 64 75 72 65 29 29 0a 09 20 e-procedure))..
5fa0: 20 20 20 20 20 28 6c 65 74 20 28 28 63 61 6e 2d (let ((can-
5fb0: 72 75 6e 2d 6d 6f 72 65 20 20 20 20 28 72 75 6e run-more (run
5fc0: 73 3a 63 61 6e 2d 72 75 6e 2d 6d 6f 72 65 2d 74 s:can-run-more-t
5fd0: 65 73 74 73 20 74 65 73 74 2d 72 65 63 6f 72 64 ests test-record
5fe0: 29 29 29 0a 09 09 28 69 66 20 28 61 6e 64 20 28 )))...(if (and (
5ff0: 6c 69 73 74 3f 20 63 61 6e 2d 72 75 6e 2d 6d 6f list? can-run-mo
6000: 72 65 29 0a 09 09 09 20 28 63 61 72 20 63 61 6e re).... (car can
6010: 2d 72 75 6e 2d 6d 6f 72 65 29 29 0a 09 09 20 20 -run-more))...
6020: 20 20 28 6c 65 74 2a 20 28 28 70 72 65 72 65 71 (let* ((prereq
6030: 73 2d 6e 6f 74 2d 6d 65 74 20 28 6f 70 65 6e 2d s-not-met (open-
6040: 72 75 6e 2d 63 6c 6f 73 65 20 64 62 3a 67 65 74 run-close db:get
6050: 2d 70 72 65 72 65 71 73 2d 6e 6f 74 2d 6d 65 74 -prereqs-not-met
6060: 20 23 66 20 72 75 6e 2d 69 64 20 77 61 69 74 6f #f run-id waito
6070: 6e 73 20 69 74 65 6d 2d 70 61 74 68 20 6d 6f 64 ns item-path mod
6080: 65 3a 20 74 65 73 74 6d 6f 64 65 29 29 0a 09 09 e: testmode))...
6090: 09 20 20 20 28 66 61 69 6c 73 20 20 20 20 20 20 . (fails
60a0: 20 20 20 20 20 28 72 75 6e 73 3a 63 61 6c 63 2d (runs:calc-
60b0: 66 61 69 6c 73 20 70 72 65 72 65 71 73 2d 6e 6f fails prereqs-no
60c0: 74 2d 6d 65 74 29 29 0a 09 09 09 20 20 20 28 6e t-met)).... (n
60d0: 6f 6e 2d 63 6f 6d 70 6c 65 74 65 64 20 20 20 28 on-completed (
60e0: 72 75 6e 73 3a 63 61 6c 63 2d 6e 6f 74 2d 63 6f runs:calc-not-co
60f0: 6d 70 6c 65 74 65 64 20 70 72 65 72 65 71 73 2d mpleted prereqs-
6100: 6e 6f 74 2d 6d 65 74 29 29 29 0a 09 09 20 20 20 not-met)))...
6110: 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d (debug:print-
6120: 69 6e 66 6f 20 38 20 22 63 61 6e 2d 72 75 6e 2d info 8 "can-run-
6130: 6d 6f 72 65 3a 20 22 20 63 61 6e 2d 72 75 6e 2d more: " can-run-
6140: 6d 6f 72 65 0a 09 09 09 09 20 20 20 22 5c 6e 20 more..... "\n
6150: 74 65 73 74 6e 61 6d 65 3a 20 20 20 20 20 20 20 testname:
6160: 20 22 20 68 65 64 0a 09 09 09 09 20 20 20 22 5c " hed..... "\
6170: 6e 20 70 72 65 72 65 71 73 2d 6e 6f 74 2d 6d 65 n prereqs-not-me
6180: 74 3a 20 22 20 28 72 75 6e 73 3a 70 72 65 74 74 t: " (runs:prett
6190: 79 2d 73 74 72 69 6e 67 20 70 72 65 72 65 71 73 y-string prereqs
61a0: 2d 6e 6f 74 2d 6d 65 74 29 0a 09 09 09 09 20 20 -not-met).....
61b0: 20 22 5c 6e 20 6e 6f 6e 2d 63 6f 6d 70 6c 65 74 "\n non-complet
61c0: 65 64 3a 20 20 20 22 20 28 72 75 6e 73 3a 70 72 ed: " (runs:pr
61d0: 65 74 74 79 2d 73 74 72 69 6e 67 20 6e 6f 6e 2d etty-string non-
61e0: 63 6f 6d 70 6c 65 74 65 64 29 20 0a 09 09 09 09 completed) .....
61f0: 20 20 20 22 5c 6e 20 66 61 69 6c 73 3a 20 20 20 "\n fails:
6200: 20 20 20 20 20 20 20 20 22 20 28 72 75 6e 73 3a " (runs:
6210: 70 72 65 74 74 79 2d 73 74 72 69 6e 67 20 66 61 pretty-string fa
6220: 69 6c 73 29 0a 09 09 09 09 20 20 20 22 5c 6e 20 ils)..... "\n
6230: 74 65 73 74 6d 6f 64 65 3a 20 20 20 20 20 20 20 testmode:
6240: 20 22 20 74 65 73 74 6d 6f 64 65 0a 09 09 09 09 " testmode.....
6250: 20 20 20 22 5c 6e 20 6e 75 6d 2d 72 65 74 72 69 "\n num-retri
6260: 65 73 3a 20 20 20 20 20 22 20 6e 75 6d 2d 72 65 es: " num-re
6270: 74 72 69 65 73 0a 09 09 09 09 20 20 20 22 5c 6e tries..... "\n
6280: 20 28 65 71 3f 20 74 65 73 74 6d 6f 64 65 20 27 (eq? testmode '
6290: 74 6f 70 6c 65 76 65 6c 29 3a 20 22 20 28 65 71 toplevel): " (eq
62a0: 3f 20 74 65 73 74 6d 6f 64 65 20 27 74 6f 70 6c ? testmode 'topl
62b0: 65 76 65 6c 29 0a 09 09 09 09 20 20 20 22 5c 6e evel)..... "\n
62c0: 20 28 6e 75 6c 6c 3f 20 6e 6f 6e 2d 63 6f 6d 70 (null? non-comp
62d0: 6c 65 74 65 64 29 3a 20 20 20 20 22 20 28 6e 75 leted): " (nu
62e0: 6c 6c 3f 20 6e 6f 6e 2d 63 6f 6d 70 6c 65 74 65 ll? non-complete
62f0: 64 29 0a 09 09 09 09 20 20 20 22 5c 6e 20 72 65 d)..... "\n re
6300: 72 75 6e 73 3a 20 20 20 20 20 20 20 20 20 20 22 runs: "
6310: 20 72 65 72 75 6e 73 0a 09 09 09 09 20 20 20 22 reruns..... "
6320: 5c 6e 20 69 74 65 6d 73 3a 20 20 20 20 20 20 20 \n items:
6330: 20 20 20 20 22 20 69 74 65 6d 73 0a 09 09 09 09 " items.....
6340: 20 20 20 22 5c 6e 20 63 61 6e 2d 72 75 6e 2d 6d "\n can-run-m
6350: 6f 72 65 3a 20 20 20 20 22 20 63 61 6e 2d 72 75 ore: " can-ru
6360: 6e 2d 6d 6f 72 65 29 0a 09 09 20 20 20 20 20 20 n-more)...
6370: 3b 3b 20 28 74 68 72 65 61 64 2d 73 6c 65 65 70 ;; (thread-sleep
6380: 21 20 28 2b 20 30 2e 30 31 20 2a 67 6c 6f 62 61 ! (+ 0.01 *globa
6390: 6c 2d 64 65 6c 74 61 2a 29 29 0a 09 09 20 20 20 l-delta*))...
63a0: 20 20 20 28 63 6f 6e 64 20 3b 3b 20 49 4e 4e 45 (cond ;; INNE
63b0: 52 20 43 4f 4e 44 20 23 32 0a 09 09 20 20 20 20 R COND #2...
63c0: 20 20 20 28 28 6f 72 20 28 6e 75 6c 6c 3f 20 70 ((or (null? p
63d0: 72 65 72 65 71 73 2d 6e 6f 74 2d 6d 65 74 29 20 rereqs-not-met)
63e0: 3b 3b 20 61 6c 6c 20 70 72 65 72 65 71 73 20 6d ;; all prereqs m
63f0: 65 74 2c 20 66 69 72 65 20 6f 66 66 20 74 68 65 et, fire off the
6400: 20 74 65 73 74 0a 09 09 09 20 20 20 20 3b 3b 20 test.... ;;
6410: 6f 72 2c 20 69 66 20 69 74 20 69 73 20 61 20 27 or, if it is a '
6420: 74 6f 70 6c 65 76 65 6c 20 74 65 73 74 20 61 6e toplevel test an
6430: 64 20 61 6c 6c 20 70 72 65 72 65 71 73 20 6e 6f d all prereqs no
6440: 74 20 6d 65 74 20 61 72 65 20 43 4f 4d 50 4c 45 t met are COMPLE
6450: 54 45 44 20 74 68 65 6e 20 6c 61 75 6e 63 68 0a TED then launch.
6460: 09 09 09 20 20 20 20 28 61 6e 64 20 28 65 71 3f ... (and (eq?
6470: 20 74 65 73 74 6d 6f 64 65 20 27 74 6f 70 6c 65 testmode 'tople
6480: 76 65 6c 29 0a 09 09 09 09 20 28 6e 75 6c 6c 3f vel)..... (null?
6490: 20 6e 6f 6e 2d 63 6f 6d 70 6c 65 74 65 64 29 29 non-completed))
64a0: 29 0a 09 09 09 28 6c 65 74 20 28 28 74 65 73 74 )....(let ((test
64b0: 2d 6e 61 6d 65 20 28 74 65 73 74 73 3a 74 65 73 -name (tests:tes
64c0: 74 71 75 65 75 65 2d 67 65 74 2d 74 65 73 74 6e tqueue-get-testn
64d0: 61 6d 65 20 74 65 73 74 2d 72 65 63 6f 72 64 29 ame test-record)
64e0: 29 29 0a 09 09 09 20 20 28 73 65 74 65 6e 76 20 )).... (setenv
64f0: 22 4d 54 5f 54 45 53 54 5f 4e 41 4d 45 22 20 74 "MT_TEST_NAME" t
6500: 65 73 74 2d 6e 61 6d 65 29 20 3b 3b 20 0a 09 09 est-name) ;; ...
6510: 09 20 20 28 73 65 74 65 6e 76 20 22 4d 54 5f 52 . (setenv "MT_R
6520: 55 4e 4e 41 4d 45 22 20 20 20 72 75 6e 6e 61 6d UNNAME" runnam
6530: 65 29 0a 09 09 09 20 20 28 73 65 74 2d 6d 65 67 e).... (set-meg
6540: 61 74 65 73 74 2d 65 6e 76 2d 76 61 72 73 20 72 atest-env-vars r
6550: 75 6e 2d 69 64 29 20 3b 3b 20 74 68 65 73 65 20 un-id) ;; these
6560: 6d 61 79 20 62 65 20 6e 65 65 64 65 64 20 62 79 may be needed by
6570: 20 74 68 65 20 6c 61 75 6e 63 68 69 6e 67 20 70 the launching p
6580: 72 6f 63 65 73 73 0a 09 09 09 20 20 28 6c 65 74 rocess.... (let
6590: 20 28 28 69 74 65 6d 73 2d 6c 69 73 74 20 28 69 ((items-list (i
65a0: 74 65 6d 73 3a 67 65 74 2d 69 74 65 6d 73 2d 66 tems:get-items-f
65b0: 72 6f 6d 2d 63 6f 6e 66 69 67 20 74 63 6f 6e 66 rom-config tconf
65c0: 69 67 29 29 29 0a 09 09 09 20 20 20 20 28 69 66 ig))).... (if
65d0: 20 28 6c 69 73 74 3f 20 69 74 65 6d 73 2d 6c 69 (list? items-li
65e0: 73 74 29 0a 09 09 09 09 28 62 65 67 69 6e 0a 09 st).....(begin..
65f0: 09 09 09 20 20 28 74 65 73 74 73 3a 74 65 73 74 ... (tests:test
6600: 71 75 65 75 65 2d 73 65 74 2d 69 74 65 6d 73 21 queue-set-items!
6610: 20 74 65 73 74 2d 72 65 63 6f 72 64 20 69 74 65 test-record ite
6620: 6d 73 2d 6c 69 73 74 29 0a 09 09 09 09 20 20 28 ms-list)..... (
6630: 74 68 72 65 61 64 2d 73 6c 65 65 70 21 20 2a 67 thread-sleep! *g
6640: 6c 6f 62 61 6c 2d 64 65 6c 74 61 2a 29 0a 09 09 lobal-delta*)...
6650: 09 09 20 20 28 6c 6f 6f 70 20 68 65 64 20 74 61 .. (loop hed ta
6660: 6c 20 72 65 72 75 6e 73 29 29 0a 09 09 09 09 28 l reruns)).....(
6670: 62 65 67 69 6e 0a 09 09 09 09 20 20 28 64 65 62 begin..... (deb
6680: 75 67 3a 70 72 69 6e 74 20 30 20 22 45 52 52 4f ug:print 0 "ERRO
6690: 52 3a 20 54 68 65 20 70 72 6f 63 20 66 72 6f 6d R: The proc from
66a0: 20 72 65 61 64 69 6e 67 20 74 68 65 20 73 65 74 reading the set
66b0: 75 70 20 64 69 64 20 6e 6f 74 20 79 69 65 6c 64 up did not yield
66c0: 20 61 20 6c 69 73 74 20 2d 20 70 6c 65 61 73 65 a list - please
66d0: 20 72 65 70 6f 72 74 20 74 68 69 73 22 29 0a 09 report this")..
66e0: 09 09 09 20 20 28 65 78 69 74 20 31 29 29 29 29 ... (exit 1))))
66f0: 29 29 0a 09 09 20 20 20 20 20 20 20 28 28 6e 75 ))... ((nu
6700: 6c 6c 3f 20 66 61 69 6c 73 29 0a 09 09 09 28 64 ll? fails)....(d
6710: 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 ebug:print-info
6720: 34 20 22 66 61 69 6c 73 20 69 73 20 6e 75 6c 6c 4 "fails is null
6730: 2c 20 6d 6f 76 69 6e 67 20 6f 6e 20 69 6e 20 74 , moving on in t
6740: 68 65 20 71 75 65 75 65 20 62 75 74 20 6b 65 65 he queue but kee
6750: 70 69 6e 67 20 22 20 68 65 64 20 22 20 66 6f 72 ping " hed " for
6760: 20 6e 6f 77 22 29 0a 09 09 09 3b 3b 20 6f 6e 6c now")....;; onl
6770: 79 20 69 6e 63 72 65 6d 65 6e 74 20 6e 75 6d 2d y increment num-
6780: 72 65 74 72 69 65 73 20 77 68 65 6e 20 74 68 65 retries when the
6790: 72 65 20 61 72 65 20 6e 6f 20 74 65 73 74 73 20 re are no tests
67a0: 72 75 6e 69 6e 67 0a 09 09 09 28 69 66 20 28 65 runing....(if (e
67b0: 71 3f 20 30 20 28 6c 69 73 74 2d 72 65 66 20 63 q? 0 (list-ref c
67c0: 61 6e 2d 72 75 6e 2d 6d 6f 72 65 20 31 29 29 0a an-run-more 1)).
67d0: 09 09 09 20 20 20 20 28 62 65 67 69 6e 0a 09 09 ... (begin...
67e0: 09 20 20 20 20 20 20 28 69 66 20 28 3e 20 6e 75 . (if (> nu
67f0: 6d 2d 72 65 74 72 69 65 73 20 31 30 30 29 20 3b m-retries 100) ;
6800: 3b 20 66 69 72 73 74 20 31 30 30 20 72 65 74 72 ; first 100 retr
6810: 69 65 73 20 61 72 65 20 6c 6f 77 20 74 69 6d 65 ies are low time
6820: 20 63 6f 73 74 0a 09 09 09 09 20 20 28 74 68 72 cost..... (thr
6830: 65 61 64 2d 73 6c 65 65 70 21 20 28 2b 20 32 20 ead-sleep! (+ 2
6840: 2a 67 6c 6f 62 61 6c 2d 64 65 6c 74 61 2a 29 29 *global-delta*))
6850: 0a 09 09 09 09 20 20 28 74 68 72 65 61 64 2d 73 ..... (thread-s
6860: 6c 65 65 70 21 20 28 2b 20 30 2e 30 31 20 2a 67 leep! (+ 0.01 *g
6870: 6c 6f 62 61 6c 2d 64 65 6c 74 61 2a 29 29 29 0a lobal-delta*))).
6880: 09 09 09 20 20 20 20 20 20 28 73 65 74 21 20 6e ... (set! n
6890: 75 6d 2d 72 65 74 72 69 65 73 20 28 2b 20 6e 75 um-retries (+ nu
68a0: 6d 2d 72 65 74 72 69 65 73 20 31 29 29 29 29 0a m-retries 1)))).
68b0: 09 09 09 28 69 66 20 28 3e 20 6e 75 6d 2d 72 65 ...(if (> num-re
68c0: 74 72 69 65 73 20 20 6d 61 78 2d 72 65 74 72 69 tries max-retri
68d0: 65 73 29 0a 09 09 09 20 20 20 20 28 69 66 20 28 es).... (if (
68e0: 6e 6f 74 20 28 6e 75 6c 6c 3f 20 74 61 6c 29 29 not (null? tal))
68f0: 0a 09 09 09 09 28 6c 6f 6f 70 20 28 63 61 72 20 .....(loop (car
6900: 74 61 6c 29 28 63 64 72 20 74 61 6c 29 20 72 65 tal)(cdr tal) re
6910: 72 75 6e 73 29 29 0a 09 09 09 20 20 20 20 28 6c runs)).... (l
6920: 6f 6f 70 20 28 63 61 72 20 6e 65 77 74 61 6c 29 oop (car newtal)
6930: 28 63 64 72 20 6e 65 77 74 61 6c 29 20 72 65 72 (cdr newtal) rer
6940: 75 6e 73 29 29 29 20 3b 3b 20 61 6e 20 69 73 73 uns))) ;; an iss
6950: 75 65 20 77 69 74 68 20 70 72 65 72 65 71 73 20 ue with prereqs
6960: 6e 6f 74 20 79 65 74 20 6d 65 74 3f 0a 09 09 20 not yet met?...
6970: 20 20 20 20 20 20 28 28 61 6e 64 20 28 6e 6f 74 ((and (not
6980: 20 28 6e 75 6c 6c 3f 20 66 61 69 6c 73 29 29 28 (null? fails))(
6990: 65 71 3f 20 74 65 73 74 6d 6f 64 65 20 27 6e 6f eq? testmode 'no
69a0: 72 6d 61 6c 29 29 0a 09 09 09 28 64 65 62 75 67 rmal))....(debug
69b0: 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 31 20 22 74 :print-info 1 "t
69c0: 65 73 74 20 22 20 20 68 65 64 20 22 20 28 6d 6f est " hed " (mo
69d0: 64 65 3d 22 20 74 65 73 74 6d 6f 64 65 20 22 29 de=" testmode ")
69e0: 20 68 61 73 20 66 61 69 6c 65 64 20 70 72 65 72 has failed prer
69f0: 65 71 75 69 73 69 74 65 28 73 29 3b 20 22 0a 09 equisite(s); "..
6a00: 09 09 09 20 20 20 20 20 28 73 74 72 69 6e 67 2d ... (string-
6a10: 69 6e 74 65 72 73 70 65 72 73 65 20 28 6d 61 70 intersperse (map
6a20: 20 28 6c 61 6d 62 64 61 20 28 74 29 28 63 6f 6e (lambda (t)(con
6a30: 63 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 74 c (db:test-get-t
6a40: 65 73 74 6e 61 6d 65 20 74 29 20 22 3a 22 20 28 estname t) ":" (
6a50: 64 62 3a 74 65 73 74 2d 67 65 74 2d 73 74 61 74 db:test-get-stat
6a60: 65 20 74 29 22 2f 22 28 64 62 3a 74 65 73 74 2d e t)"/"(db:test-
6a70: 67 65 74 2d 73 74 61 74 75 73 20 74 29 29 29 20 get-status t)))
6a80: 66 61 69 6c 73 29 20 22 2c 20 22 29 0a 09 09 09 fails) ", ")....
6a90: 09 20 20 20 20 20 22 2c 20 72 65 6d 6f 76 69 6e . ", removin
6aa0: 67 20 69 74 20 66 72 6f 6d 20 74 6f 2d 64 6f 20 g it from to-do
6ab0: 6c 69 73 74 22 29 0a 09 09 09 28 69 66 20 28 6e list")....(if (n
6ac0: 6f 74 20 28 6e 75 6c 6c 3f 20 74 61 6c 29 29 0a ot (null? tal)).
6ad0: 09 09 09 20 20 20 20 28 62 65 67 69 6e 0a 09 09 ... (begin...
6ae0: 09 20 20 20 20 20 20 28 74 68 72 65 61 64 2d 73 . (thread-s
6af0: 6c 65 65 70 21 20 2a 67 6c 6f 62 61 6c 2d 64 65 leep! *global-de
6b00: 6c 74 61 2a 29 0a 09 09 09 20 20 20 20 20 20 28 lta*).... (
6b10: 6c 6f 6f 70 20 28 63 61 72 20 74 61 6c 29 28 63 loop (car tal)(c
6b20: 64 72 20 74 61 6c 29 28 63 6f 6e 73 20 68 65 64 dr tal)(cons hed
6b30: 20 72 65 72 75 6e 73 29 29 29 29 29 0a 09 09 20 reruns)))))...
6b40: 20 20 20 20 20 20 28 65 6c 73 65 0a 09 09 09 28 (else....(
6b50: 64 65 62 75 67 3a 70 72 69 6e 74 20 38 20 22 45 debug:print 8 "E
6b60: 52 52 4f 52 3a 20 4e 6f 20 68 61 6e 64 6c 65 72 RROR: No handler
6b70: 20 66 6f 72 20 74 68 69 73 20 63 6f 6e 64 69 74 for this condit
6b80: 69 6f 6e 2e 22 29 0a 09 09 09 28 74 68 72 65 61 ion.")....(threa
6b90: 64 2d 73 6c 65 65 70 21 20 28 2b 20 31 20 2a 67 d-sleep! (+ 1 *g
6ba0: 6c 6f 62 61 6c 2d 64 65 6c 74 61 2a 29 29 0a 09 lobal-delta*))..
6bb0: 09 09 28 6c 6f 6f 70 20 28 63 61 72 20 6e 65 77 ..(loop (car new
6bc0: 74 61 6c 29 28 63 64 72 20 6e 65 77 74 61 6c 29 tal)(cdr newtal)
6bd0: 20 72 65 72 75 6e 73 29 29 29 29 20 3b 3b 20 45 reruns)))) ;; E
6be0: 4e 44 20 4f 46 20 49 46 20 43 41 4e 20 52 55 4e ND OF IF CAN RUN
6bf0: 20 4d 4f 52 45 0a 0a 09 09 20 20 20 20 3b 3b 20 MORE.... ;;
6c00: 69 66 20 63 61 6e 27 74 20 72 75 6e 20 6d 6f 72 if can't run mor
6c10: 65 20 6a 75 73 74 20 6c 6f 6f 70 20 77 69 74 68 e just loop with
6c20: 20 6e 65 78 74 20 70 6f 73 73 69 62 6c 65 20 74 next possible t
6c30: 65 73 74 0a 09 09 20 20 20 20 28 62 65 67 69 6e est... (begin
6c40: 0a 09 09 20 20 20 20 20 20 28 64 65 62 75 67 3a ... (debug:
6c50: 70 72 69 6e 74 2d 69 6e 66 6f 20 34 20 22 70 72 print-info 4 "pr
6c60: 6f 63 65 73 73 69 6e 67 20 74 68 65 20 63 61 73 ocessing the cas
6c70: 65 20 77 69 74 68 20 61 20 6c 61 6d 62 64 61 20 e with a lambda
6c80: 66 6f 72 20 69 74 65 6d 73 20 6f 72 20 27 68 61 for items or 'ha
6c90: 76 65 2d 70 72 6f 63 65 64 75 72 65 2e 20 4d 6f ve-procedure. Mo
6ca0: 76 69 6e 67 20 74 68 72 6f 75 67 68 20 74 68 65 ving through the
6cb0: 20 71 75 65 75 65 20 77 69 74 68 6f 75 74 20 64 queue without d
6cc0: 72 6f 70 70 69 6e 67 20 22 20 68 65 64 29 0a 09 ropping " hed)..
6cd0: 09 20 20 20 20 20 20 28 74 68 72 65 61 64 2d 73 . (thread-s
6ce0: 6c 65 65 70 21 20 28 2b 20 32 20 2a 67 6c 6f 62 leep! (+ 2 *glob
6cf0: 61 6c 2d 64 65 6c 74 61 2a 29 29 0a 09 09 20 20 al-delta*))...
6d00: 20 20 20 20 28 6c 6f 6f 70 20 28 63 61 72 20 6e (loop (car n
6d10: 65 77 74 61 6c 29 28 63 64 72 20 6e 65 77 74 61 ewtal)(cdr newta
6d20: 6c 29 20 72 65 72 75 6e 73 29 29 29 29 29 20 3b l) reruns))))) ;
6d30: 3b 20 45 4e 44 20 4f 46 20 28 6f 72 20 28 70 72 ; END OF (or (pr
6d40: 6f 63 65 64 75 72 65 3f 20 69 74 65 6d 73 29 28 ocedure? items)(
6d50: 65 71 3f 20 69 74 65 6d 73 20 27 68 61 76 65 2d eq? items 'have-
6d60: 70 72 6f 63 65 64 75 72 65 29 29 0a 09 20 20 20 procedure))..
6d70: 20 20 0a 09 20 20 20 20 20 3b 3b 20 74 68 69 73 .. ;; this
6d80: 20 63 61 73 65 20 73 68 6f 75 6c 64 20 6e 6f 74 case should not
6d90: 20 68 61 70 70 65 6e 2c 20 61 64 64 65 64 20 74 happen, added t
6da0: 6f 20 68 65 6c 70 20 63 61 74 63 68 20 61 6e 79 o help catch any
6db0: 20 62 75 67 73 0a 09 20 20 20 20 20 28 28 61 6e bugs.. ((an
6dc0: 64 20 28 6c 69 73 74 3f 20 69 74 65 6d 73 29 20 d (list? items)
6dd0: 69 74 65 6d 64 61 74 29 0a 09 20 20 20 20 20 20 itemdat)..
6de0: 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 22 (debug:print 0 "
6df0: 45 52 52 4f 52 3a 20 53 68 6f 75 6c 64 20 6e 6f ERROR: Should no
6e00: 74 20 68 61 76 65 20 61 20 6c 69 73 74 20 6f 66 t have a list of
6e10: 20 69 74 65 6d 73 20 69 6e 20 61 20 74 65 73 74 items in a test
6e20: 20 61 6e 64 20 74 68 65 20 69 74 65 6d 73 70 61 and the itemspa
6e30: 74 68 20 73 65 74 20 2d 20 70 6c 65 61 73 65 20 th set - please
6e40: 72 65 70 6f 72 74 20 74 68 69 73 22 29 0a 09 20 report this")..
6e50: 20 20 20 20 20 28 65 78 69 74 20 31 29 29 0a 09 (exit 1))..
6e60: 20 20 20 20 20 28 28 6e 6f 74 20 28 6e 75 6c 6c ((not (null
6e70: 3f 20 72 65 72 75 6e 73 29 29 0a 09 20 20 20 20 ? reruns))..
6e80: 20 20 28 6c 65 74 2a 20 28 28 6e 65 77 6c 73 74 (let* ((newlst
6e90: 20 28 74 65 73 74 73 3a 66 69 6c 74 65 72 2d 6e (tests:filter-n
6ea0: 6f 6e 2d 72 75 6e 6e 61 62 6c 65 20 72 75 6e 2d on-runnable run-
6eb0: 69 64 20 74 61 6c 20 74 65 73 74 2d 72 65 63 6f id tal test-reco
6ec0: 72 64 73 29 29 20 3b 3b 20 69 2e 65 2e 20 6e 6f rds)) ;; i.e. no
6ed0: 74 20 46 41 49 4c 2c 20 57 41 49 56 45 44 2c 20 t FAIL, WAIVED,
6ee0: 49 4e 43 4f 4d 50 4c 45 54 45 2c 20 50 41 53 53 INCOMPLETE, PASS
6ef0: 2c 20 4b 49 4c 4c 45 44 2c 0a 09 09 20 20 20 20 , KILLED,...
6f00: 20 28 6a 75 6e 6b 65 64 20 28 6c 73 65 74 2d 64 (junked (lset-d
6f10: 69 66 66 65 72 65 6e 63 65 20 65 71 75 61 6c 3f ifference equal?
6f20: 20 74 61 6c 20 6e 65 77 6c 73 74 29 29 29 0a 09 tal newlst)))..
6f30: 09 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e .(debug:print-in
6f40: 66 6f 20 34 20 22 66 75 6c 6c 20 64 72 6f 70 20 fo 4 "full drop
6f50: 74 68 72 6f 75 67 68 2c 20 69 66 20 72 65 72 75 through, if reru
6f60: 6e 73 20 69 73 20 6c 65 73 73 20 74 68 61 6e 20 ns is less than
6f70: 31 30 30 20 77 65 20 77 69 6c 6c 20 66 6f 72 63 100 we will forc
6f80: 65 20 72 65 74 72 79 20 74 68 65 6d 2c 20 72 65 e retry them, re
6f90: 72 75 6e 73 3d 22 20 72 65 72 75 6e 73 20 22 2c runs=" reruns ",
6fa0: 20 74 61 6c 3d 22 20 74 61 6c 29 0a 09 09 28 69 tal=" tal)...(i
6fb0: 66 20 28 3c 20 6e 75 6d 2d 72 65 74 72 69 65 73 f (< num-retries
6fc0: 20 6d 61 78 2d 72 65 74 72 69 65 73 29 0a 09 09 max-retries)...
6fd0: 20 20 20 20 28 73 65 74 21 20 6e 65 77 6c 73 74 (set! newlst
6fe0: 20 28 61 70 70 65 6e 64 20 72 65 72 75 6e 73 20 (append reruns
6ff0: 6e 65 77 6c 73 74 29 29 29 0a 09 09 28 73 65 74 newlst)))...(set
7000: 21 20 6e 75 6d 2d 72 65 74 72 69 65 73 20 28 2b ! num-retries (+
7010: 20 6e 75 6d 2d 72 65 74 72 69 65 73 20 31 29 29 num-retries 1))
7020: 0a 09 09 28 74 68 72 65 61 64 2d 73 6c 65 65 70 ...(thread-sleep
7030: 21 20 28 2b 20 31 20 2a 67 6c 6f 62 61 6c 2d 64 ! (+ 1 *global-d
7040: 65 6c 74 61 2a 29 29 0a 09 09 28 69 66 20 28 6e elta*))...(if (n
7050: 6f 74 20 28 6e 75 6c 6c 3f 20 6e 65 77 6c 73 74 ot (null? newlst
7060: 29 29 0a 09 09 20 20 20 20 3b 3b 20 73 69 6e 63 ))... ;; sinc
7070: 65 20 72 65 72 75 6e 73 20 68 61 76 65 20 62 65 e reruns have be
7080: 65 6e 20 74 61 63 6b 65 64 20 6f 6e 20 74 6f 20 en tacked on to
7090: 6e 65 77 6c 73 74 20 63 72 65 61 74 65 20 6e 65 newlst create ne
70a0: 77 20 72 65 72 75 6e 73 20 66 72 6f 6d 20 6a 75 w reruns from ju
70b0: 6e 6b 65 64 0a 09 09 20 20 20 20 28 6c 6f 6f 70 nked... (loop
70c0: 20 28 63 61 72 20 6e 65 77 6c 73 74 29 28 63 64 (car newlst)(cd
70d0: 72 20 6e 65 77 6c 73 74 29 28 64 65 6c 65 74 65 r newlst)(delete
70e0: 2d 64 75 70 6c 69 63 61 74 65 73 20 6a 75 6e 6b -duplicates junk
70f0: 65 64 29 29 29 29 29 0a 09 20 20 20 20 20 28 28 ed))))).. ((
7100: 6e 6f 74 20 28 6e 75 6c 6c 3f 20 74 61 6c 29 29 not (null? tal))
7110: 0a 09 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 .. (debug:p
7120: 72 69 6e 74 2d 69 6e 66 6f 20 34 20 22 49 27 6d rint-info 4 "I'm
7130: 20 70 72 65 74 74 79 20 73 75 72 65 20 49 20 73 pretty sure I s
7140: 68 6f 75 6c 64 6e 27 74 20 67 65 74 20 68 65 72 houldn't get her
7150: 65 2e 22 29 29 0a 09 20 20 20 20 20 28 65 6c 73 e.")).. (els
7160: 65 0a 09 20 20 20 20 20 20 28 64 65 62 75 67 3a e.. (debug:
7170: 70 72 69 6e 74 2d 69 6e 66 6f 20 34 20 22 45 78 print-info 4 "Ex
7180: 69 74 69 6e 67 20 6c 6f 6f 70 20 77 69 74 68 2e iting loop with.
7190: 2e 2e 5c 6e 20 20 68 65 64 3d 22 20 68 65 64 20 ..\n hed=" hed
71a0: 22 5c 6e 20 20 74 61 6c 3d 22 20 74 61 6c 20 22 "\n tal=" tal "
71b0: 5c 6e 20 20 72 65 72 75 6e 73 3d 22 20 72 65 72 \n reruns=" rer
71c0: 75 6e 73 29 29 0a 09 20 20 20 20 20 29 29 29 29 uns)).. ))))
71d0: 20 3b 3b 20 4c 45 54 2a 20 28 28 74 65 73 74 2d ;; LET* ((test-
71e0: 72 65 63 6f 72 64 0a 0a 20 20 20 20 3b 3b 20 77 record.. ;; w
71f0: 65 20 67 65 74 20 68 65 72 65 20 6f 6e 20 22 64 e get here on "d
7200: 72 6f 70 20 74 68 72 6f 75 67 68 22 20 2d 20 6c rop through" - l
7210: 6f 6f 70 20 66 6f 72 20 6e 65 78 74 20 74 65 73 oop for next tes
7220: 74 20 69 6e 20 71 75 65 75 65 0a 20 20 20 20 3b t in queue. ;
7230: 3b 20 46 49 58 4d 45 21 21 21 21 20 54 48 49 53 ; FIXME!!!! THIS
7240: 20 53 48 4f 55 4c 44 20 4e 4f 54 20 52 45 51 55 SHOULD NOT REQU
7250: 49 52 45 20 41 4e 20 45 58 49 54 21 21 21 21 21 IRE AN EXIT!!!!!
7260: 21 21 0a 20 20 20 20 0a 20 20 20 20 28 64 65 62 !!. . (deb
7270: 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 31 20 ug:print-info 1
7280: 22 41 6c 6c 20 74 65 73 74 73 20 6c 61 75 6e 63 "All tests launc
7290: 68 65 64 22 29 0a 20 20 20 20 28 74 68 72 65 61 hed"). (threa
72a0: 64 2d 73 6c 65 65 70 21 20 30 2e 35 29 0a 20 20 d-sleep! 0.5).
72b0: 20 20 3b 3b 20 46 49 58 4d 45 21 20 54 68 69 73 ;; FIXME! This
72c0: 20 68 61 72 73 68 20 65 78 69 74 20 73 68 6f 75 harsh exit shou
72d0: 6c 64 20 6e 6f 74 20 62 65 20 6e 65 63 65 73 73 ld not be necess
72e0: 61 72 79 2e 2e 2e 2e 0a 20 20 20 20 3b 3b 20 28 ary..... ;; (
72f0: 69 66 20 28 6e 6f 74 20 2a 72 75 6e 72 65 6d 6f if (not *runremo
7300: 74 65 2a 29 28 65 78 69 74 29 29 20 3b 3b 20 0a te*)(exit)) ;; .
7310: 20 20 20 20 23 66 29 29 20 3b 3b 20 72 65 74 75 #f)) ;; retu
7320: 72 6e 20 61 20 23 66 20 61 73 20 61 20 68 69 6e rn a #f as a hin
7330: 74 20 74 68 61 74 20 77 65 20 61 72 65 20 64 6f t that we are do
7340: 6e 65 0a 20 20 3b 3b 20 48 65 72 65 20 77 65 20 ne. ;; Here we
7350: 6e 65 65 64 20 74 6f 20 63 68 65 63 6b 20 74 68 need to check th
7360: 61 74 20 61 6c 6c 20 74 68 65 20 74 65 73 74 73 at all the tests
7370: 20 72 65 6d 61 69 6e 69 6e 67 20 74 6f 20 62 65 remaining to be
7380: 20 72 75 6e 20 61 72 65 20 65 6c 69 67 69 62 6c run are eligibl
7390: 65 20 74 6f 20 72 75 6e 0a 20 20 3b 3b 20 61 6e e to run. ;; an
73a0: 64 20 61 72 65 20 6e 6f 74 20 62 6c 6f 63 6b 65 d are not blocke
73b0: 64 20 62 79 20 66 61 69 6c 65 64 0a 20 20 0a 0a d by failed. ..
73c0: 3b 3b 20 70 61 72 65 6e 74 2d 74 65 73 74 20 69 ;; parent-test i
73d0: 73 20 74 68 65 72 65 20 61 73 20 61 20 70 6c 61 s there as a pla
73e0: 63 65 68 6f 6c 64 65 72 20 66 6f 72 20 77 68 65 ceholder for whe
73f0: 6e 20 70 61 72 65 6e 74 2d 74 65 73 74 73 20 63 n parent-tests c
7400: 61 6e 20 62 65 20 72 75 6e 20 61 73 20 61 20 73 an be run as a s
7410: 65 74 75 70 20 73 74 65 70 0a 28 64 65 66 69 6e etup step.(defin
7420: 65 20 28 72 75 6e 3a 74 65 73 74 20 72 75 6e 2d e (run:test run-
7430: 69 64 20 72 75 6e 6e 61 6d 65 20 6b 65 79 76 61 id runname keyva
7440: 6c 6c 73 74 20 74 65 73 74 2d 72 65 63 6f 72 64 llst test-record
7450: 20 66 6c 61 67 73 20 70 61 72 65 6e 74 2d 74 65 flags parent-te
7460: 73 74 29 0a 20 20 3b 3b 20 41 6c 6c 20 74 68 65 st). ;; All the
7470: 73 65 20 76 61 72 73 20 6d 69 67 68 74 20 62 65 se vars might be
7480: 20 72 65 66 65 72 65 6e 63 65 64 20 62 79 20 74 referenced by t
7490: 68 65 20 74 65 73 74 63 6f 6e 66 69 67 20 66 69 he testconfig fi
74a0: 6c 65 20 72 65 61 64 65 72 0a 20 20 28 6c 65 74 le reader. (let
74b0: 2a 20 28 28 74 65 73 74 2d 6e 61 6d 65 20 20 20 * ((test-name
74c0: 20 28 74 65 73 74 73 3a 74 65 73 74 71 75 65 75 (tests:testqueu
74d0: 65 2d 67 65 74 2d 74 65 73 74 6e 61 6d 65 20 20 e-get-testname
74e0: 20 74 65 73 74 2d 72 65 63 6f 72 64 29 29 0a 09 test-record))..
74f0: 20 28 74 65 73 74 2d 77 61 69 74 6f 6e 73 20 28 (test-waitons (
7500: 74 65 73 74 73 3a 74 65 73 74 71 75 65 75 65 2d tests:testqueue-
7510: 67 65 74 2d 77 61 69 74 6f 6e 73 20 20 20 20 74 get-waitons t
7520: 65 73 74 2d 72 65 63 6f 72 64 29 29 0a 09 20 28 est-record)).. (
7530: 74 65 73 74 2d 63 6f 6e 66 20 20 20 20 28 74 65 test-conf (te
7540: 73 74 73 3a 74 65 73 74 71 75 65 75 65 2d 67 65 sts:testqueue-ge
7550: 74 2d 74 65 73 74 63 6f 6e 66 69 67 20 74 65 73 t-testconfig tes
7560: 74 2d 72 65 63 6f 72 64 29 29 0a 09 20 28 69 74 t-record)).. (it
7570: 65 6d 64 61 74 20 20 20 20 20 20 28 74 65 73 74 emdat (test
7580: 73 3a 74 65 73 74 71 75 65 75 65 2d 67 65 74 2d s:testqueue-get-
7590: 69 74 65 6d 64 61 74 20 20 20 20 74 65 73 74 2d itemdat test-
75a0: 72 65 63 6f 72 64 29 29 0a 09 20 28 74 65 73 74 record)).. (test
75b0: 2d 70 61 74 68 20 20 20 20 28 63 6f 6e 63 20 2a -path (conc *
75c0: 74 6f 70 70 61 74 68 2a 20 22 2f 74 65 73 74 73 toppath* "/tests
75d0: 2f 22 20 74 65 73 74 2d 6e 61 6d 65 29 29 20 3b /" test-name)) ;
75e0: 3b 20 63 6f 75 6c 64 20 75 73 65 20 74 65 73 74 ; could use test
75f0: 73 3a 67 65 74 2d 74 65 73 74 63 6f 6e 66 69 67 s:get-testconfig
7600: 20 68 65 72 65 20 2e 2e 2e 0a 09 20 28 66 6f 72 here ..... (for
7610: 63 65 20 20 20 20 20 20 20 20 28 68 61 73 68 2d ce (hash-
7620: 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c table-ref/defaul
7630: 74 20 66 6c 61 67 73 20 22 2d 66 6f 72 63 65 22 t flags "-force"
7640: 20 23 66 29 29 0a 09 20 28 72 65 72 75 6e 20 20 #f)).. (rerun
7650: 20 20 20 20 20 20 28 68 61 73 68 2d 74 61 62 6c (hash-tabl
7660: 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 66 6c e-ref/default fl
7670: 61 67 73 20 22 2d 72 65 72 75 6e 22 20 23 66 29 ags "-rerun" #f)
7680: 29 0a 09 20 28 6b 65 65 70 67 6f 69 6e 67 20 20 ).. (keepgoing
7690: 20 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 (hash-table-re
76a0: 66 2f 64 65 66 61 75 6c 74 20 66 6c 61 67 73 20 f/default flags
76b0: 22 2d 6b 65 65 70 67 6f 69 6e 67 22 20 23 66 29 "-keepgoing" #f)
76c0: 29 0a 09 20 28 69 74 65 6d 2d 70 61 74 68 20 20 ).. (item-path
76d0: 20 20 20 22 22 29 0a 09 20 28 64 62 20 20 20 20 "").. (db
76e0: 20 20 20 20 20 20 20 23 66 29 29 0a 20 20 20 20 #f)).
76f0: 28 64 65 62 75 67 3a 70 72 69 6e 74 20 34 0a 09 (debug:print 4..
7700: 09 20 22 74 65 73 74 2d 63 6f 6e 66 69 67 3a 20 . "test-config:
7710: 22 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 3e 61 " (hash-table->a
7720: 6c 69 73 74 20 74 65 73 74 2d 63 6f 6e 66 29 0a list test-conf).
7730: 09 09 20 22 5c 6e 20 20 20 69 74 65 6d 64 61 74 .. "\n itemdat
7740: 3a 20 22 20 69 74 65 6d 64 61 74 0a 09 09 20 29 : " itemdat... )
7750: 0a 20 20 20 20 3b 3b 20 73 65 74 74 69 6e 67 20 . ;; setting
7760: 69 74 65 6d 64 61 74 20 74 6f 20 61 20 6c 69 73 itemdat to a lis
7770: 74 20 69 66 20 69 74 20 69 73 20 23 66 0a 20 20 t if it is #f.
7780: 20 20 28 69 66 20 28 6e 6f 74 20 69 74 65 6d 64 (if (not itemd
7790: 61 74 29 28 73 65 74 21 20 69 74 65 6d 64 61 74 at)(set! itemdat
77a0: 20 27 28 29 29 29 0a 20 20 20 20 28 73 65 74 21 '())). (set!
77b0: 20 69 74 65 6d 2d 70 61 74 68 20 28 69 74 65 6d item-path (item
77c0: 2d 6c 69 73 74 2d 3e 70 61 74 68 20 69 74 65 6d -list->path item
77d0: 64 61 74 29 29 0a 20 20 20 20 28 64 65 62 75 67 dat)). (debug
77e0: 3a 70 72 69 6e 74 20 32 20 22 41 74 74 65 6d 70 :print 2 "Attemp
77f0: 74 69 6e 67 20 74 6f 20 6c 61 75 6e 63 68 20 74 ting to launch t
7800: 65 73 74 20 22 20 74 65 73 74 2d 6e 61 6d 65 20 est " test-name
7810: 28 69 66 20 28 65 71 75 61 6c 3f 20 69 74 65 6d (if (equal? item
7820: 2d 70 61 74 68 20 22 2f 22 29 20 22 2f 22 20 69 -path "/") "/" i
7830: 74 65 6d 2d 70 61 74 68 29 29 0a 20 20 20 20 28 tem-path)). (
7840: 73 65 74 65 6e 76 20 22 4d 54 5f 54 45 53 54 5f setenv "MT_TEST_
7850: 4e 41 4d 45 22 20 74 65 73 74 2d 6e 61 6d 65 29 NAME" test-name)
7860: 20 3b 3b 20 0a 20 20 20 20 28 73 65 74 65 6e 76 ;; . (setenv
7870: 20 22 4d 54 5f 52 55 4e 4e 41 4d 45 22 20 20 20 "MT_RUNNAME"
7880: 72 75 6e 6e 61 6d 65 29 0a 20 20 20 20 28 73 65 runname). (se
7890: 74 2d 6d 65 67 61 74 65 73 74 2d 65 6e 76 2d 76 t-megatest-env-v
78a0: 61 72 73 20 72 75 6e 2d 69 64 29 20 3b 3b 20 74 ars run-id) ;; t
78b0: 68 65 73 65 20 6d 61 79 20 62 65 20 6e 65 65 64 hese may be need
78c0: 65 64 20 62 79 20 74 68 65 20 6c 61 75 6e 63 68 ed by the launch
78d0: 69 6e 67 20 70 72 6f 63 65 73 73 0a 20 20 20 20 ing process.
78e0: 28 63 68 61 6e 67 65 2d 64 69 72 65 63 74 6f 72 (change-director
78f0: 79 20 2a 74 6f 70 70 61 74 68 2a 29 0a 0a 20 20 y *toppath*)..
7900: 20 20 3b 3b 20 48 65 72 65 20 69 73 20 77 68 65 ;; Here is whe
7910: 72 65 20 74 68 65 20 74 65 73 74 5f 6d 65 74 61 re the test_meta
7920: 20 74 61 62 6c 65 20 69 73 20 62 65 73 74 20 75 table is best u
7930: 70 64 61 74 65 64 0a 20 20 20 20 3b 3b 20 59 65 pdated. ;; Ye
7940: 73 2c 20 61 6e 6f 74 68 65 72 20 75 73 65 20 6f s, another use o
7950: 66 20 61 20 67 6c 6f 62 61 6c 20 66 6f 72 20 63 f a global for c
7960: 61 63 68 69 6e 67 2e 20 4e 65 65 64 20 61 20 62 aching. Need a b
7970: 65 74 74 65 72 20 77 61 79 3f 0a 20 20 20 20 28 etter way?. (
7980: 69 66 20 28 6e 6f 74 20 28 68 61 73 68 2d 74 61 if (not (hash-ta
7990: 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 ble-ref/default
79a0: 2a 74 65 73 74 2d 6d 65 74 61 2d 75 70 64 61 74 *test-meta-updat
79b0: 65 64 2a 20 74 65 73 74 2d 6e 61 6d 65 20 23 66 ed* test-name #f
79c0: 29 29 0a 20 20 20 20 20 20 20 20 28 62 65 67 69 )). (begi
79d0: 6e 0a 09 20 20 20 28 68 61 73 68 2d 74 61 62 6c n.. (hash-tabl
79e0: 65 2d 73 65 74 21 20 2a 74 65 73 74 2d 6d 65 74 e-set! *test-met
79f0: 61 2d 75 70 64 61 74 65 64 2a 20 74 65 73 74 2d a-updated* test-
7a00: 6e 61 6d 65 20 23 74 29 0a 20 20 20 20 20 20 20 name #t).
7a10: 20 20 20 20 28 6f 70 65 6e 2d 72 75 6e 2d 63 6c (open-run-cl
7a20: 6f 73 65 20 72 75 6e 73 3a 75 70 64 61 74 65 2d ose runs:update-
7a30: 74 65 73 74 5f 6d 65 74 61 20 64 62 20 74 65 73 test_meta db tes
7a40: 74 2d 6e 61 6d 65 20 74 65 73 74 2d 63 6f 6e 66 t-name test-conf
7a50: 29 29 29 0a 20 20 20 20 0a 20 20 20 20 3b 3b 20 ))). . ;;
7a60: 28 6c 61 6d 62 64 61 20 28 69 74 65 6d 64 61 74 (lambda (itemdat
7a70: 29 20 3b 3b 3b 20 28 28 72 69 70 65 6e 65 73 73 ) ;;; ((ripeness
7a80: 20 22 6f 76 65 72 72 69 70 65 22 29 20 28 74 65 "overripe") (te
7a90: 6d 70 65 72 61 74 75 72 65 20 22 63 6f 6f 6c 22 mperature "cool"
7aa0: 29 20 28 73 65 61 73 6f 6e 20 22 73 75 6d 6d 65 ) (season "summe
7ab0: 72 22 29 29 0a 20 20 20 20 28 6c 65 74 2a 20 28 r")). (let* (
7ac0: 28 6e 65 77 2d 74 65 73 74 2d 70 61 74 68 20 28 (new-test-path (
7ad0: 73 74 72 69 6e 67 2d 69 6e 74 65 72 73 70 65 72 string-intersper
7ae0: 73 65 20 28 63 6f 6e 73 20 74 65 73 74 2d 70 61 se (cons test-pa
7af0: 74 68 20 28 6d 61 70 20 63 61 64 72 20 69 74 65 th (map cadr ite
7b00: 6d 64 61 74 29 29 20 22 2f 22 29 29 0a 09 20 20 mdat)) "/"))..
7b10: 20 28 6e 65 77 2d 74 65 73 74 2d 6e 61 6d 65 20 (new-test-name
7b20: 28 69 66 20 28 65 71 75 61 6c 3f 20 69 74 65 6d (if (equal? item
7b30: 2d 70 61 74 68 20 22 22 29 20 74 65 73 74 2d 6e -path "") test-n
7b40: 61 6d 65 20 28 63 6f 6e 63 20 74 65 73 74 2d 6e ame (conc test-n
7b50: 61 6d 65 20 22 2f 22 20 69 74 65 6d 2d 70 61 74 ame "/" item-pat
7b60: 68 29 29 29 20 3b 3b 20 6a 75 73 74 20 6e 65 65 h))) ;; just nee
7b70: 64 20 69 74 20 74 6f 20 62 65 20 75 6e 69 71 75 d it to be uniqu
7b80: 65 0a 09 20 20 20 28 74 65 73 74 2d 69 64 20 20 e.. (test-id
7b90: 20 20 20 20 20 28 63 64 62 3a 72 65 6d 6f 74 65 (cdb:remote
7ba0: 2d 72 75 6e 20 64 62 3a 67 65 74 2d 74 65 73 74 -run db:get-test
7bb0: 2d 69 64 20 23 66 20 20 72 75 6e 2d 69 64 20 74 -id #f run-id t
7bc0: 65 73 74 2d 6e 61 6d 65 20 69 74 65 6d 2d 70 61 est-name item-pa
7bd0: 74 68 29 29 0a 09 20 20 20 28 74 65 73 74 64 61 th)).. (testda
7be0: 74 20 20 20 20 20 20 20 28 63 64 62 3a 67 65 74 t (cdb:get
7bf0: 2d 74 65 73 74 2d 69 6e 66 6f 2d 62 79 2d 69 64 -test-info-by-id
7c00: 20 2a 72 75 6e 72 65 6d 6f 74 65 2a 20 74 65 73 *runremote* tes
7c10: 74 2d 69 64 29 29 29 0a 20 20 20 20 20 20 28 69 t-id))). (i
7c20: 66 20 28 6e 6f 74 20 74 65 73 74 64 61 74 29 0a f (not testdat).
7c30: 09 20 20 28 62 65 67 69 6e 0a 09 20 20 20 20 3b . (begin.. ;
7c40: 3b 20 65 6e 73 75 72 65 20 74 68 61 74 20 74 68 ; ensure that th
7c50: 65 20 70 61 74 68 20 65 78 69 73 74 73 20 62 65 e path exists be
7c60: 66 6f 72 65 20 72 65 67 69 73 74 65 72 69 6e 67 fore registering
7c70: 20 74 68 65 20 74 65 73 74 0a 09 20 20 20 20 3b the test.. ;
7c80: 3b 20 4e 4f 50 45 3a 20 43 61 6e 6e 6f 74 21 20 ; NOPE: Cannot!
7c90: 44 6f 6e 27 74 20 6b 6e 6f 77 20 79 65 74 20 77 Don't know yet w
7ca0: 68 69 63 68 20 64 69 73 6b 20 61 72 65 61 20 77 hich disk area w
7cb0: 69 6c 6c 20 62 65 20 61 73 73 69 67 6e 65 64 2e ill be assigned.
7cc0: 2e 2e 2e 0a 09 20 20 20 20 3b 3b 20 28 73 79 73 ..... ;; (sys
7cd0: 74 65 6d 20 28 63 6f 6e 63 20 22 6d 6b 64 69 72 tem (conc "mkdir
7ce0: 20 2d 70 20 22 20 6e 65 77 2d 74 65 73 74 2d 70 -p " new-test-p
7cf0: 61 74 68 29 29 0a 09 20 20 20 20 3b 3b 0a 09 20 ath)).. ;;..
7d00: 20 20 20 3b 3b 20 28 6f 70 65 6e 2d 72 75 6e 2d ;; (open-run-
7d10: 63 6c 6f 73 65 20 74 65 73 74 73 3a 72 65 67 69 close tests:regi
7d20: 73 74 65 72 2d 74 65 73 74 20 64 62 20 72 75 6e ster-test db run
7d30: 2d 69 64 20 74 65 73 74 2d 6e 61 6d 65 20 69 74 -id test-name it
7d40: 65 6d 2d 70 61 74 68 29 0a 09 20 20 20 20 3b 3b em-path).. ;;
7d50: 0a 09 20 20 20 20 3b 3b 20 4e 42 2f 2f 20 66 6f .. ;; NB// fo
7d60: 72 20 74 68 65 20 61 62 6f 76 65 20 6c 69 6e 65 r the above line
7d70: 2e 20 49 20 77 61 6e 74 20 74 68 65 20 74 65 73 . I want the tes
7d80: 74 20 74 6f 20 62 65 20 72 65 67 69 73 74 65 72 t to be register
7d90: 65 64 20 6c 6f 6e 67 20 62 65 66 6f 72 65 20 74 ed long before t
7da0: 68 69 73 20 72 6f 75 74 69 6e 65 20 67 65 74 73 his routine gets
7db0: 20 63 61 6c 6c 65 64 21 0a 09 20 20 20 20 3b 3b called!.. ;;
7dc0: 0a 09 20 20 20 20 28 73 65 74 21 20 74 65 73 74 .. (set! test
7dd0: 2d 69 64 20 28 6f 70 65 6e 2d 72 75 6e 2d 63 6c -id (open-run-cl
7de0: 6f 73 65 20 64 62 3a 67 65 74 2d 74 65 73 74 2d ose db:get-test-
7df0: 69 64 20 64 62 20 72 75 6e 2d 69 64 20 74 65 73 id db run-id tes
7e00: 74 2d 6e 61 6d 65 20 69 74 65 6d 2d 70 61 74 68 t-name item-path
7e10: 29 29 0a 09 20 20 20 20 28 69 66 20 28 6e 6f 74 )).. (if (not
7e20: 20 74 65 73 74 2d 69 64 29 0a 09 09 28 62 65 67 test-id)...(beg
7e30: 69 6e 0a 09 09 20 20 28 64 65 62 75 67 3a 70 72 in... (debug:pr
7e40: 69 6e 74 20 32 20 22 57 41 52 4e 3a 20 54 65 73 int 2 "WARN: Tes
7e50: 74 20 6e 6f 74 20 70 72 65 2d 63 72 65 61 74 65 t not pre-create
7e60: 64 3f 20 74 65 73 74 2d 6e 61 6d 65 3d 22 20 74 d? test-name=" t
7e70: 65 73 74 2d 6e 61 6d 65 20 22 2c 20 69 74 65 6d est-name ", item
7e80: 2d 70 61 74 68 3d 22 20 69 74 65 6d 2d 70 61 74 -path=" item-pat
7e90: 68 20 22 2c 20 72 75 6e 2d 69 64 3d 22 20 72 75 h ", run-id=" ru
7ea0: 6e 2d 69 64 29 0a 09 09 20 20 28 6f 70 65 6e 2d n-id)... (open-
7eb0: 72 75 6e 2d 63 6c 6f 73 65 20 64 62 3a 74 65 73 run-close db:tes
7ec0: 74 73 2d 72 65 67 69 73 74 65 72 2d 74 65 73 74 ts-register-test
7ed0: 20 23 66 20 72 75 6e 2d 69 64 20 74 65 73 74 2d #f run-id test-
7ee0: 6e 61 6d 65 20 69 74 65 6d 2d 70 61 74 68 29 0a name item-path).
7ef0: 09 09 20 20 28 73 65 74 21 20 74 65 73 74 2d 69 .. (set! test-i
7f00: 64 20 28 6f 70 65 6e 2d 72 75 6e 2d 63 6c 6f 73 d (open-run-clos
7f10: 65 20 64 62 3a 67 65 74 2d 74 65 73 74 2d 69 64 e db:get-test-id
7f20: 20 64 62 20 72 75 6e 2d 69 64 20 74 65 73 74 2d db run-id test-
7f30: 6e 61 6d 65 20 69 74 65 6d 2d 70 61 74 68 29 29 name item-path))
7f40: 29 29 0a 09 20 20 20 20 28 64 65 62 75 67 3a 70 )).. (debug:p
7f50: 72 69 6e 74 2d 69 6e 66 6f 20 34 20 22 74 65 73 rint-info 4 "tes
7f60: 74 2d 69 64 3d 22 20 74 65 73 74 2d 69 64 20 22 t-id=" test-id "
7f70: 2c 20 72 75 6e 2d 69 64 3d 22 20 72 75 6e 2d 69 , run-id=" run-i
7f80: 64 20 22 2c 20 74 65 73 74 2d 6e 61 6d 65 3d 22 d ", test-name="
7f90: 20 74 65 73 74 2d 6e 61 6d 65 20 22 2c 20 69 74 test-name ", it
7fa0: 65 6d 2d 70 61 74 68 3d 5c 22 22 20 69 74 65 6d em-path=\"" item
7fb0: 2d 70 61 74 68 20 22 5c 22 22 29 0a 09 20 20 20 -path "\"")..
7fc0: 20 28 73 65 74 21 20 74 65 73 74 64 61 74 20 28 (set! testdat (
7fd0: 63 64 62 3a 67 65 74 2d 74 65 73 74 2d 69 6e 66 cdb:get-test-inf
7fe0: 6f 2d 62 79 2d 69 64 20 2a 72 75 6e 72 65 6d 6f o-by-id *runremo
7ff0: 74 65 2a 20 74 65 73 74 2d 69 64 29 29 29 29 0a te* test-id)))).
8000: 20 20 20 20 20 20 28 73 65 74 21 20 74 65 73 74 (set! test
8010: 2d 69 64 20 28 64 62 3a 74 65 73 74 2d 67 65 74 -id (db:test-get
8020: 2d 69 64 20 74 65 73 74 64 61 74 29 29 0a 20 20 -id testdat)).
8030: 20 20 20 20 28 63 68 61 6e 67 65 2d 64 69 72 65 (change-dire
8040: 63 74 6f 72 79 20 74 65 73 74 2d 70 61 74 68 29 ctory test-path)
8050: 0a 20 20 20 20 20 20 28 63 61 73 65 20 28 69 66 . (case (if
8060: 20 66 6f 72 63 65 20 3b 3b 20 28 61 72 67 73 3a force ;; (args:
8070: 67 65 74 2d 61 72 67 20 22 2d 66 6f 72 63 65 22 get-arg "-force"
8080: 29 0a 09 09 27 4e 4f 54 5f 53 54 41 52 54 45 44 )...'NOT_STARTED
8090: 0a 09 09 28 69 66 20 74 65 73 74 64 61 74 0a 09 ...(if testdat..
80a0: 09 20 20 20 20 28 73 74 72 69 6e 67 2d 3e 73 79 . (string->sy
80b0: 6d 62 6f 6c 20 28 74 65 73 74 3a 67 65 74 2d 73 mbol (test:get-s
80c0: 74 61 74 65 20 74 65 73 74 64 61 74 29 29 0a 09 tate testdat))..
80d0: 09 20 20 20 20 27 66 61 69 6c 65 64 2d 74 6f 2d . 'failed-to-
80e0: 69 6e 73 65 72 74 29 29 0a 09 28 28 66 61 69 6c insert))..((fail
80f0: 65 64 2d 74 6f 2d 69 6e 73 65 72 74 29 0a 09 20 ed-to-insert)..
8100: 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 22 (debug:print 0 "
8110: 45 52 52 4f 52 3a 20 46 61 69 6c 65 64 20 74 6f ERROR: Failed to
8120: 20 69 6e 73 65 72 74 20 74 68 65 20 72 65 63 6f insert the reco
8130: 72 64 20 69 6e 74 6f 20 74 68 65 20 64 62 22 29 rd into the db")
8140: 29 0a 09 28 28 4e 4f 54 5f 53 54 41 52 54 45 44 )..((NOT_STARTED
8150: 20 43 4f 4d 50 4c 45 54 45 44 20 44 45 4c 45 54 COMPLETED DELET
8160: 45 44 29 0a 09 20 28 6c 65 74 20 28 28 72 75 6e ED).. (let ((run
8170: 66 6c 61 67 20 23 66 29 29 0a 09 20 20 20 28 63 flag #f)).. (c
8180: 6f 6e 64 0a 09 20 20 20 20 3b 3b 20 2d 66 6f 72 ond.. ;; -for
8190: 63 65 2c 20 72 75 6e 20 6e 6f 20 6d 61 74 74 65 ce, run no matte
81a0: 72 20 77 68 61 74 0a 09 20 20 20 20 28 66 6f 72 r what.. (for
81b0: 63 65 20 28 73 65 74 21 20 72 75 6e 66 6c 61 67 ce (set! runflag
81c0: 20 23 74 29 29 0a 09 20 20 20 20 3b 3b 20 4e 4f #t)).. ;; NO
81d0: 54 5f 53 54 41 52 54 45 44 2c 20 72 75 6e 20 6e T_STARTED, run n
81e0: 6f 20 6d 61 74 74 65 72 20 77 68 61 74 0a 09 20 o matter what..
81f0: 20 20 20 28 28 6d 65 6d 62 65 72 20 28 74 65 73 ((member (tes
8200: 74 3a 67 65 74 2d 73 74 61 74 65 20 74 65 73 74 t:get-state test
8210: 64 61 74 29 20 27 28 22 44 45 4c 45 54 45 44 22 dat) '("DELETED"
8220: 20 22 4e 4f 54 5f 53 54 41 52 54 45 44 22 29 29 "NOT_STARTED"))
8230: 28 73 65 74 21 20 72 75 6e 66 6c 61 67 20 23 74 (set! runflag #t
8240: 29 29 0a 09 20 20 20 20 3b 3b 20 6e 6f 74 20 2d )).. ;; not -
8250: 72 65 72 75 6e 20 61 6e 64 20 50 41 53 53 2c 20 rerun and PASS,
8260: 57 41 52 4e 20 6f 72 20 43 48 45 43 4b 2c 20 64 WARN or CHECK, d
8270: 6f 20 6e 6f 20 72 75 6e 0a 09 20 20 20 20 28 28 o no run.. ((
8280: 61 6e 64 20 28 6f 72 20 28 6e 6f 74 20 72 65 72 and (or (not rer
8290: 75 6e 29 0a 09 09 20 20 20 20 20 20 6b 65 65 70 un)... keep
82a0: 67 6f 69 6e 67 29 0a 09 09 20 20 3b 3b 20 52 65 going)... ;; Re
82b0: 71 75 69 72 65 20 74 6f 20 66 6f 72 63 65 20 72 quire to force r
82c0: 65 2d 72 75 6e 20 66 6f 72 20 43 4f 4d 50 4c 45 e-run for COMPLE
82d0: 54 45 44 20 6f 72 20 2a 61 6e 79 74 68 69 6e 67 TED or *anything
82e0: 2a 20 2b 20 50 41 53 53 2c 57 41 52 4e 20 6f 72 * + PASS,WARN or
82f0: 20 43 48 45 43 4b 0a 09 09 20 20 28 6f 72 20 28 CHECK... (or (
8300: 6d 65 6d 62 65 72 20 28 74 65 73 74 3a 67 65 74 member (test:get
8310: 2d 73 74 61 74 75 73 20 74 65 73 74 64 61 74 29 -status testdat)
8320: 20 27 28 22 50 41 53 53 22 20 22 57 41 52 4e 22 '("PASS" "WARN"
8330: 20 22 43 48 45 43 4b 22 29 29 0a 09 09 20 20 20 "CHECK"))...
8340: 20 20 20 28 6d 65 6d 62 65 72 20 28 74 65 73 74 (member (test
8350: 3a 67 65 74 2d 73 74 61 74 65 20 20 74 65 73 74 :get-state test
8360: 64 61 74 29 20 27 28 22 43 4f 4d 50 4c 45 54 45 dat) '("COMPLETE
8370: 44 22 29 29 29 29 20 0a 09 20 20 20 20 20 28 64 D")))) .. (d
8380: 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 ebug:print-info
8390: 32 20 22 72 75 6e 6e 69 6e 67 20 74 65 73 74 20 2 "running test
83a0: 22 20 74 65 73 74 2d 6e 61 6d 65 20 22 2f 22 20 " test-name "/"
83b0: 69 74 65 6d 2d 70 61 74 68 20 22 20 73 75 70 70 item-path " supp
83c0: 72 65 73 73 65 64 20 61 73 20 69 74 20 69 73 20 ressed as it is
83d0: 22 20 28 74 65 73 74 3a 67 65 74 2d 73 74 61 74 " (test:get-stat
83e0: 65 20 74 65 73 74 64 61 74 29 20 22 20 61 6e 64 e testdat) " and
83f0: 20 22 20 28 74 65 73 74 3a 67 65 74 2d 73 74 61 " (test:get-sta
8400: 74 75 73 20 74 65 73 74 64 61 74 29 29 0a 09 20 tus testdat))..
8410: 20 20 20 20 28 73 65 74 21 20 72 75 6e 66 6c 61 (set! runfla
8420: 67 20 23 66 29 29 0a 09 20 20 20 20 3b 3b 20 2d g #f)).. ;; -
8430: 72 65 72 75 6e 20 61 6e 64 20 73 74 61 74 75 73 rerun and status
8440: 20 69 73 20 6f 6e 65 20 6f 66 20 74 68 65 20 73 is one of the s
8450: 70 65 63 69 66 65 64 2c 20 72 75 6e 20 69 74 0a pecifed, run it.
8460: 09 20 20 20 20 28 28 61 6e 64 20 72 65 72 75 6e . ((and rerun
8470: 0a 09 09 20 20 28 6c 65 74 2a 20 28 28 72 65 72 ... (let* ((rer
8480: 75 6e 6c 73 74 20 20 20 28 73 74 72 69 6e 67 2d unlst (string-
8490: 73 70 6c 69 74 20 72 65 72 75 6e 20 22 2c 22 29 split rerun ",")
84a0: 29 0a 09 09 09 20 28 6d 75 73 74 2d 72 65 72 75 ).... (must-reru
84b0: 6e 20 28 6d 65 6d 62 65 72 20 28 74 65 73 74 3a n (member (test:
84c0: 67 65 74 2d 73 74 61 74 75 73 20 74 65 73 74 64 get-status testd
84d0: 61 74 29 20 72 65 72 75 6e 6c 73 74 29 29 29 0a at) rerunlst))).
84e0: 09 09 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 .. (debug:pri
84f0: 6e 74 2d 69 6e 66 6f 20 33 20 22 2d 72 65 72 75 nt-info 3 "-reru
8500: 6e 20 6c 69 73 74 3a 20 22 20 72 65 72 75 6e 20 n list: " rerun
8510: 22 2c 20 74 65 73 74 2d 73 74 61 74 75 73 3a 20 ", test-status:
8520: 22 20 28 74 65 73 74 3a 67 65 74 2d 73 74 61 74 " (test:get-stat
8530: 75 73 20 74 65 73 74 64 61 74 29 22 2c 20 6d 75 us testdat)", mu
8540: 73 74 2d 72 65 72 75 6e 3a 20 22 20 6d 75 73 74 st-rerun: " must
8550: 2d 72 65 72 75 6e 29 0a 09 09 20 20 20 20 6d 75 -rerun)... mu
8560: 73 74 2d 72 65 72 75 6e 29 29 0a 09 20 20 20 20 st-rerun))..
8570: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e (debug:print-in
8580: 66 6f 20 32 20 22 52 65 72 75 6e 20 66 6f 72 63 fo 2 "Rerun forc
8590: 65 64 20 66 6f 72 20 74 65 73 74 20 22 20 74 65 ed for test " te
85a0: 73 74 2d 6e 61 6d 65 20 22 2f 22 20 69 74 65 6d st-name "/" item
85b0: 2d 70 61 74 68 29 0a 09 20 20 20 20 20 28 73 65 -path).. (se
85c0: 74 21 20 72 75 6e 66 6c 61 67 20 23 74 29 29 0a t! runflag #t)).
85d0: 09 20 20 20 20 3b 3b 20 2d 6b 65 65 70 67 6f 69 . ;; -keepgoi
85e0: 6e 67 2c 20 64 6f 20 6e 6f 74 20 72 65 72 75 6e ng, do not rerun
85f0: 20 46 41 49 4c 0a 09 20 20 20 20 28 28 61 6e 64 FAIL.. ((and
8600: 20 6b 65 65 70 67 6f 69 6e 67 0a 09 09 20 20 28 keepgoing... (
8610: 6d 65 6d 62 65 72 20 28 74 65 73 74 3a 67 65 74 member (test:get
8620: 2d 73 74 61 74 75 73 20 74 65 73 74 64 61 74 29 -status testdat)
8630: 20 27 28 22 46 41 49 4c 22 29 29 29 0a 09 20 20 '("FAIL")))..
8640: 20 20 20 28 73 65 74 21 20 72 75 6e 66 6c 61 67 (set! runflag
8650: 20 23 66 29 29 0a 09 20 20 20 20 28 28 61 6e 64 #f)).. ((and
8660: 20 28 6e 6f 74 20 72 65 72 75 6e 29 0a 09 09 20 (not rerun)...
8670: 20 28 6d 65 6d 62 65 72 20 28 74 65 73 74 3a 67 (member (test:g
8680: 65 74 2d 73 74 61 74 75 73 20 74 65 73 74 64 61 et-status testda
8690: 74 29 20 27 28 22 46 41 49 4c 22 20 22 6e 2f 61 t) '("FAIL" "n/a
86a0: 22 29 29 29 0a 09 20 20 20 20 20 28 73 65 74 21 "))).. (set!
86b0: 20 72 75 6e 66 6c 61 67 20 23 74 29 29 0a 09 20 runflag #t))..
86c0: 20 20 20 28 65 6c 73 65 20 28 73 65 74 21 20 72 (else (set! r
86d0: 75 6e 66 6c 61 67 20 23 66 29 29 29 0a 09 20 20 unflag #f)))..
86e0: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 36 20 (debug:print 6
86f0: 22 52 55 4e 4e 49 4e 47 20 3d 3e 20 72 75 6e 66 "RUNNING => runf
8700: 6c 61 67 3a 20 22 20 72 75 6e 66 6c 61 67 20 22 lag: " runflag "
8710: 20 53 54 41 54 45 3a 20 22 20 28 74 65 73 74 3a STATE: " (test:
8720: 67 65 74 2d 73 74 61 74 65 20 74 65 73 74 64 61 get-state testda
8730: 74 29 20 22 20 53 54 41 54 55 53 3a 20 22 20 28 t) " STATUS: " (
8740: 74 65 73 74 3a 67 65 74 2d 73 74 61 74 75 73 20 test:get-status
8750: 74 65 73 74 64 61 74 29 29 0a 09 20 20 20 28 69 testdat)).. (i
8760: 66 20 28 6e 6f 74 20 72 75 6e 66 6c 61 67 29 0a f (not runflag).
8770: 09 20 20 20 20 20 20 20 28 69 66 20 28 6e 6f 74 . (if (not
8780: 20 70 61 72 65 6e 74 2d 74 65 73 74 29 0a 09 09 parent-test)...
8790: 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 (debug:print
87a0: 31 20 22 4e 4f 54 45 3a 20 4e 6f 74 20 73 74 61 1 "NOTE: Not sta
87b0: 72 74 69 6e 67 20 74 65 73 74 20 22 20 6e 65 77 rting test " new
87c0: 2d 74 65 73 74 2d 6e 61 6d 65 20 22 20 61 73 20 -test-name " as
87d0: 69 74 20 69 73 20 73 74 61 74 65 20 5c 22 22 20 it is state \""
87e0: 28 74 65 73 74 3a 67 65 74 2d 73 74 61 74 65 20 (test:get-state
87f0: 74 65 73 74 64 61 74 29 20 0a 09 09 09 09 22 5c testdat) ....."\
8800: 22 20 61 6e 64 20 73 74 61 74 75 73 20 5c 22 22 " and status \""
8810: 20 28 74 65 73 74 3a 67 65 74 2d 73 74 61 74 75 (test:get-statu
8820: 73 20 74 65 73 74 64 61 74 29 20 22 5c 22 2c 20 s testdat) "\",
8830: 75 73 65 20 2d 72 65 72 75 6e 20 5c 22 22 20 28 use -rerun \"" (
8840: 74 65 73 74 3a 67 65 74 2d 73 74 61 74 75 73 20 test:get-status
8850: 74 65 73 74 64 61 74 29 0a 20 20 20 20 20 20 20 testdat).
8860: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8870: 20 20 20 20 20 20 20 20 20 22 5c 22 20 6f 72 20 "\" or
8880: 2d 66 6f 72 63 65 20 74 6f 20 6f 76 65 72 72 69 -force to overri
8890: 64 65 22 29 29 0a 09 20 20 20 20 20 20 20 3b 3b de")).. ;;
88a0: 20 4e 4f 54 45 3a 20 4e 6f 20 6c 6f 6e 67 65 72 NOTE: No longer
88b0: 20 62 65 20 63 68 65 63 6b 69 6e 67 20 70 72 65 be checking pre
88c0: 72 65 71 75 69 73 69 74 65 73 20 68 65 72 65 21 requisites here!
88d0: 20 57 69 6c 6c 20 6e 65 76 65 72 20 67 65 74 20 Will never get
88e0: 68 65 72 65 20 75 6e 6c 65 73 73 20 70 72 65 72 here unless prer
88f0: 65 71 73 20 61 72 65 0a 09 20 20 20 20 20 20 20 eqs are..
8900: 3b 3b 20 20 20 20 20 20 20 61 6c 72 65 61 64 79 ;; already
8910: 20 6d 65 74 2e 0a 09 20 20 20 20 20 20 20 28 69 met... (i
8920: 66 20 28 6e 6f 74 20 28 6c 61 75 6e 63 68 2d 74 f (not (launch-t
8930: 65 73 74 20 23 66 20 72 75 6e 2d 69 64 20 72 75 est #f run-id ru
8940: 6e 6e 61 6d 65 20 74 65 73 74 2d 63 6f 6e 66 20 nname test-conf
8950: 6b 65 79 76 61 6c 6c 73 74 20 74 65 73 74 2d 6e keyvallst test-n
8960: 61 6d 65 20 74 65 73 74 2d 70 61 74 68 20 69 74 ame test-path it
8970: 65 6d 64 61 74 20 66 6c 61 67 73 29 29 0a 09 09 emdat flags))...
8980: 20 20 20 28 62 65 67 69 6e 0a 09 09 20 20 20 20 (begin...
8990: 20 28 70 72 69 6e 74 20 22 45 52 52 4f 52 3a 20 (print "ERROR:
89a0: 46 61 69 6c 65 64 20 74 6f 20 6c 61 75 6e 63 68 Failed to launch
89b0: 20 74 68 65 20 74 65 73 74 2e 20 45 78 69 74 69 the test. Exiti
89c0: 6e 67 20 61 73 20 73 6f 6f 6e 20 61 73 20 70 6f ng as soon as po
89d0: 73 73 69 62 6c 65 22 29 0a 09 09 20 20 20 20 20 ssible")...
89e0: 28 73 65 74 21 20 2a 67 6c 6f 62 61 6c 65 78 69 (set! *globalexi
89f0: 74 73 74 61 74 75 73 2a 20 31 29 20 3b 3b 20 0a tstatus* 1) ;; .
8a00: 09 09 20 20 20 20 20 28 70 72 6f 63 65 73 73 2d .. (process-
8a10: 73 69 67 6e 61 6c 20 28 63 75 72 72 65 6e 74 2d signal (current-
8a20: 70 72 6f 63 65 73 73 2d 69 64 29 20 73 69 67 6e process-id) sign
8a30: 61 6c 2f 6b 69 6c 6c 29 29 29 29 29 29 0a 09 28 al/kill))))))..(
8a40: 28 4b 49 4c 4c 45 44 29 20 0a 09 20 28 64 65 62 (KILLED) .. (deb
8a50: 75 67 3a 70 72 69 6e 74 20 31 20 22 4e 4f 54 45 ug:print 1 "NOTE
8a60: 3a 20 22 20 6e 65 77 2d 74 65 73 74 2d 6e 61 6d : " new-test-nam
8a70: 65 20 22 20 69 73 20 61 6c 72 65 61 64 79 20 72 e " is already r
8a80: 75 6e 6e 69 6e 67 20 6f 72 20 77 61 73 20 65 78 unning or was ex
8a90: 70 6c 69 63 74 6c 79 20 6b 69 6c 6c 65 64 2c 20 plictly killed,
8aa0: 75 73 65 20 2d 66 6f 72 63 65 20 74 6f 20 6c 61 use -force to la
8ab0: 75 6e 63 68 20 69 74 2e 22 29 29 0a 09 28 28 4c unch it."))..((L
8ac0: 41 55 4e 43 48 45 44 20 52 45 4d 4f 54 45 48 4f AUNCHED REMOTEHO
8ad0: 53 54 53 54 41 52 54 20 52 55 4e 4e 49 4e 47 29 STSTART RUNNING)
8ae0: 20 20 0a 09 20 28 69 66 20 28 3e 20 28 2d 20 28 .. (if (> (- (
8af0: 63 75 72 72 65 6e 74 2d 73 65 63 6f 6e 64 73 29 current-seconds)
8b00: 28 2b 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d (+ (db:test-get-
8b10: 65 76 65 6e 74 5f 74 69 6d 65 20 74 65 73 74 64 event_time testd
8b20: 61 74 29 0a 09 09 09 09 20 20 20 20 20 20 20 28 at)..... (
8b30: 64 62 3a 74 65 73 74 2d 67 65 74 2d 72 75 6e 5f db:test-get-run_
8b40: 64 75 72 61 74 69 6f 6e 20 74 65 73 74 64 61 74 duration testdat
8b50: 29 29 29 0a 09 09 36 30 30 29 20 3b 3b 20 69 2e )))...600) ;; i.
8b60: 65 2e 20 6e 6f 20 75 70 64 61 74 65 20 66 6f 72 e. no update for
8b70: 20 6d 6f 72 65 20 74 68 61 6e 20 36 30 30 20 73 more than 600 s
8b80: 65 63 6f 6e 64 73 0a 09 20 20 20 20 20 28 62 65 econds.. (be
8b90: 67 69 6e 0a 09 20 20 20 20 20 20 20 28 64 65 62 gin.. (deb
8ba0: 75 67 3a 70 72 69 6e 74 20 30 20 22 57 41 52 4e ug:print 0 "WARN
8bb0: 49 4e 47 3a 20 54 65 73 74 20 22 20 74 65 73 74 ING: Test " test
8bc0: 2d 6e 61 6d 65 20 22 20 61 70 70 65 61 72 73 20 -name " appears
8bd0: 74 6f 20 62 65 20 64 65 61 64 2e 20 46 6f 72 63 to be dead. Forc
8be0: 69 6e 67 20 69 74 20 74 6f 20 73 74 61 74 65 20 ing it to state
8bf0: 49 4e 43 4f 4d 50 4c 45 54 45 20 61 6e 64 20 73 INCOMPLETE and s
8c00: 74 61 74 75 73 20 53 54 55 43 4b 2f 44 45 41 44 tatus STUCK/DEAD
8c10: 22 29 0a 09 20 20 20 20 20 20 20 28 74 65 73 74 ").. (test
8c20: 73 3a 74 65 73 74 2d 73 65 74 2d 73 74 61 74 75 s:test-set-statu
8c30: 73 21 20 74 65 73 74 2d 69 64 20 22 49 4e 43 4f s! test-id "INCO
8c40: 4d 50 4c 45 54 45 22 20 22 53 54 55 43 4b 2f 44 MPLETE" "STUCK/D
8c50: 45 41 44 22 20 22 54 65 73 74 20 69 73 20 73 74 EAD" "Test is st
8c60: 75 63 6b 20 6f 72 20 64 65 61 64 22 20 23 66 29 uck or dead" #f)
8c70: 29 0a 09 20 20 20 20 20 28 64 65 62 75 67 3a 70 ).. (debug:p
8c80: 72 69 6e 74 20 32 20 22 4e 4f 54 45 3a 20 22 20 rint 2 "NOTE: "
8c90: 74 65 73 74 2d 6e 61 6d 65 20 22 20 69 73 20 61 test-name " is a
8ca0: 6c 72 65 61 64 79 20 72 75 6e 6e 69 6e 67 22 29 lready running")
8cb0: 29 29 0a 09 28 65 6c 73 65 20 20 20 20 20 20 20 ))..(else
8cc0: 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 22 (debug:print 0 "
8cd0: 45 52 52 4f 52 3a 20 46 61 69 6c 65 64 20 74 6f ERROR: Failed to
8ce0: 20 6c 61 75 6e 63 68 20 74 65 73 74 20 22 20 6e launch test " n
8cf0: 65 77 2d 74 65 73 74 2d 6e 61 6d 65 20 22 2e 20 ew-test-name ".
8d00: 55 6e 72 65 63 6f 67 6e 69 73 65 64 20 73 74 61 Unrecognised sta
8d10: 74 65 20 22 20 28 74 65 73 74 3a 67 65 74 2d 73 te " (test:get-s
8d20: 74 61 74 65 20 74 65 73 74 64 61 74 29 29 29 29 tate testdat))))
8d30: 29 29 29 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d )))..;;=========
8d40: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8d50: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8d60: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8d70: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b =============.;;
8d80: 20 45 4e 44 20 4f 46 20 4e 45 57 20 53 54 55 46 END OF NEW STUF
8d90: 46 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d F.;;============
8da0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8db0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8dc0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8dd0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 28 64 65 66 ==========..(def
8de0: 69 6e 65 20 28 67 65 74 2d 64 69 72 2d 75 70 2d ine (get-dir-up-
8df0: 6e 20 64 69 72 20 2e 20 70 61 72 61 6d 73 29 20 n dir . params)
8e00: 0a 20 20 28 6c 65 74 20 28 28 64 70 61 72 74 73 . (let ((dparts
8e10: 20 20 28 73 74 72 69 6e 67 2d 73 70 6c 69 74 20 (string-split
8e20: 64 69 72 20 22 2f 22 29 29 0a 09 28 63 6f 75 6e dir "/"))..(coun
8e30: 74 20 20 20 28 69 66 20 28 6e 75 6c 6c 3f 20 70 t (if (null? p
8e40: 61 72 61 6d 73 29 20 31 20 28 63 61 72 20 70 61 arams) 1 (car pa
8e50: 72 61 6d 73 29 29 29 29 0a 20 20 20 20 28 63 6f rams)))). (co
8e60: 6e 63 20 22 2f 22 20 28 73 74 72 69 6e 67 2d 69 nc "/" (string-i
8e70: 6e 74 65 72 73 70 65 72 73 65 20 0a 09 20 20 20 ntersperse ..
8e80: 20 20 20 20 28 74 61 6b 65 20 64 70 61 72 74 73 (take dparts
8e90: 20 28 2d 20 28 6c 65 6e 67 74 68 20 64 70 61 72 (- (length dpar
8ea0: 74 73 29 20 63 6f 75 6e 74 29 29 0a 09 20 20 20 ts) count))..
8eb0: 20 20 20 20 22 2f 22 29 29 29 29 0a 3b 3b 20 52 "/")))).;; R
8ec0: 65 6d 6f 76 65 20 72 75 6e 73 0a 3b 3b 20 66 69 emove runs.;; fi
8ed0: 65 6c 64 73 20 61 72 65 20 70 61 73 73 69 6e 67 elds are passing
8ee0: 20 69 6e 20 74 68 72 6f 75 67 68 20 0a 3b 3b 20 in through .;;
8ef0: 61 63 74 69 6f 6e 3a 0a 3b 3b 20 20 20 20 27 72 action:.;; 'r
8f00: 65 6d 6f 76 65 2d 72 75 6e 73 0a 3b 3b 20 20 20 emove-runs.;;
8f10: 20 27 73 65 74 2d 73 74 61 74 65 2d 73 74 61 74 'set-state-stat
8f20: 75 73 0a 3b 3b 0a 3b 3b 20 4e 42 2f 2f 20 73 68 us.;;.;; NB// sh
8f30: 6f 75 6c 64 20 70 61 73 73 20 69 6e 20 6b 65 79 ould pass in key
8f40: 73 3f 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 72 s?.;;.(define (r
8f50: 75 6e 73 3a 6f 70 65 72 61 74 65 2d 6f 6e 20 61 uns:operate-on a
8f60: 63 74 69 6f 6e 20 72 75 6e 6e 61 6d 65 70 61 74 ction runnamepat
8f70: 74 20 74 65 73 74 70 61 74 74 20 23 21 6b 65 79 t testpatt #!key
8f80: 20 28 73 74 61 74 65 20 23 66 29 28 73 74 61 74 (state #f)(stat
8f90: 75 73 20 23 66 29 28 6e 65 77 2d 73 74 61 74 65 us #f)(new-state
8fa0: 2d 73 74 61 74 75 73 20 23 66 29 29 0a 20 20 28 -status #f)). (
8fb0: 63 6f 6d 6d 6f 6e 3a 63 6c 65 61 72 2d 63 61 63 common:clear-cac
8fc0: 68 65 73 29 20 3b 3b 20 63 6c 65 61 72 20 61 6c hes) ;; clear al
8fd0: 6c 20 63 61 63 68 65 73 0a 20 20 28 6c 65 74 2a l caches. (let*
8fe0: 20 28 28 64 62 20 20 20 20 20 20 20 20 20 20 20 ((db
8ff0: 23 66 29 0a 09 20 28 6b 65 79 73 20 20 20 20 20 #f).. (keys
9000: 20 20 20 20 28 6f 70 65 6e 2d 72 75 6e 2d 63 6c (open-run-cl
9010: 6f 73 65 20 64 62 3a 67 65 74 2d 6b 65 79 73 20 ose db:get-keys
9020: 64 62 29 29 0a 09 20 28 72 75 6e 64 61 74 20 20 db)).. (rundat
9030: 20 20 20 20 20 28 6f 70 65 6e 2d 72 75 6e 2d 63 (open-run-c
9040: 6c 6f 73 65 20 72 75 6e 73 3a 67 65 74 2d 72 75 lose runs:get-ru
9050: 6e 73 2d 62 79 2d 70 61 74 74 20 64 62 20 6b 65 ns-by-patt db ke
9060: 79 73 20 72 75 6e 6e 61 6d 65 70 61 74 74 29 29 ys runnamepatt))
9070: 0a 09 20 28 68 65 61 64 65 72 20 20 20 20 20 20 .. (header
9080: 20 28 76 65 63 74 6f 72 2d 72 65 66 20 72 75 6e (vector-ref run
9090: 64 61 74 20 30 29 29 0a 09 20 28 72 75 6e 73 20 dat 0)).. (runs
90a0: 20 20 20 20 20 20 20 20 28 76 65 63 74 6f 72 2d (vector-
90b0: 72 65 66 20 72 75 6e 64 61 74 20 31 29 29 0a 09 ref rundat 1))..
90c0: 20 28 73 74 61 74 65 73 20 20 20 20 20 20 20 28 (states (
90d0: 69 66 20 73 74 61 74 65 20 20 28 73 74 72 69 6e if state (strin
90e0: 67 2d 73 70 6c 69 74 20 73 74 61 74 65 20 20 22 g-split state "
90f0: 2c 22 29 20 27 28 29 29 29 0a 09 20 28 73 74 61 ,") '())).. (sta
9100: 74 75 73 65 73 20 20 20 20 20 28 69 66 20 73 74 tuses (if st
9110: 61 74 75 73 20 28 73 74 72 69 6e 67 2d 73 70 6c atus (string-spl
9120: 69 74 20 73 74 61 74 75 73 20 22 2c 22 29 20 27 it status ",") '
9130: 28 29 29 29 0a 09 20 28 73 74 61 74 65 2d 73 74 ())).. (state-st
9140: 61 74 75 73 20 28 69 66 20 28 73 74 72 69 6e 67 atus (if (string
9150: 3f 20 6e 65 77 2d 73 74 61 74 65 2d 73 74 61 74 ? new-state-stat
9160: 75 73 29 20 28 73 74 72 69 6e 67 2d 73 70 6c 69 us) (string-spli
9170: 74 20 6e 65 77 2d 73 74 61 74 65 2d 73 74 61 74 t new-state-stat
9180: 75 73 20 22 2c 22 29 20 27 28 23 66 20 23 66 29 us ",") '(#f #f)
9190: 29 29 29 0a 20 20 20 20 28 64 65 62 75 67 3a 70 ))). (debug:p
91a0: 72 69 6e 74 2d 69 6e 66 6f 20 34 20 22 72 75 6e rint-info 4 "run
91b0: 73 3a 6f 70 65 72 61 74 65 2d 6f 6e 20 3d 3e 20 s:operate-on =>
91c0: 48 65 61 64 65 72 3a 20 22 20 68 65 61 64 65 72 Header: " header
91d0: 20 22 20 61 63 74 69 6f 6e 3a 20 22 20 61 63 74 " action: " act
91e0: 69 6f 6e 20 22 20 6e 65 77 2d 73 74 61 74 65 2d ion " new-state-
91f0: 73 74 61 74 75 73 3a 20 22 20 6e 65 77 2d 73 74 status: " new-st
9200: 61 74 65 2d 73 74 61 74 75 73 29 0a 20 20 20 20 ate-status).
9210: 28 69 66 20 28 3e 20 32 20 28 6c 65 6e 67 74 68 (if (> 2 (length
9220: 20 73 74 61 74 65 2d 73 74 61 74 75 73 29 29 0a state-status)).
9230: 09 28 62 65 67 69 6e 0a 09 20 20 28 64 65 62 75 .(begin.. (debu
9240: 67 3a 70 72 69 6e 74 20 30 20 22 45 52 52 4f 52 g:print 0 "ERROR
9250: 3a 20 74 68 65 20 70 61 72 61 6d 65 74 65 72 20 : the parameter
9260: 74 6f 20 2d 73 65 74 2d 73 74 61 74 65 2d 73 74 to -set-state-st
9270: 61 74 75 73 20 69 73 20 61 20 63 6f 6d 6d 61 20 atus is a comma
9280: 64 65 6c 69 6d 69 74 65 64 20 73 74 72 69 6e 67 delimited string
9290: 2e 20 45 2e 67 2e 20 43 4f 4d 50 4c 45 54 45 44 . E.g. COMPLETED
92a0: 2c 46 41 49 4c 22 29 0a 09 20 20 28 65 78 69 74 ,FAIL").. (exit
92b0: 29 29 29 0a 20 20 20 20 28 66 6f 72 2d 65 61 63 ))). (for-eac
92c0: 68 0a 20 20 20 20 20 28 6c 61 6d 62 64 61 20 28 h. (lambda (
92d0: 72 75 6e 29 0a 20 20 20 20 20 20 20 28 6c 65 74 run). (let
92e0: 20 28 28 72 75 6e 6b 65 79 20 28 73 74 72 69 6e ((runkey (strin
92f0: 67 2d 69 6e 74 65 72 73 70 65 72 73 65 20 28 6d g-intersperse (m
9300: 61 70 20 28 6c 61 6d 62 64 61 20 28 6b 29 0a 09 ap (lambda (k)..
9310: 09 09 09 09 09 28 64 62 3a 67 65 74 2d 76 61 6c .....(db:get-val
9320: 75 65 2d 62 79 2d 68 65 61 64 65 72 20 72 75 6e ue-by-header run
9330: 20 68 65 61 64 65 72 20 28 76 65 63 74 6f 72 2d header (vector-
9340: 72 65 66 20 6b 20 30 29 29 29 20 6b 65 79 73 29 ref k 0))) keys)
9350: 20 22 2f 22 29 29 0a 09 20 20 20 20 20 28 64 69 "/")).. (di
9360: 72 73 2d 74 6f 2d 72 65 6d 6f 76 65 20 28 6d 61 rs-to-remove (ma
9370: 6b 65 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 29 ke-hash-table)))
9380: 0a 09 20 28 6c 65 74 2a 20 28 28 72 75 6e 2d 69 .. (let* ((run-i
9390: 64 20 20 20 20 28 64 62 3a 67 65 74 2d 76 61 6c d (db:get-val
93a0: 75 65 2d 62 79 2d 68 65 61 64 65 72 20 72 75 6e ue-by-header run
93b0: 20 68 65 61 64 65 72 20 22 69 64 22 29 29 0a 09 header "id"))..
93c0: 09 28 72 75 6e 2d 73 74 61 74 65 20 28 64 62 3a .(run-state (db:
93d0: 67 65 74 2d 76 61 6c 75 65 2d 62 79 2d 68 65 61 get-value-by-hea
93e0: 64 65 72 20 72 75 6e 20 68 65 61 64 65 72 20 22 der run header "
93f0: 73 74 61 74 65 22 29 29 0a 09 09 28 74 65 73 74 state"))...(test
9400: 73 20 20 20 20 20 28 69 66 20 28 6e 6f 74 20 28 s (if (not (
9410: 65 71 75 61 6c 3f 20 72 75 6e 2d 73 74 61 74 65 equal? run-state
9420: 20 22 6c 6f 63 6b 65 64 22 29 29 0a 09 09 09 20 "locked"))....
9430: 20 20 20 20 20 20 28 6f 70 65 6e 2d 72 75 6e 2d (open-run-
9440: 63 6c 6f 73 65 20 64 62 3a 67 65 74 2d 74 65 73 close db:get-tes
9450: 74 73 2d 66 6f 72 2d 72 75 6e 20 64 62 20 72 75 ts-for-run db ru
9460: 6e 2d 69 64 0a 09 09 09 09 09 09 20 20 20 20 20 n-id.......
9470: 20 74 65 73 74 70 61 74 74 20 73 74 61 74 65 73 testpatt states
9480: 20 73 74 61 74 75 73 65 73 0a 09 09 09 09 09 09 statuses.......
9490: 20 20 20 20 20 20 6e 6f 74 2d 69 6e 3a 20 20 23 not-in: #
94a0: 66 0a 09 09 09 09 09 09 20 20 20 20 20 20 73 6f f....... so
94b0: 72 74 2d 62 79 3a 20 28 63 61 73 65 20 61 63 74 rt-by: (case act
94c0: 69 6f 6e 0a 09 09 09 09 09 09 09 09 20 28 28 72 ion......... ((r
94d0: 65 6d 6f 76 65 2d 72 75 6e 73 29 20 27 72 75 6e emove-runs) 'run
94e0: 64 69 72 29 0a 09 09 09 09 09 09 09 09 20 28 65 dir)......... (e
94f0: 6c 73 65 20 20 20 20 20 20 20 20 20 20 27 65 76 lse 'ev
9500: 65 6e 74 5f 74 69 6d 65 29 29 29 0a 09 09 09 20 ent_time)))....
9510: 20 20 20 20 20 20 27 28 29 29 29 0a 09 09 28 6c '()))...(l
9520: 61 73 74 74 70 61 74 68 20 22 2f 64 6f 65 73 2f asttpath "/does/
9530: 6e 6f 74 2f 65 78 69 73 74 2f 49 2f 68 6f 70 65 not/exist/I/hope
9540: 22 29 29 0a 09 20 20 20 28 64 65 62 75 67 3a 70 ")).. (debug:p
9550: 72 69 6e 74 2d 69 6e 66 6f 20 34 20 22 72 75 6e rint-info 4 "run
9560: 73 3a 6f 70 65 72 61 74 65 2d 6f 6e 20 72 75 6e s:operate-on run
9570: 3d 22 20 72 75 6e 20 22 2c 20 68 65 61 64 65 72 =" run ", header
9580: 3d 22 20 68 65 61 64 65 72 29 0a 09 20 20 20 28 =" header).. (
9590: 69 66 20 28 6e 6f 74 20 28 6e 75 6c 6c 3f 20 74 if (not (null? t
95a0: 65 73 74 73 29 29 0a 09 20 20 20 20 20 20 20 28 ests)).. (
95b0: 62 65 67 69 6e 0a 09 09 20 28 63 61 73 65 20 61 begin... (case a
95c0: 63 74 69 6f 6e 0a 09 09 20 20 20 28 28 72 65 6d ction... ((rem
95d0: 6f 76 65 2d 72 75 6e 73 29 0a 09 09 20 20 20 20 ove-runs)...
95e0: 28 64 65 62 75 67 3a 70 72 69 6e 74 20 31 20 22 (debug:print 1 "
95f0: 52 65 6d 6f 76 69 6e 67 20 74 65 73 74 73 20 66 Removing tests f
9600: 6f 72 20 72 75 6e 3a 20 22 20 72 75 6e 6b 65 79 or run: " runkey
9610: 20 22 20 22 20 28 64 62 3a 67 65 74 2d 76 61 6c " " (db:get-val
9620: 75 65 2d 62 79 2d 68 65 61 64 65 72 20 72 75 6e ue-by-header run
9630: 20 68 65 61 64 65 72 20 22 72 75 6e 6e 61 6d 65 header "runname
9640: 22 29 29 29 0a 09 09 20 20 20 28 28 73 65 74 2d ")))... ((set-
9650: 73 74 61 74 65 2d 73 74 61 74 75 73 29 0a 09 09 state-status)...
9660: 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 (debug:print
9670: 20 31 20 22 4d 6f 64 69 66 79 69 6e 67 20 73 74 1 "Modifying st
9680: 61 74 65 20 61 6e 64 20 73 74 61 75 73 20 66 6f ate and staus fo
9690: 72 20 74 65 73 74 73 20 66 6f 72 20 72 75 6e 3a r tests for run:
96a0: 20 22 20 72 75 6e 6b 65 79 20 22 20 22 20 28 64 " runkey " " (d
96b0: 62 3a 67 65 74 2d 76 61 6c 75 65 2d 62 79 2d 68 b:get-value-by-h
96c0: 65 61 64 65 72 20 72 75 6e 20 68 65 61 64 65 72 eader run header
96d0: 20 22 72 75 6e 6e 61 6d 65 22 29 29 29 0a 09 09 "runname")))...
96e0: 20 20 20 28 28 70 72 69 6e 74 2d 72 75 6e 29 0a ((print-run).
96f0: 09 09 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 .. (debug:pri
9700: 6e 74 20 31 20 22 50 72 69 6e 74 69 6e 67 20 69 nt 1 "Printing i
9710: 6e 66 6f 20 66 6f 72 20 72 75 6e 20 22 20 72 75 nfo for run " ru
9720: 6e 6b 65 79 20 22 2c 20 72 75 6e 3d 22 20 72 75 nkey ", run=" ru
9730: 6e 20 22 2c 20 74 65 73 74 73 3d 22 20 74 65 73 n ", tests=" tes
9740: 74 73 20 22 2c 20 68 65 61 64 65 72 3d 22 20 68 ts ", header=" h
9750: 65 61 64 65 72 29 0a 09 09 20 20 20 20 61 63 74 eader)... act
9760: 69 6f 6e 29 0a 09 09 20 20 20 28 65 6c 73 65 0a ion)... (else.
9770: 09 09 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 .. (debug:pri
9780: 6e 74 2d 69 6e 66 6f 20 30 20 22 61 63 74 69 6f nt-info 0 "actio
9790: 6e 20 6e 6f 74 20 72 65 63 6f 67 6e 69 73 65 64 n not recognised
97a0: 20 22 20 61 63 74 69 6f 6e 29 29 29 0a 09 09 20 " action)))...
97b0: 28 66 6f 72 2d 65 61 63 68 0a 09 09 20 20 28 6c (for-each... (l
97c0: 61 6d 62 64 61 20 28 74 65 73 74 29 0a 09 09 20 ambda (test)...
97d0: 20 20 20 28 6c 65 74 2a 20 28 28 69 74 65 6d 2d (let* ((item-
97e0: 70 61 74 68 20 28 64 62 3a 74 65 73 74 2d 67 65 path (db:test-ge
97f0: 74 2d 69 74 65 6d 2d 70 61 74 68 20 74 65 73 74 t-item-path test
9800: 29 29 0a 09 09 09 20 20 20 28 74 65 73 74 2d 6e )).... (test-n
9810: 61 6d 65 20 28 64 62 3a 74 65 73 74 2d 67 65 74 ame (db:test-get
9820: 2d 74 65 73 74 6e 61 6d 65 20 74 65 73 74 29 29 -testname test))
9830: 0a 09 09 09 20 20 20 28 72 75 6e 2d 64 69 72 20 .... (run-dir
9840: 20 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 72 (db:test-get-r
9850: 75 6e 64 69 72 20 74 65 73 74 29 29 20 20 20 20 undir test))
9860: 3b 3b 20 72 75 6e 20 64 69 72 20 69 73 20 66 72 ;; run dir is fr
9870: 6f 6d 20 74 68 65 20 6c 69 6e 6b 20 74 72 65 65 om the link tree
9880: 0a 09 09 09 20 20 20 28 72 65 61 6c 2d 64 69 72 .... (real-dir
9890: 20 20 28 69 66 20 28 66 69 6c 65 2d 65 78 69 73 (if (file-exis
98a0: 74 73 3f 20 72 75 6e 2d 64 69 72 29 0a 09 09 09 ts? run-dir)....
98b0: 09 09 20 20 28 72 65 73 6f 6c 76 65 2d 70 61 74 .. (resolve-pat
98c0: 68 6e 61 6d 65 20 72 75 6e 2d 64 69 72 29 0a 09 hname run-dir)..
98d0: 09 09 09 09 20 20 23 66 29 29 0a 09 09 09 20 20 .... #f))....
98e0: 20 28 74 65 73 74 2d 69 64 20 20 20 28 64 62 3a (test-id (db:
98f0: 74 65 73 74 2d 67 65 74 2d 69 64 20 74 65 73 74 test-get-id test
9900: 29 29 29 0a 09 09 20 20 20 20 20 20 3b 3b 20 20 )))... ;;
9910: 20 28 74 64 62 20 20 20 20 20 20 20 28 64 62 3a (tdb (db:
9920: 6f 70 65 6e 2d 74 65 73 74 2d 64 62 20 72 75 6e open-test-db run
9930: 2d 64 69 72 29 29 29 0a 09 09 20 20 20 20 20 20 -dir)))...
9940: 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 (debug:print-inf
9950: 6f 20 34 20 22 74 65 73 74 3d 22 20 74 65 73 74 o 4 "test=" test
9960: 29 20 3b 3b 20 20 20 22 20 28 64 62 3a 74 65 73 ) ;; " (db:tes
9970: 74 2d 67 65 74 2d 74 65 73 74 6e 61 6d 65 20 74 t-get-testname t
9980: 65 73 74 29 20 22 20 69 64 3a 20 22 20 28 64 62 est) " id: " (db
9990: 3a 74 65 73 74 2d 67 65 74 2d 69 64 20 74 65 73 :test-get-id tes
99a0: 74 29 20 22 20 22 20 69 74 65 6d 2d 70 61 74 68 t) " " item-path
99b0: 20 22 20 61 63 74 69 6f 6e 3a 20 22 20 61 63 74 " action: " act
99c0: 69 6f 6e 29 0a 09 09 20 20 20 20 20 20 28 63 61 ion)... (ca
99d0: 73 65 20 61 63 74 69 6f 6e 0a 09 09 09 28 28 72 se action....((r
99e0: 65 6d 6f 76 65 2d 72 75 6e 73 29 20 3b 3b 20 74 emove-runs) ;; t
99f0: 68 65 20 74 64 62 20 69 73 20 66 6f 72 20 66 75 he tdb is for fu
9a00: 74 75 72 65 20 70 6f 73 73 69 62 6c 65 2e 20 0a ture possible. .
9a10: 09 09 09 20 28 6f 70 65 6e 2d 72 75 6e 2d 63 6c ... (open-run-cl
9a20: 6f 73 65 20 64 62 3a 64 65 6c 65 74 65 2d 74 65 ose db:delete-te
9a30: 73 74 2d 72 65 63 6f 72 64 73 20 64 62 20 23 66 st-records db #f
9a40: 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 69 64 (db:test-get-id
9a50: 20 74 65 73 74 29 29 0a 09 09 09 20 28 64 65 62 test)).... (deb
9a60: 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 31 20 ug:print-info 1
9a70: 22 41 74 74 65 6d 70 74 69 6e 67 20 74 6f 20 72 "Attempting to r
9a80: 65 6d 6f 76 65 20 22 20 28 69 66 20 72 65 61 6c emove " (if real
9a90: 2d 64 69 72 20 28 63 6f 6e 63 20 22 20 64 69 72 -dir (conc " dir
9aa0: 20 22 20 72 65 61 6c 2d 64 69 72 20 22 20 61 6e " real-dir " an
9ab0: 64 20 22 29 20 22 22 29 20 22 20 6c 69 6e 6b 20 d ") "") " link
9ac0: 22 20 72 75 6e 2d 64 69 72 29 0a 09 09 09 20 28 " run-dir).... (
9ad0: 69 66 20 28 61 6e 64 20 72 65 61 6c 2d 64 69 72 if (and real-dir
9ae0: 20 0a 09 09 09 09 20 20 28 3e 20 28 73 74 72 69 ..... (> (stri
9af0: 6e 67 2d 6c 65 6e 67 74 68 20 72 65 61 6c 2d 64 ng-length real-d
9b00: 69 72 29 20 35 29 0a 09 09 09 09 20 20 28 66 69 ir) 5)..... (fi
9b10: 6c 65 2d 65 78 69 73 74 73 3f 20 72 65 61 6c 2d le-exists? real-
9b20: 64 69 72 29 29 20 3b 3b 20 62 61 64 20 68 65 75 dir)) ;; bad heu
9b30: 72 69 73 74 69 63 20 62 75 74 20 73 68 6f 75 6c ristic but shoul
9b40: 64 20 70 72 65 76 65 6e 74 20 2f 74 6d 70 20 2f d prevent /tmp /
9b50: 68 6f 6d 65 20 65 74 63 2e 0a 09 09 09 20 20 20 home etc.....
9b60: 20 20 28 62 65 67 69 6e 20 3b 3b 20 6c 65 74 2a (begin ;; let*
9b70: 20 28 28 72 65 61 6c 70 61 74 68 20 28 72 65 73 ((realpath (res
9b80: 6f 6c 76 65 2d 70 61 74 68 6e 61 6d 65 20 72 75 olve-pathname ru
9b90: 6e 2d 64 69 72 29 29 29 0a 09 09 09 20 20 20 20 n-dir)))....
9ba0: 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d (debug:print-
9bb0: 69 6e 66 6f 20 31 20 22 52 65 63 75 72 73 69 76 info 1 "Recursiv
9bc0: 65 6c 79 20 72 65 6d 6f 76 69 6e 67 20 22 20 72 ely removing " r
9bd0: 65 61 6c 2d 64 69 72 29 0a 09 09 09 20 20 20 20 eal-dir)....
9be0: 20 20 20 28 69 66 20 28 66 69 6c 65 2d 65 78 69 (if (file-exi
9bf0: 73 74 73 3f 20 72 65 61 6c 2d 64 69 72 29 0a 09 sts? real-dir)..
9c00: 09 09 09 20 20 20 28 69 66 20 28 3e 20 28 73 79 ... (if (> (sy
9c10: 73 74 65 6d 20 28 63 6f 6e 63 20 22 72 6d 20 2d stem (conc "rm -
9c20: 72 66 20 22 20 72 65 61 6c 2d 64 69 72 29 29 20 rf " real-dir))
9c30: 30 29 0a 09 09 09 09 20 20 20 20 20 20 20 28 64 0)..... (d
9c40: 65 62 75 67 3a 70 72 69 6e 74 20 30 20 22 45 52 ebug:print 0 "ER
9c50: 52 4f 52 3a 20 54 68 65 72 65 20 77 61 73 20 61 ROR: There was a
9c60: 20 70 72 6f 62 6c 65 6d 20 72 65 6d 6f 76 69 6e problem removin
9c70: 67 20 22 20 72 65 61 6c 2d 64 69 72 20 22 20 77 g " real-dir " w
9c80: 69 74 68 20 72 6d 20 2d 66 22 29 29 0a 09 09 09 ith rm -f"))....
9c90: 09 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 . (debug:print
9ca0: 20 30 20 22 57 41 52 4e 49 4e 47 3a 20 74 65 73 0 "WARNING: tes
9cb0: 74 20 64 69 72 20 22 20 72 65 61 6c 2d 64 69 72 t dir " real-dir
9cc0: 20 22 20 61 70 70 65 61 72 73 20 74 6f 20 6e 6f " appears to no
9cd0: 74 20 65 78 69 73 74 20 6f 72 20 69 73 20 6e 6f t exist or is no
9ce0: 74 20 72 65 61 64 61 62 6c 65 22 29 29 29 0a 09 t readable")))..
9cf0: 09 09 20 20 20 20 20 28 69 66 20 72 65 61 6c 2d .. (if real-
9d00: 64 69 72 20 0a 09 09 09 09 20 28 64 65 62 75 67 dir ..... (debug
9d10: 3a 70 72 69 6e 74 20 30 20 22 57 41 52 4e 49 4e :print 0 "WARNIN
9d20: 47 3a 20 64 69 72 65 63 74 6f 72 79 20 22 20 72 G: directory " r
9d30: 65 61 6c 2d 64 69 72 20 22 20 64 6f 65 73 20 6e eal-dir " does n
9d40: 6f 74 20 65 78 69 73 74 22 29 0a 09 09 09 09 20 ot exist").....
9d50: 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 22 (debug:print 0 "
9d60: 57 41 52 4e 49 4e 47 3a 20 6e 6f 20 72 65 61 6c WARNING: no real
9d70: 20 64 69 72 65 63 74 6f 72 79 20 63 6f 72 72 6f directory corro
9d80: 73 70 6f 6e 64 69 6e 67 20 74 6f 20 6c 69 6e 6b sponding to link
9d90: 20 22 20 72 75 6e 2d 64 69 72 20 22 2c 20 6e 6f " run-dir ", no
9da0: 74 68 69 6e 67 20 64 6f 6e 65 22 29 29 29 0a 09 thing done")))..
9db0: 09 09 20 28 69 66 20 28 73 79 6d 62 6f 6c 69 63 .. (if (symbolic
9dc0: 2d 6c 69 6e 6b 3f 20 72 75 6e 2d 64 69 72 29 0a -link? run-dir).
9dd0: 09 09 09 20 20 20 20 20 28 62 65 67 69 6e 0a 09 ... (begin..
9de0: 09 09 20 20 20 20 20 20 20 28 64 65 62 75 67 3a .. (debug:
9df0: 70 72 69 6e 74 2d 69 6e 66 6f 20 31 20 22 52 65 print-info 1 "Re
9e00: 6d 6f 76 69 6e 67 20 73 79 6d 6c 69 6e 6b 20 22 moving symlink "
9e10: 20 72 75 6e 2d 64 69 72 29 0a 09 09 09 20 20 20 run-dir)....
9e20: 20 20 20 20 28 68 61 6e 64 6c 65 2d 65 78 63 65 (handle-exce
9e30: 70 74 69 6f 6e 73 0a 09 09 09 09 65 78 6e 0a 09 ptions.....exn..
9e40: 09 09 09 28 64 65 62 75 67 3a 70 72 69 6e 74 20 ...(debug:print
9e50: 30 20 22 45 52 52 4f 52 3a 20 20 46 61 69 6c 65 0 "ERROR: Faile
9e60: 64 20 74 6f 20 72 65 6d 6f 76 65 20 73 79 6d 6c d to remove syml
9e70: 69 6e 6b 20 22 20 72 75 6e 2d 64 69 72 20 28 28 ink " run-dir ((
9e80: 63 6f 6e 64 69 74 69 6f 6e 2d 70 72 6f 70 65 72 condition-proper
9e90: 74 79 2d 61 63 63 65 73 73 6f 72 20 27 65 78 6e ty-accessor 'exn
9ea0: 20 27 6d 65 73 73 61 67 65 29 20 65 78 6e 29 20 'message) exn)
9eb0: 22 2c 20 61 74 74 65 6d 70 74 69 6e 67 20 74 6f ", attempting to
9ec0: 20 63 6f 6e 74 69 6e 75 65 22 29 0a 09 09 09 09 continue").....
9ed0: 28 64 65 6c 65 74 65 2d 66 69 6c 65 20 72 75 6e (delete-file run
9ee0: 2d 64 69 72 29 29 29 0a 09 09 09 20 20 20 20 20 -dir)))....
9ef0: 28 69 66 20 28 64 69 72 65 63 74 6f 72 79 3f 20 (if (directory?
9f00: 72 75 6e 2d 64 69 72 29 0a 09 09 09 09 20 28 69 run-dir)..... (i
9f10: 66 20 28 3e 20 28 64 69 72 65 63 74 6f 72 79 2d f (> (directory-
9f20: 66 6f 6c 64 20 28 6c 61 6d 62 64 61 20 28 66 20 fold (lambda (f
9f30: 78 29 28 2b 20 31 20 78 29 29 20 30 20 72 75 6e x)(+ 1 x)) 0 run
9f40: 2d 64 69 72 29 20 30 29 0a 09 09 09 09 20 20 20 -dir) 0).....
9f50: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 (debug:print 0
9f60: 20 22 57 41 52 4e 49 4e 47 3a 20 72 65 66 75 73 "WARNING: refus
9f70: 69 6e 67 20 74 6f 20 72 65 6d 6f 76 65 20 22 20 ing to remove "
9f80: 72 75 6e 2d 64 69 72 20 22 20 61 73 20 69 74 20 run-dir " as it
9f90: 69 73 20 6e 6f 74 20 65 6d 70 74 79 22 29 0a 09 is not empty")..
9fa0: 09 09 09 20 20 20 20 20 20 28 68 61 6e 64 6c 65 ... (handle
9fb0: 2d 65 78 63 65 70 74 69 6f 6e 73 0a 09 09 09 09 -exceptions.....
9fc0: 20 20 20 20 20 20 20 65 78 6e 0a 09 09 09 09 20 exn.....
9fd0: 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 (debug:pri
9fe0: 6e 74 20 30 20 22 45 52 52 4f 52 3a 20 20 46 61 nt 0 "ERROR: Fa
9ff0: 69 6c 65 64 20 74 6f 20 72 65 6d 6f 76 65 20 64 iled to remove d
a000: 69 72 65 63 74 6f 72 79 20 22 20 72 75 6e 2d 64 irectory " run-d
a010: 69 72 20 28 28 63 6f 6e 64 69 74 69 6f 6e 2d 70 ir ((condition-p
a020: 72 6f 70 65 72 74 79 2d 61 63 63 65 73 73 6f 72 roperty-accessor
a030: 20 27 65 78 6e 20 27 6d 65 73 73 61 67 65 29 20 'exn 'message)
a040: 65 78 6e 29 20 22 2c 20 61 74 74 65 6d 70 74 69 exn) ", attempti
a050: 6e 67 20 74 6f 20 63 6f 6e 74 69 6e 75 65 22 29 ng to continue")
a060: 0a 09 09 09 09 20 20 20 20 20 20 20 28 64 65 6c ..... (del
a070: 65 74 65 2d 64 69 72 65 63 74 6f 72 79 20 72 75 ete-directory ru
a080: 6e 2d 64 69 72 29 29 29 0a 09 09 09 09 20 28 69 n-dir)))..... (i
a090: 66 20 72 75 6e 2d 64 69 72 0a 09 09 09 09 20 20 f run-dir.....
a0a0: 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 (debug:print
a0b0: 30 20 22 57 41 52 4e 49 4e 47 3a 20 6e 6f 74 20 0 "WARNING: not
a0c0: 72 65 6d 6f 76 69 6e 67 20 22 20 72 75 6e 2d 64 removing " run-d
a0d0: 69 72 20 22 20 61 73 20 69 74 20 65 69 74 68 65 ir " as it eithe
a0e0: 72 20 64 6f 65 73 6e 27 74 20 65 78 69 73 74 20 r doesn't exist
a0f0: 6f 72 20 69 73 20 6e 6f 74 20 61 20 73 79 6d 6c or is not a syml
a100: 69 6e 6b 22 29 0a 09 09 09 09 20 20 20 20 20 28 ink")..... (
a110: 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 22 4e debug:print 0 "N
a120: 4f 54 45 3a 20 74 68 65 20 72 75 6e 20 64 69 72 OTE: the run dir
a130: 20 66 6f 72 20 74 68 69 73 20 74 65 73 74 20 69 for this test i
a140: 73 20 75 6e 64 65 66 69 6e 65 64 2e 20 54 65 73 s undefined. Tes
a150: 74 20 6d 61 79 20 68 61 76 65 20 61 6c 72 65 61 t may have alrea
a160: 64 79 20 62 65 65 6e 20 64 65 6c 65 74 65 64 2e dy been deleted.
a170: 22 29 29 0a 09 09 09 09 20 29 29 29 0a 09 09 09 "))..... )))....
a180: 28 28 73 65 74 2d 73 74 61 74 65 2d 73 74 61 74 ((set-state-stat
a190: 75 73 29 0a 09 09 09 20 28 64 65 62 75 67 3a 70 us).... (debug:p
a1a0: 72 69 6e 74 2d 69 6e 66 6f 20 32 20 22 6e 65 77 rint-info 2 "new
a1b0: 20 73 74 61 74 65 20 22 20 28 63 61 72 20 73 74 state " (car st
a1c0: 61 74 65 2d 73 74 61 74 75 73 29 20 22 2c 20 6e ate-status) ", n
a1d0: 65 77 20 73 74 61 74 75 73 20 22 20 28 63 61 64 ew status " (cad
a1e0: 72 20 73 74 61 74 65 2d 73 74 61 74 75 73 29 29 r state-status))
a1f0: 0a 09 09 09 20 28 6f 70 65 6e 2d 72 75 6e 2d 63 .... (open-run-c
a200: 6c 6f 73 65 20 64 62 3a 74 65 73 74 2d 73 65 74 lose db:test-set
a210: 2d 73 74 61 74 65 2d 73 74 61 74 75 73 2d 62 79 -state-status-by
a220: 2d 69 64 20 64 62 20 28 64 62 3a 74 65 73 74 2d -id db (db:test-
a230: 67 65 74 2d 69 64 20 74 65 73 74 29 20 28 63 61 get-id test) (ca
a240: 72 20 73 74 61 74 65 2d 73 74 61 74 75 73 29 28 r state-status)(
a250: 63 61 64 72 20 73 74 61 74 65 2d 73 74 61 74 75 cadr state-statu
a260: 73 29 20 23 66 29 29 29 29 29 0a 09 09 20 20 28 s) #f)))))... (
a270: 73 6f 72 74 20 74 65 73 74 73 20 28 6c 61 6d 62 sort tests (lamb
a280: 64 61 20 28 61 20 62 29 28 6c 65 74 20 28 28 64 da (a b)(let ((d
a290: 69 72 61 20 28 64 62 3a 74 65 73 74 2d 67 65 74 ira (db:test-get
a2a0: 2d 72 75 6e 64 69 72 20 61 29 29 0a 09 09 09 09 -rundir a)).....
a2b0: 09 09 20 28 64 69 72 62 20 28 64 62 3a 74 65 73 .. (dirb (db:tes
a2c0: 74 2d 67 65 74 2d 72 75 6e 64 69 72 20 62 29 29 t-get-rundir b))
a2d0: 29 0a 09 09 09 09 09 20 20 20 20 20 28 69 66 20 )...... (if
a2e0: 28 61 6e 64 20 28 73 74 72 69 6e 67 3f 20 64 69 (and (string? di
a2f0: 72 61 29 28 73 74 72 69 6e 67 3f 20 64 69 72 62 ra)(string? dirb
a300: 29 29 0a 09 09 09 09 09 09 20 28 3e 20 28 73 74 ))....... (> (st
a310: 72 69 6e 67 2d 6c 65 6e 67 74 68 20 64 69 72 61 ring-length dira
a320: 29 28 73 74 72 69 6e 67 2d 6c 65 6e 67 74 68 20 )(string-length
a330: 64 69 72 62 29 29 0a 09 09 09 09 09 09 20 23 66 dirb))....... #f
a340: 29 29 29 29 29 29 29 0a 09 20 20 20 3b 3b 20 72 ))))))).. ;; r
a350: 65 6d 6f 76 65 20 74 68 65 20 72 75 6e 20 69 66 emove the run if
a360: 20 7a 65 72 6f 20 74 65 73 74 73 20 72 65 6d 61 zero tests rema
a370: 69 6e 0a 09 20 20 20 28 69 66 20 28 65 71 3f 20 in.. (if (eq?
a380: 61 63 74 69 6f 6e 20 27 72 65 6d 6f 76 65 2d 72 action 'remove-r
a390: 75 6e 73 29 0a 09 20 20 20 20 20 20 20 28 6c 65 uns).. (le
a3a0: 74 20 28 28 72 65 6d 74 65 73 74 73 20 28 6f 70 t ((remtests (op
a3b0: 65 6e 2d 72 75 6e 2d 63 6c 6f 73 65 20 64 62 3a en-run-close db:
a3c0: 67 65 74 2d 74 65 73 74 73 2d 66 6f 72 2d 72 75 get-tests-for-ru
a3d0: 6e 20 64 62 20 28 64 62 3a 67 65 74 2d 76 61 6c n db (db:get-val
a3e0: 75 65 2d 62 79 2d 68 65 61 64 65 72 20 72 75 6e ue-by-header run
a3f0: 20 68 65 61 64 65 72 20 22 69 64 22 29 20 23 66 header "id") #f
a400: 20 27 28 22 44 45 4c 45 54 45 44 22 29 20 27 28 '("DELETED") '(
a410: 22 6e 2f 61 22 29 20 6e 6f 74 2d 69 6e 3a 20 23 "n/a") not-in: #
a420: 74 29 29 29 0a 09 09 20 28 69 66 20 28 6e 75 6c t)))... (if (nul
a430: 6c 3f 20 72 65 6d 74 65 73 74 73 29 20 3b 3b 20 l? remtests) ;;
a440: 6e 6f 20 6d 6f 72 65 20 74 65 73 74 73 20 72 65 no more tests re
a450: 6d 61 69 6e 69 6e 67 0a 09 09 20 20 20 20 20 28 maining... (
a460: 6c 65 74 2a 20 28 28 64 70 61 72 74 73 20 20 28 let* ((dparts (
a470: 73 74 72 69 6e 67 2d 73 70 6c 69 74 20 6c 61 73 string-split las
a480: 74 74 70 61 74 68 20 22 2f 22 29 29 0a 09 09 09 ttpath "/"))....
a490: 20 20 20 20 28 72 75 6e 70 61 74 68 20 28 63 6f (runpath (co
a4a0: 6e 63 20 22 2f 22 20 28 73 74 72 69 6e 67 2d 69 nc "/" (string-i
a4b0: 6e 74 65 72 73 70 65 72 73 65 20 0a 09 09 09 09 ntersperse .....
a4c0: 09 09 28 74 61 6b 65 20 64 70 61 72 74 73 20 28 ..(take dparts (
a4d0: 2d 20 28 6c 65 6e 67 74 68 20 64 70 61 72 74 73 - (length dparts
a4e0: 29 20 31 29 29 0a 09 09 09 09 09 09 22 2f 22 29 ) 1))......."/")
a4f0: 29 29 29 0a 09 09 20 20 20 20 20 20 20 28 64 65 )))... (de
a500: 62 75 67 3a 70 72 69 6e 74 20 31 20 22 52 65 6d bug:print 1 "Rem
a510: 6f 76 69 6e 67 20 72 75 6e 3a 20 22 20 72 75 6e oving run: " run
a520: 6b 65 79 20 22 20 22 20 28 64 62 3a 67 65 74 2d key " " (db:get-
a530: 76 61 6c 75 65 2d 62 79 2d 68 65 61 64 65 72 20 value-by-header
a540: 72 75 6e 20 68 65 61 64 65 72 20 22 72 75 6e 6e run header "runn
a550: 61 6d 65 22 29 20 22 20 61 6e 64 20 72 65 6c 61 ame") " and rela
a560: 74 65 64 20 72 65 63 6f 72 64 22 29 0a 09 09 20 ted record")...
a570: 20 20 20 20 20 20 28 6f 70 65 6e 2d 72 75 6e 2d (open-run-
a580: 63 6c 6f 73 65 20 64 62 3a 64 65 6c 65 74 65 2d close db:delete-
a590: 72 75 6e 20 64 62 20 72 75 6e 2d 69 64 29 0a 09 run db run-id)..
a5a0: 09 20 20 20 20 20 20 20 3b 3b 20 54 68 69 73 20 . ;; This
a5b0: 69 73 20 61 20 70 72 65 74 74 79 20 67 6f 6f 64 is a pretty good
a5c0: 20 70 6c 61 63 65 20 74 6f 20 70 75 72 67 65 20 place to purge
a5d0: 6f 6c 64 20 44 45 4c 45 54 45 44 20 74 65 73 74 old DELETED test
a5e0: 73 0a 09 09 20 20 20 20 20 20 20 28 6f 70 65 6e s... (open
a5f0: 2d 72 75 6e 2d 63 6c 6f 73 65 20 64 62 3a 64 65 -run-close db:de
a600: 6c 65 74 65 2d 74 65 73 74 73 2d 66 6f 72 2d 72 lete-tests-for-r
a610: 75 6e 20 64 62 20 72 75 6e 2d 69 64 29 0a 09 09 un db run-id)...
a620: 20 20 20 20 20 20 20 28 6f 70 65 6e 2d 72 75 6e (open-run
a630: 2d 63 6c 6f 73 65 20 64 62 3a 64 65 6c 65 74 65 -close db:delete
a640: 2d 6f 6c 64 2d 64 65 6c 65 74 65 64 2d 74 65 73 -old-deleted-tes
a650: 74 2d 72 65 63 6f 72 64 73 20 64 62 29 0a 09 09 t-records db)...
a660: 20 20 20 20 20 20 20 28 6f 70 65 6e 2d 72 75 6e (open-run
a670: 2d 63 6c 6f 73 65 20 64 62 3a 73 65 74 2d 76 61 -close db:set-va
a680: 72 20 64 62 20 22 44 45 4c 45 54 45 44 5f 54 45 r db "DELETED_TE
a690: 53 54 53 22 20 28 63 75 72 72 65 6e 74 2d 73 65 STS" (current-se
a6a0: 63 6f 6e 64 73 29 29 0a 09 09 20 20 20 20 20 20 conds))...
a6b0: 20 3b 3b 20 6e 65 65 64 20 74 6f 20 66 69 67 75 ;; need to figu
a6c0: 72 65 20 6f 75 74 20 74 68 65 20 70 61 74 68 20 re out the path
a6d0: 74 6f 20 74 68 65 20 72 75 6e 20 64 69 72 20 61 to the run dir a
a6e0: 6e 64 20 72 65 6d 6f 76 65 20 69 74 20 69 66 20 nd remove it if
a6f0: 65 6d 70 74 79 0a 09 09 20 20 20 20 20 20 20 3b empty... ;
a700: 3b 20 20 20 20 28 69 66 20 28 6e 75 6c 6c 3f 20 ; (if (null?
a710: 28 67 6c 6f 62 20 28 63 6f 6e 63 20 72 75 6e 70 (glob (conc runp
a720: 61 74 68 20 22 2f 2a 22 29 29 29 0a 09 09 20 20 ath "/*")))...
a730: 20 20 20 20 20 3b 3b 20 20 20 20 20 20 20 20 28 ;; (
a740: 62 65 67 69 6e 0a 09 09 20 20 20 20 20 20 20 3b begin... ;
a750: 3b 20 09 20 28 64 65 62 75 67 3a 70 72 69 6e 74 ; . (debug:print
a760: 20 31 20 22 52 65 6d 6f 76 69 6e 67 20 72 75 6e 1 "Removing run
a770: 20 64 69 72 20 22 20 72 75 6e 70 61 74 68 29 0a dir " runpath).
a780: 09 09 20 20 20 20 20 20 20 3b 3b 20 09 20 28 73 .. ;; . (s
a790: 79 73 74 65 6d 20 28 63 6f 6e 63 20 22 72 6d 64 ystem (conc "rmd
a7a0: 69 72 20 2d 70 20 22 20 72 75 6e 70 61 74 68 29 ir -p " runpath)
a7b0: 29 29 29 0a 09 09 20 20 20 20 20 20 20 29 29 29 )))... )))
a7c0: 29 29 0a 09 20 29 29 0a 20 20 20 20 20 72 75 6e )).. )). run
a7d0: 73 29 29 0a 20 20 23 74 29 0a 0a 3b 3b 3d 3d 3d s)). #t)..;;===
a7e0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
a7f0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
a800: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
a810: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
a820: 3d 3d 3d 0a 3b 3b 20 52 6f 75 74 69 6e 65 73 20 ===.;; Routines
a830: 66 6f 72 20 6d 61 6e 69 70 75 6c 61 74 69 6e 67 for manipulating
a840: 20 72 75 6e 73 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d runs.;;========
a850: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
a860: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
a870: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
a880: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a ==============..
a890: 3b 3b 20 53 69 6e 63 65 20 6d 61 6e 79 20 63 61 ;; Since many ca
a8a0: 6c 6c 73 20 74 6f 20 61 20 72 75 6e 20 72 65 71 lls to a run req
a8b0: 75 69 72 65 20 70 72 65 74 74 79 20 6d 75 63 68 uire pretty much
a8c0: 20 74 68 65 20 73 61 6d 65 20 73 65 74 75 70 20 the same setup
a8d0: 0a 3b 3b 20 74 68 69 73 20 77 72 61 70 70 65 72 .;; this wrapper
a8e0: 20 69 73 20 75 73 65 64 20 74 6f 20 72 65 64 75 is used to redu
a8f0: 63 65 20 74 68 65 20 72 65 70 6c 69 63 61 74 69 ce the replicati
a900: 6f 6e 20 6f 66 20 63 6f 64 65 0a 28 64 65 66 69 on of code.(defi
a910: 6e 65 20 28 67 65 6e 65 72 61 6c 2d 72 75 6e 2d ne (general-run-
a920: 63 61 6c 6c 20 73 77 69 74 63 68 6e 61 6d 65 20 call switchname
a930: 61 63 74 69 6f 6e 2d 64 65 73 63 20 70 72 6f 63 action-desc proc
a940: 29 0a 20 20 28 6c 65 74 20 28 28 72 75 6e 6e 61 ). (let ((runna
a950: 6d 65 20 28 61 72 67 73 3a 67 65 74 2d 61 72 67 me (args:get-arg
a960: 20 22 3a 72 75 6e 6e 61 6d 65 22 29 29 0a 09 28 ":runname"))..(
a970: 74 61 72 67 65 74 20 20 28 69 66 20 28 61 72 67 target (if (arg
a980: 73 3a 67 65 74 2d 61 72 67 20 22 2d 74 61 72 67 s:get-arg "-targ
a990: 65 74 22 29 0a 09 09 20 20 20 20 20 28 61 72 67 et")... (arg
a9a0: 73 3a 67 65 74 2d 61 72 67 20 22 2d 74 61 72 67 s:get-arg "-targ
a9b0: 65 74 22 29 0a 09 09 20 20 20 20 20 28 61 72 67 et")... (arg
a9c0: 73 3a 67 65 74 2d 61 72 67 20 22 2d 72 65 71 74 s:get-arg "-reqt
a9d0: 61 72 67 22 29 29 29 0a 09 28 74 68 31 20 20 20 arg")))..(th1
a9e0: 20 20 23 66 29 29 0a 20 20 20 20 28 63 6f 6e 64 #f)). (cond
a9f0: 0a 20 20 20 20 20 28 28 6e 6f 74 20 74 61 72 67 . ((not targ
aa00: 65 74 29 0a 20 20 20 20 20 20 28 64 65 62 75 67 et). (debug
aa10: 3a 70 72 69 6e 74 20 30 20 22 45 52 52 4f 52 3a :print 0 "ERROR:
aa20: 20 4d 69 73 73 69 6e 67 20 72 65 71 75 69 72 65 Missing require
aa30: 64 20 70 61 72 61 6d 65 74 65 72 20 66 6f 72 20 d parameter for
aa40: 22 20 73 77 69 74 63 68 6e 61 6d 65 20 22 2c 20 " switchname ",
aa50: 79 6f 75 20 6d 75 73 74 20 73 70 65 63 69 66 79 you must specify
aa60: 20 74 68 65 20 74 61 72 67 65 74 20 77 69 74 68 the target with
aa70: 20 2d 74 61 72 67 65 74 22 29 0a 20 20 20 20 20 -target").
aa80: 20 28 65 78 69 74 20 33 29 29 0a 20 20 20 20 20 (exit 3)).
aa90: 28 28 6e 6f 74 20 72 75 6e 6e 61 6d 65 29 0a 20 ((not runname).
aaa0: 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e (debug:prin
aab0: 74 20 30 20 22 45 52 52 4f 52 3a 20 4d 69 73 73 t 0 "ERROR: Miss
aac0: 69 6e 67 20 72 65 71 75 69 72 65 64 20 70 61 72 ing required par
aad0: 61 6d 65 74 65 72 20 66 6f 72 20 22 20 73 77 69 ameter for " swi
aae0: 74 63 68 6e 61 6d 65 20 22 2c 20 79 6f 75 20 6d tchname ", you m
aaf0: 75 73 74 20 73 70 65 63 69 66 79 20 74 68 65 20 ust specify the
ab00: 72 75 6e 20 6e 61 6d 65 20 77 69 74 68 20 3a 72 run name with :r
ab10: 75 6e 6e 61 6d 65 20 72 75 6e 6e 61 6d 65 22 29 unname runname")
ab20: 0a 20 20 20 20 20 20 28 65 78 69 74 20 33 29 29 . (exit 3))
ab30: 0a 20 20 20 20 20 28 65 6c 73 65 0a 20 20 20 20 . (else.
ab40: 20 20 28 6c 65 74 20 28 28 64 62 20 20 20 23 66 (let ((db #f
ab50: 29 0a 09 20 20 20 20 28 6b 65 79 73 20 23 66 29 ).. (keys #f)
ab60: 29 0a 09 28 69 66 20 28 6e 6f 74 20 28 73 65 74 )..(if (not (set
ab70: 75 70 2d 66 6f 72 2d 72 75 6e 29 29 0a 09 20 20 up-for-run))..
ab80: 20 20 28 62 65 67 69 6e 20 0a 09 20 20 20 20 20 (begin ..
ab90: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 (debug:print 0
aba0: 22 46 61 69 6c 65 64 20 74 6f 20 73 65 74 75 70 "Failed to setup
abb0: 2c 20 65 78 69 74 69 6e 67 22 29 0a 09 20 20 20 , exiting")..
abc0: 20 20 20 28 65 78 69 74 20 31 29 29 29 0a 09 28 (exit 1)))..(
abd0: 69 66 20 28 61 72 67 73 3a 67 65 74 2d 61 72 67 if (args:get-arg
abe0: 20 22 2d 73 65 72 76 65 72 22 29 0a 09 20 20 20 "-server")..
abf0: 20 28 6f 70 65 6e 2d 72 75 6e 2d 63 6c 6f 73 65 (open-run-close
ac00: 20 73 65 72 76 65 72 3a 73 74 61 72 74 20 64 62 server:start db
ac10: 20 28 61 72 67 73 3a 67 65 74 2d 61 72 67 20 22 (args:get-arg "
ac20: 2d 73 65 72 76 65 72 22 29 29 29 0a 20 09 20 20 -server"))). .
ac30: 20 20 3b 3b 20 28 69 66 20 28 6e 6f 74 20 28 6f ;; (if (not (o
ac40: 72 20 28 61 72 67 73 3a 67 65 74 2d 61 72 67 20 r (args:get-arg
ac50: 22 2d 72 75 6e 61 6c 6c 22 29 20 20 20 20 20 3b "-runall") ;
ac60: 3b 20 72 75 6e 61 6c 6c 20 61 6e 64 20 72 75 6e ; runall and run
ac70: 74 65 73 74 73 20 61 72 65 20 61 6c 6c 6f 77 65 tests are allowe
ac80: 64 20 74 6f 20 62 65 20 73 65 72 76 65 72 73 0a d to be servers.
ac90: 20 09 20 20 20 20 3b 3b 20 20 20 20 20 09 20 28 . ;; . (
aca0: 61 72 67 73 3a 67 65 74 2d 61 72 67 20 22 2d 72 args:get-arg "-r
acb0: 75 6e 74 65 73 74 73 22 29 29 29 0a 09 20 20 20 untests")))..
acc0: 20 3b 3b 20 20 20 20 20 28 63 6c 69 65 6e 74 3a ;; (client:
acd0: 73 65 74 75 70 29 20 3b 3b 20 54 68 69 73 20 69 setup) ;; This i
ace0: 73 20 61 20 64 75 70 6c 69 63 61 74 65 20 73 74 s a duplicate st
acf0: 61 72 74 75 70 21 21 21 3f 3f 3f 20 42 55 47 3f artup!!!??? BUG?
ad00: 0a 09 20 20 20 20 3b 3b 20 20 20 20 20 29 29 0a .. ;; )).
ad10: 09 28 73 65 74 21 20 6b 65 79 73 20 28 6f 70 65 .(set! keys (ope
ad20: 6e 2d 72 75 6e 2d 63 6c 6f 73 65 20 64 62 3a 67 n-run-close db:g
ad30: 65 74 2d 6b 65 79 73 20 64 62 29 29 0a 09 3b 3b et-keys db))..;;
ad40: 20 68 61 76 65 20 65 6e 6f 75 67 68 20 74 6f 20 have enough to
ad50: 70 72 6f 63 65 73 73 20 2d 74 61 72 67 65 74 20 process -target
ad60: 6f 72 20 2d 72 65 71 74 61 72 67 20 68 65 72 65 or -reqtarg here
ad70: 0a 09 28 69 66 20 28 61 72 67 73 3a 67 65 74 2d ..(if (args:get-
ad80: 61 72 67 20 22 2d 72 65 71 74 61 72 67 22 29 0a arg "-reqtarg").
ad90: 09 20 20 20 20 28 6c 65 74 2a 20 28 28 72 75 6e . (let* ((run
ada0: 63 6f 6e 66 69 67 66 20 28 63 6f 6e 63 20 20 2a configf (conc *
adb0: 74 6f 70 70 61 74 68 2a 20 22 2f 72 75 6e 63 6f toppath* "/runco
adc0: 6e 66 69 67 73 2e 63 6f 6e 66 69 67 22 29 29 20 nfigs.config"))
add0: 3b 3b 20 44 4f 20 4e 4f 54 20 45 56 41 4c 55 41 ;; DO NOT EVALUA
ade0: 54 45 20 41 4c 4c 20 0a 09 09 20 20 20 28 72 75 TE ALL ... (ru
adf0: 6e 63 6f 6e 66 69 67 20 20 28 72 65 61 64 2d 63 nconfig (read-c
ae00: 6f 6e 66 69 67 20 72 75 6e 63 6f 6e 66 69 67 66 onfig runconfigf
ae10: 20 23 66 20 23 74 20 65 6e 76 69 72 6f 6e 2d 70 #f #t environ-p
ae20: 61 74 74 3a 20 23 66 29 29 29 20 0a 09 20 20 20 att: #f))) ..
ae30: 20 20 20 28 69 66 20 28 68 61 73 68 2d 74 61 62 (if (hash-tab
ae40: 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 72 le-ref/default r
ae50: 75 6e 63 6f 6e 66 69 67 20 28 61 72 67 73 3a 67 unconfig (args:g
ae60: 65 74 2d 61 72 67 20 22 2d 72 65 71 74 61 72 67 et-arg "-reqtarg
ae70: 22 29 20 23 66 29 0a 09 09 20 20 28 6b 65 79 73 ") #f)... (keys
ae80: 3a 74 61 72 67 65 74 2d 73 65 74 2d 61 72 67 73 :target-set-args
ae90: 20 6b 65 79 73 20 28 61 72 67 73 3a 67 65 74 2d keys (args:get-
aea0: 61 72 67 20 22 2d 72 65 71 74 61 72 67 22 29 20 arg "-reqtarg")
aeb0: 61 72 67 73 3a 61 72 67 2d 68 61 73 68 29 0a 09 args:arg-hash)..
aec0: 09 20 20 28 62 65 67 69 6e 0a 09 09 20 20 20 20 . (begin...
aed0: 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 22 (debug:print 0 "
aee0: 45 52 52 4f 52 3a 20 5b 22 20 28 61 72 67 73 3a ERROR: [" (args:
aef0: 67 65 74 2d 61 72 67 20 22 2d 72 65 71 74 61 72 get-arg "-reqtar
af00: 67 22 29 20 22 5d 20 6e 6f 74 20 66 6f 75 6e 64 g") "] not found
af10: 20 69 6e 20 22 20 72 75 6e 63 6f 6e 66 69 67 66 in " runconfigf
af20: 29 0a 09 09 20 20 20 20 28 69 66 20 64 62 20 28 )... (if db (
af30: 73 71 6c 69 74 65 33 3a 66 69 6e 61 6c 69 7a 65 sqlite3:finalize
af40: 21 20 64 62 29 29 0a 09 09 20 20 20 20 28 65 78 ! db))... (ex
af50: 69 74 20 31 29 29 29 29 0a 09 20 20 20 20 28 69 it 1)))).. (i
af60: 66 20 28 61 72 67 73 3a 67 65 74 2d 61 72 67 20 f (args:get-arg
af70: 22 2d 74 61 72 67 65 74 22 29 0a 09 09 28 6b 65 "-target")...(ke
af80: 79 73 3a 74 61 72 67 65 74 2d 73 65 74 2d 61 72 ys:target-set-ar
af90: 67 73 20 6b 65 79 73 20 28 61 72 67 73 3a 67 65 gs keys (args:ge
afa0: 74 2d 61 72 67 20 22 2d 74 61 72 67 65 74 22 20 t-arg "-target"
afb0: 61 72 67 73 3a 61 72 67 2d 68 61 73 68 29 20 61 args:arg-hash) a
afc0: 72 67 73 3a 61 72 67 2d 68 61 73 68 29 29 29 0a rgs:arg-hash))).
afd0: 09 28 69 66 20 28 6e 6f 74 20 28 63 61 72 20 2a .(if (not (car *
afe0: 63 6f 6e 66 69 67 69 6e 66 6f 2a 29 29 0a 09 20 configinfo*))..
aff0: 20 20 20 28 62 65 67 69 6e 0a 09 20 20 20 20 20 (begin..
b000: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 (debug:print 0
b010: 22 45 52 52 4f 52 3a 20 41 74 74 65 6d 70 74 65 "ERROR: Attempte
b020: 64 20 74 6f 20 22 20 61 63 74 69 6f 6e 2d 64 65 d to " action-de
b030: 73 63 20 22 20 62 75 74 20 72 75 6e 20 61 72 65 sc " but run are
b040: 61 20 63 6f 6e 66 69 67 20 66 69 6c 65 20 6e 6f a config file no
b050: 74 20 66 6f 75 6e 64 22 29 0a 09 20 20 20 20 20 t found")..
b060: 20 28 65 78 69 74 20 31 29 29 0a 09 20 20 20 20 (exit 1))..
b070: 3b 3b 20 45 78 74 72 61 63 74 20 6f 75 74 20 73 ;; Extract out s
b080: 74 75 66 66 20 6e 65 65 64 65 64 20 69 6e 20 6d tuff needed in m
b090: 6f 73 74 20 6f 72 20 6d 61 6e 79 20 63 61 6c 6c ost or many call
b0a0: 73 0a 09 20 20 20 20 3b 3b 20 68 65 72 65 20 74 s.. ;; here t
b0b0: 68 65 6e 20 63 61 6c 6c 20 70 72 6f 63 0a 09 20 hen call proc..
b0c0: 20 20 20 28 6c 65 74 2a 20 28 28 6b 65 79 6e 61 (let* ((keyna
b0d0: 6d 65 73 20 20 20 28 6d 61 70 20 6b 65 79 3a 67 mes (map key:g
b0e0: 65 74 2d 66 69 65 6c 64 6e 61 6d 65 20 6b 65 79 et-fieldname key
b0f0: 73 29 29 0a 09 09 20 20 20 28 6b 65 79 76 61 6c s))... (keyval
b100: 6c 73 74 20 20 28 6b 65 79 73 2d 3e 76 61 6c 6c lst (keys->vall
b110: 69 73 74 20 6b 65 79 73 20 23 74 29 29 29 0a 09 ist keys #t)))..
b120: 20 20 20 20 20 20 28 70 72 6f 63 20 74 61 72 67 (proc targ
b130: 65 74 20 72 75 6e 6e 61 6d 65 20 6b 65 79 73 20 et runname keys
b140: 6b 65 79 6e 61 6d 65 73 20 6b 65 79 76 61 6c 6c keynames keyvall
b150: 73 74 29 29 29 0a 09 28 69 66 20 74 68 31 20 28 st)))..(if th1 (
b160: 74 68 72 65 61 64 2d 6a 6f 69 6e 21 20 74 68 31 thread-join! th1
b170: 29 29 0a 09 28 69 66 20 64 62 20 28 73 71 6c 69 ))..(if db (sqli
b180: 74 65 33 3a 66 69 6e 61 6c 69 7a 65 21 20 64 62 te3:finalize! db
b190: 29 29 0a 09 28 73 65 74 21 20 2a 64 69 64 73 6f ))..(set! *didso
b1a0: 6d 65 74 68 69 6e 67 2a 20 23 74 29 29 29 29 29 mething* #t)))))
b1b0: 29 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d )..;;===========
b1c0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
b1d0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
b1e0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
b1f0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 4c ===========.;; L
b200: 6f 63 6b 2f 75 6e 6c 6f 63 6b 20 72 75 6e 73 0a ock/unlock runs.
b210: 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;;==============
b220: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
b230: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
b240: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
b250: 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 28 64 65 66 69 6e ========..(defin
b260: 65 20 28 72 75 6e 73 3a 68 61 6e 64 6c 65 2d 6c e (runs:handle-l
b270: 6f 63 6b 69 6e 67 20 74 61 72 67 65 74 20 6b 65 ocking target ke
b280: 79 73 20 72 75 6e 6e 61 6d 65 20 6c 6f 63 6b 20 ys runname lock
b290: 75 6e 6c 6f 63 6b 20 75 73 65 72 29 0a 20 20 28 unlock user). (
b2a0: 6c 65 74 2a 20 28 28 64 62 20 20 20 20 20 20 20 let* ((db
b2b0: 23 66 29 0a 09 20 28 72 75 6e 64 61 74 20 20 20 #f).. (rundat
b2c0: 28 6f 70 65 6e 2d 72 75 6e 2d 63 6c 6f 73 65 20 (open-run-close
b2d0: 72 75 6e 73 3a 67 65 74 2d 72 75 6e 73 2d 62 79 runs:get-runs-by
b2e0: 2d 70 61 74 74 20 64 62 20 6b 65 79 73 20 72 75 -patt db keys ru
b2f0: 6e 6e 61 6d 65 29 29 0a 09 20 28 68 65 61 64 65 nname)).. (heade
b300: 72 20 20 20 28 76 65 63 74 6f 72 2d 72 65 66 20 r (vector-ref
b310: 72 75 6e 64 61 74 20 30 29 29 0a 09 20 28 72 75 rundat 0)).. (ru
b320: 6e 73 20 20 20 20 20 28 76 65 63 74 6f 72 2d 72 ns (vector-r
b330: 65 66 20 72 75 6e 64 61 74 20 31 29 29 29 0a 20 ef rundat 1))).
b340: 20 20 20 28 66 6f 72 2d 65 61 63 68 20 28 6c 61 (for-each (la
b350: 6d 62 64 61 20 28 72 75 6e 29 0a 09 09 28 6c 65 mbda (run)...(le
b360: 74 20 28 28 72 75 6e 2d 69 64 20 28 64 62 3a 67 t ((run-id (db:g
b370: 65 74 2d 76 61 6c 75 65 2d 62 79 2d 68 65 61 64 et-value-by-head
b380: 65 72 20 72 75 6e 20 68 65 61 64 65 72 20 22 69 er run header "i
b390: 64 22 29 29 29 0a 09 09 20 20 28 69 66 20 28 6f d")))... (if (o
b3a0: 72 20 6c 6f 63 6b 0a 09 09 09 20 20 28 61 6e 64 r lock.... (and
b3b0: 20 75 6e 6c 6f 63 6b 0a 09 09 09 20 20 20 20 20 unlock....
b3c0: 20 20 28 62 65 67 69 6e 0a 09 09 09 09 20 28 70 (begin..... (p
b3d0: 72 69 6e 74 20 22 44 6f 20 79 6f 75 20 72 65 61 rint "Do you rea
b3e0: 6c 6c 79 20 77 69 73 68 20 74 6f 20 75 6e 6c 6f lly wish to unlo
b3f0: 63 6b 20 72 75 6e 20 22 20 72 75 6e 2d 69 64 20 ck run " run-id
b400: 22 3f 5c 6e 20 20 20 79 2f 6e 3a 20 22 29 0a 09 "?\n y/n: ")..
b410: 09 09 09 20 28 65 71 75 61 6c 3f 20 22 79 22 20 ... (equal? "y"
b420: 28 72 65 61 64 2d 6c 69 6e 65 29 29 29 29 29 0a (read-line))))).
b430: 09 09 20 20 20 20 20 20 28 6f 70 65 6e 2d 72 75 .. (open-ru
b440: 6e 2d 63 6c 6f 73 65 20 64 62 3a 6c 6f 63 6b 2f n-close db:lock/
b450: 75 6e 6c 6f 63 6b 2d 72 75 6e 20 64 62 20 72 75 unlock-run db ru
b460: 6e 2d 69 64 20 6c 6f 63 6b 20 75 6e 6c 6f 63 6b n-id lock unlock
b470: 20 75 73 65 72 29 0a 09 09 20 20 20 20 20 20 28 user)... (
b480: 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f debug:print-info
b490: 20 30 20 22 53 6b 69 70 70 69 6e 67 20 6c 6f 63 0 "Skipping loc
b4a0: 6b 2f 75 6e 6c 6f 63 6b 20 6f 6e 20 22 20 72 75 k/unlock on " ru
b4b0: 6e 2d 69 64 29 29 29 29 0a 09 20 20 20 20 20 20 n-id))))..
b4c0: 72 75 6e 73 29 29 29 0a 3b 3b 3d 3d 3d 3d 3d 3d runs))).;;======
b4d0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
b4e0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
b4f0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
b500: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
b510: 0a 3b 3b 20 52 6f 6c 6c 75 70 20 72 75 6e 73 0a .;; Rollup runs.
b520: 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;;==============
b530: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
b540: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
b550: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
b560: 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 3b 3b 20 55 70 64 ========..;; Upd
b570: 61 74 65 20 74 68 65 20 74 65 73 74 5f 6d 65 74 ate the test_met
b580: 61 20 74 61 62 6c 65 20 66 6f 72 20 74 68 69 73 a table for this
b590: 20 74 65 73 74 0a 28 64 65 66 69 6e 65 20 28 72 test.(define (r
b5a0: 75 6e 73 3a 75 70 64 61 74 65 2d 74 65 73 74 5f uns:update-test_
b5b0: 6d 65 74 61 20 64 62 20 74 65 73 74 2d 6e 61 6d meta db test-nam
b5c0: 65 20 74 65 73 74 2d 63 6f 6e 66 29 0a 20 20 28 e test-conf). (
b5d0: 6c 65 74 20 28 28 63 75 72 72 72 65 63 6f 72 64 let ((currrecord
b5e0: 20 28 6f 70 65 6e 2d 72 75 6e 2d 63 6c 6f 73 65 (open-run-close
b5f0: 20 64 62 3a 74 65 73 74 6d 65 74 61 2d 67 65 74 db:testmeta-get
b600: 2d 72 65 63 6f 72 64 20 64 62 20 74 65 73 74 2d -record db test-
b610: 6e 61 6d 65 29 29 29 0a 20 20 20 20 28 69 66 20 name))). (if
b620: 28 6e 6f 74 20 63 75 72 72 72 65 63 6f 72 64 29 (not currrecord)
b630: 0a 09 28 62 65 67 69 6e 0a 09 20 20 28 73 65 74 ..(begin.. (set
b640: 21 20 63 75 72 72 72 65 63 6f 72 64 20 28 6d 61 ! currrecord (ma
b650: 6b 65 2d 76 65 63 74 6f 72 20 31 30 20 23 66 29 ke-vector 10 #f)
b660: 29 0a 09 20 20 28 6f 70 65 6e 2d 72 75 6e 2d 63 ).. (open-run-c
b670: 6c 6f 73 65 20 64 62 3a 74 65 73 74 6d 65 74 61 lose db:testmeta
b680: 2d 61 64 64 2d 72 65 63 6f 72 64 20 64 62 20 74 -add-record db t
b690: 65 73 74 2d 6e 61 6d 65 29 29 29 0a 20 20 20 20 est-name))).
b6a0: 28 66 6f 72 2d 65 61 63 68 20 0a 20 20 20 20 20 (for-each .
b6b0: 28 6c 61 6d 62 64 61 20 28 6b 65 79 29 0a 20 20 (lambda (key).
b6c0: 20 20 20 20 20 28 6c 65 74 2a 20 28 28 69 64 78 (let* ((idx
b6d0: 20 28 63 61 64 72 20 6b 65 79 29 29 0a 09 20 20 (cadr key))..
b6e0: 20 20 20 20 28 66 6c 64 20 28 63 61 72 20 20 6b (fld (car k
b6f0: 65 79 29 29 0a 09 20 20 20 20 20 20 28 76 61 6c ey)).. (val
b700: 20 28 63 6f 6e 66 69 67 2d 6c 6f 6f 6b 75 70 20 (config-lookup
b710: 74 65 73 74 2d 63 6f 6e 66 20 22 74 65 73 74 5f test-conf "test_
b720: 6d 65 74 61 22 20 66 6c 64 29 29 29 0a 09 20 3b meta" fld))).. ;
b730: 3b 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 35 ; (debug:print 5
b740: 20 22 69 64 78 3a 20 22 20 69 64 78 20 22 20 66 "idx: " idx " f
b750: 6c 64 3a 20 22 20 66 6c 64 20 22 20 76 61 6c 3a ld: " fld " val:
b760: 20 22 20 76 61 6c 29 0a 09 20 28 69 66 20 28 61 " val).. (if (a
b770: 6e 64 20 76 61 6c 20 28 6e 6f 74 20 28 65 71 75 nd val (not (equ
b780: 61 6c 3f 20 28 76 65 63 74 6f 72 2d 72 65 66 20 al? (vector-ref
b790: 63 75 72 72 72 65 63 6f 72 64 20 69 64 78 29 20 currrecord idx)
b7a0: 76 61 6c 29 29 29 0a 09 20 20 20 20 20 28 62 65 val))).. (be
b7b0: 67 69 6e 0a 09 20 20 20 20 20 20 20 28 70 72 69 gin.. (pri
b7c0: 6e 74 20 22 55 70 64 61 74 69 6e 67 20 22 20 74 nt "Updating " t
b7d0: 65 73 74 2d 6e 61 6d 65 20 22 20 22 20 66 6c 64 est-name " " fld
b7e0: 20 22 20 74 6f 20 22 20 76 61 6c 29 0a 09 20 20 " to " val)..
b7f0: 20 20 20 20 20 28 6f 70 65 6e 2d 72 75 6e 2d 63 (open-run-c
b800: 6c 6f 73 65 20 64 62 3a 74 65 73 74 6d 65 74 61 lose db:testmeta
b810: 2d 75 70 64 61 74 65 2d 66 69 65 6c 64 20 64 62 -update-field db
b820: 20 74 65 73 74 2d 6e 61 6d 65 20 66 6c 64 20 76 test-name fld v
b830: 61 6c 29 29 29 29 29 0a 20 20 20 20 20 27 28 28 al))))). '((
b840: 22 61 75 74 68 6f 72 22 20 32 29 28 22 6f 77 6e "author" 2)("own
b850: 65 72 22 20 33 29 28 22 64 65 73 63 72 69 70 74 er" 3)("descript
b860: 69 6f 6e 22 20 34 29 28 22 72 65 76 69 65 77 65 ion" 4)("reviewe
b870: 64 22 20 35 29 28 22 74 61 67 73 22 20 39 29 29 d" 5)("tags" 9))
b880: 29 29 29 0a 0a 3b 3b 20 55 70 64 61 74 65 20 74 )))..;; Update t
b890: 65 73 74 5f 6d 65 74 61 20 66 6f 72 20 61 6c 6c est_meta for all
b8a0: 20 74 65 73 74 73 0a 28 64 65 66 69 6e 65 20 28 tests.(define (
b8b0: 72 75 6e 73 3a 75 70 64 61 74 65 2d 61 6c 6c 2d runs:update-all-
b8c0: 74 65 73 74 5f 6d 65 74 61 20 64 62 29 0a 20 20 test_meta db).
b8d0: 28 6c 65 74 20 28 28 74 65 73 74 2d 6e 61 6d 65 (let ((test-name
b8e0: 73 20 28 67 65 74 2d 61 6c 6c 2d 6c 65 67 61 6c s (get-all-legal
b8f0: 2d 74 65 73 74 73 29 29 29 0a 20 20 20 20 28 66 -tests))). (f
b900: 6f 72 2d 65 61 63 68 20 0a 20 20 20 20 20 28 6c or-each . (l
b910: 61 6d 62 64 61 20 28 74 65 73 74 2d 6e 61 6d 65 ambda (test-name
b920: 29 0a 20 20 20 20 20 20 20 28 6c 65 74 2a 20 28 ). (let* (
b930: 28 74 65 73 74 2d 70 61 74 68 20 20 20 20 28 63 (test-path (c
b940: 6f 6e 63 20 2a 74 6f 70 70 61 74 68 2a 20 22 2f onc *toppath* "/
b950: 74 65 73 74 73 2f 22 20 74 65 73 74 2d 6e 61 6d tests/" test-nam
b960: 65 29 29 0a 09 20 20 20 20 20 20 28 74 65 73 74 e)).. (test
b970: 2d 63 6f 6e 66 69 67 66 20 28 63 6f 6e 63 20 74 -configf (conc t
b980: 65 73 74 2d 70 61 74 68 20 22 2f 74 65 73 74 63 est-path "/testc
b990: 6f 6e 66 69 67 22 29 29 0a 09 20 20 20 20 20 20 onfig"))..
b9a0: 28 74 65 73 74 65 78 69 73 74 73 20 20 20 28 61 (testexists (a
b9b0: 6e 64 20 28 66 69 6c 65 2d 65 78 69 73 74 73 3f nd (file-exists?
b9c0: 20 74 65 73 74 2d 63 6f 6e 66 69 67 66 29 28 66 test-configf)(f
b9d0: 69 6c 65 2d 72 65 61 64 2d 61 63 63 65 73 73 3f ile-read-access?
b9e0: 20 74 65 73 74 2d 63 6f 6e 66 69 67 66 29 29 29 test-configf)))
b9f0: 0a 09 20 20 20 20 20 20 3b 3b 20 72 65 61 64 20 .. ;; read
ba00: 63 6f 6e 66 69 67 73 20 77 69 74 68 20 74 72 69 configs with tri
ba10: 63 6b 73 20 74 75 72 6e 65 64 20 6f 66 66 20 28 cks turned off (
ba20: 69 2e 65 2e 20 6e 6f 20 73 79 73 74 65 6d 29 0a i.e. no system).
ba30: 09 20 20 20 20 20 20 28 74 65 73 74 2d 63 6f 6e . (test-con
ba40: 66 20 20 20 20 28 69 66 20 74 65 73 74 65 78 69 f (if testexi
ba50: 73 74 73 20 28 72 65 61 64 2d 63 6f 6e 66 69 67 sts (read-config
ba60: 20 74 65 73 74 2d 63 6f 6e 66 69 67 66 20 23 66 test-configf #f
ba70: 20 23 66 29 28 6d 61 6b 65 2d 68 61 73 68 2d 74 #f)(make-hash-t
ba80: 61 62 6c 65 29 29 29 29 0a 09 20 3b 3b 20 75 73 able)))).. ;; us
ba90: 65 20 74 68 65 20 6f 70 65 6e 2d 72 75 6e 2d 63 e the open-run-c
baa0: 6c 6f 73 65 20 69 6e 73 74 65 61 64 20 6f 66 20 lose instead of
bab0: 70 61 73 73 69 6e 67 20 69 6e 20 64 62 0a 09 20 passing in db..
bac0: 28 72 75 6e 73 3a 75 70 64 61 74 65 2d 74 65 73 (runs:update-tes
bad0: 74 5f 6d 65 74 61 20 23 66 20 74 65 73 74 2d 6e t_meta #f test-n
bae0: 61 6d 65 20 74 65 73 74 2d 63 6f 6e 66 29 29 29 ame test-conf)))
baf0: 0a 20 20 20 20 20 74 65 73 74 2d 6e 61 6d 65 73 . test-names
bb00: 29 29 29 0a 0a 3b 3b 20 54 68 69 73 20 63 6f 75 )))..;; This cou
bb10: 6c 64 20 70 72 6f 62 61 62 6c 79 20 62 65 20 72 ld probably be r
bb20: 65 66 61 63 74 6f 72 65 64 20 69 6e 74 6f 20 6f efactored into o
bb30: 6e 65 20 63 6f 6d 70 6c 65 78 20 71 75 65 72 79 ne complex query
bb40: 20 2e 2e 2e 0a 28 64 65 66 69 6e 65 20 28 72 75 ....(define (ru
bb50: 6e 73 3a 72 6f 6c 6c 75 70 2d 72 75 6e 20 6b 65 ns:rollup-run ke
bb60: 79 73 20 6b 65 79 76 61 6c 6c 73 74 20 72 75 6e ys keyvallst run
bb70: 6e 61 6d 65 20 75 73 65 72 29 20 3b 3b 20 77 61 name user) ;; wa
bb80: 73 20 74 61 72 67 65 74 2c 20 6e 6f 77 20 6b 65 s target, now ke
bb90: 79 76 61 6c 6c 73 74 0a 20 20 28 64 65 62 75 67 yvallst. (debug
bba0: 3a 70 72 69 6e 74 20 34 20 22 72 75 6e 73 3a 72 :print 4 "runs:r
bbb0: 6f 6c 6c 75 70 2d 72 75 6e 2c 20 6b 65 79 73 3a ollup-run, keys:
bbc0: 20 22 20 6b 65 79 73 20 22 20 6b 65 79 76 61 6c " keys " keyval
bbd0: 6c 73 74 3a 20 22 20 6b 65 79 76 61 6c 6c 73 74 lst: " keyvallst
bbe0: 20 22 20 3a 72 75 6e 6e 61 6d 65 20 22 20 72 75 " :runname " ru
bbf0: 6e 6e 61 6d 65 20 22 20 75 73 65 72 3a 20 22 20 nname " user: "
bc00: 75 73 65 72 29 0a 20 20 28 6c 65 74 2a 20 28 28 user). (let* ((
bc10: 64 62 20 20 20 20 20 20 20 20 20 20 20 20 20 20 db
bc20: 23 66 29 20 3b 3b 20 28 6b 65 79 76 61 6c 6c 6c #f) ;; (keyvalll
bc30: 73 74 20 20 20 20 20 20 28 6b 65 79 73 3a 74 61 st (keys:ta
bc40: 72 67 65 74 2d 3e 6b 65 79 76 61 6c 20 6b 65 79 rget->keyval key
bc50: 73 20 74 61 72 67 65 74 29 29 0a 09 20 28 6e 65 s target)).. (ne
bc60: 77 2d 72 75 6e 2d 69 64 20 20 20 20 20 20 28 6f w-run-id (o
bc70: 70 65 6e 2d 72 75 6e 2d 63 6c 6f 73 65 20 72 75 pen-run-close ru
bc80: 6e 73 3a 72 65 67 69 73 74 65 72 2d 72 75 6e 20 ns:register-run
bc90: 64 62 20 6b 65 79 73 20 6b 65 79 76 61 6c 6c 73 db keys keyvalls
bca0: 74 20 72 75 6e 6e 61 6d 65 20 22 6e 65 77 22 20 t runname "new"
bcb0: 22 6e 2f 61 22 20 75 73 65 72 29 29 0a 09 20 28 "n/a" user)).. (
bcc0: 70 72 65 76 2d 74 65 73 74 73 20 20 20 20 20 20 prev-tests
bcd0: 28 6f 70 65 6e 2d 72 75 6e 2d 63 6c 6f 73 65 20 (open-run-close
bce0: 74 65 73 74 3a 67 65 74 2d 6d 61 74 63 68 69 6e test:get-matchin
bcf0: 67 2d 70 72 65 76 69 6f 75 73 2d 74 65 73 74 2d g-previous-test-
bd00: 72 75 6e 2d 72 65 63 6f 72 64 73 20 64 62 20 6e run-records db n
bd10: 65 77 2d 72 75 6e 2d 69 64 20 22 25 22 20 22 25 ew-run-id "%" "%
bd20: 22 29 29 0a 09 20 28 63 75 72 72 2d 74 65 73 74 ")).. (curr-test
bd30: 73 20 20 20 20 20 20 28 6f 70 65 6e 2d 72 75 6e s (open-run
bd40: 2d 63 6c 6f 73 65 20 64 62 3a 67 65 74 2d 74 65 -close db:get-te
bd50: 73 74 73 2d 66 6f 72 2d 72 75 6e 20 64 62 20 6e sts-for-run db n
bd60: 65 77 2d 72 75 6e 2d 69 64 20 22 25 2f 25 22 20 ew-run-id "%/%"
bd70: 27 28 29 20 27 28 29 29 29 0a 09 20 28 63 75 72 '() '())).. (cur
bd80: 72 2d 74 65 73 74 73 2d 68 61 73 68 20 28 6d 61 r-tests-hash (ma
bd90: 6b 65 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 29 ke-hash-table)))
bda0: 0a 20 20 20 20 28 6f 70 65 6e 2d 72 75 6e 2d 63 . (open-run-c
bdb0: 6c 6f 73 65 20 64 62 3a 75 70 64 61 74 65 2d 72 lose db:update-r
bdc0: 75 6e 2d 65 76 65 6e 74 5f 74 69 6d 65 20 64 62 un-event_time db
bdd0: 20 6e 65 77 2d 72 75 6e 2d 69 64 29 0a 20 20 20 new-run-id).
bde0: 20 3b 3b 20 69 6e 64 65 78 20 74 68 65 20 61 6c ;; index the al
bdf0: 72 65 61 64 79 20 73 61 76 65 64 20 74 65 73 74 ready saved test
be00: 73 20 62 79 20 74 65 73 74 6e 61 6d 65 20 61 6e s by testname an
be10: 64 20 69 74 65 6d 64 61 74 20 69 6e 20 63 75 72 d itemdat in cur
be20: 72 2d 74 65 73 74 73 2d 68 61 73 68 0a 20 20 20 r-tests-hash.
be30: 20 28 66 6f 72 2d 65 61 63 68 0a 20 20 20 20 20 (for-each.
be40: 28 6c 61 6d 62 64 61 20 28 74 65 73 74 64 61 74 (lambda (testdat
be50: 29 0a 20 20 20 20 20 20 20 28 6c 65 74 2a 20 28 ). (let* (
be60: 28 74 65 73 74 6e 61 6d 65 20 20 28 64 62 3a 74 (testname (db:t
be70: 65 73 74 2d 67 65 74 2d 74 65 73 74 6e 61 6d 65 est-get-testname
be80: 20 74 65 73 74 64 61 74 29 29 0a 09 20 20 20 20 testdat))..
be90: 20 20 28 69 74 65 6d 2d 70 61 74 68 20 28 64 62 (item-path (db
bea0: 3a 74 65 73 74 2d 67 65 74 2d 69 74 65 6d 2d 70 :test-get-item-p
beb0: 61 74 68 20 74 65 73 74 64 61 74 29 29 0a 09 20 ath testdat))..
bec0: 20 20 20 20 20 28 66 75 6c 6c 2d 6e 61 6d 65 20 (full-name
bed0: 28 63 6f 6e 63 20 74 65 73 74 6e 61 6d 65 20 22 (conc testname "
bee0: 2f 22 20 69 74 65 6d 2d 70 61 74 68 29 29 29 0a /" item-path))).
bef0: 09 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 . (hash-table-se
bf00: 74 21 20 63 75 72 72 2d 74 65 73 74 73 2d 68 61 t! curr-tests-ha
bf10: 73 68 20 66 75 6c 6c 2d 6e 61 6d 65 20 74 65 73 sh full-name tes
bf20: 74 64 61 74 29 29 29 0a 20 20 20 20 20 63 75 72 tdat))). cur
bf30: 72 2d 74 65 73 74 73 29 0a 20 20 20 20 3b 3b 20 r-tests). ;;
bf40: 4e 4f 50 45 3a 20 4e 6f 6e 2d 6f 70 74 69 6d 61 NOPE: Non-optima
bf50: 6c 20 61 70 70 72 6f 61 63 68 2e 20 54 72 79 20 l approach. Try
bf60: 74 68 69 73 20 69 6e 73 74 65 61 64 2e 0a 20 20 this instead..
bf70: 20 20 3b 3b 20 20 20 31 2e 20 74 65 73 74 73 20 ;; 1. tests
bf80: 61 72 65 20 72 65 63 65 69 76 65 64 20 69 6e 20 are received in
bf90: 61 20 6c 69 73 74 2c 20 6d 6f 73 74 20 72 65 63 a list, most rec
bfa0: 65 6e 74 20 66 69 72 73 74 0a 20 20 20 20 3b 3b ent first. ;;
bfb0: 20 20 20 32 2e 20 72 65 70 6c 61 63 65 20 74 68 2. replace th
bfc0: 65 20 72 6f 6c 6c 75 70 20 74 65 73 74 20 77 69 e rollup test wi
bfd0: 74 68 20 74 68 65 20 6e 65 77 20 2a 61 6c 77 61 th the new *alwa
bfe0: 79 73 2a 0a 20 20 20 20 28 66 6f 72 2d 65 61 63 ys*. (for-eac
bff0: 68 20 0a 20 20 20 20 20 28 6c 61 6d 62 64 61 20 h . (lambda
c000: 28 74 65 73 74 64 61 74 29 0a 20 20 20 20 20 20 (testdat).
c010: 20 28 6c 65 74 2a 20 28 28 74 65 73 74 6e 61 6d (let* ((testnam
c020: 65 20 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d e (db:test-get-
c030: 74 65 73 74 6e 61 6d 65 20 74 65 73 74 64 61 74 testname testdat
c040: 29 29 0a 09 20 20 20 20 20 20 28 69 74 65 6d 2d )).. (item-
c050: 70 61 74 68 20 28 64 62 3a 74 65 73 74 2d 67 65 path (db:test-ge
c060: 74 2d 69 74 65 6d 2d 70 61 74 68 20 74 65 73 74 t-item-path test
c070: 64 61 74 29 29 0a 09 20 20 20 20 20 20 28 66 75 dat)).. (fu
c080: 6c 6c 2d 6e 61 6d 65 20 28 63 6f 6e 63 20 74 65 ll-name (conc te
c090: 73 74 6e 61 6d 65 20 22 2f 22 20 69 74 65 6d 2d stname "/" item-
c0a0: 70 61 74 68 29 29 0a 09 20 20 20 20 20 20 28 70 path)).. (p
c0b0: 72 65 76 2d 74 65 73 74 2d 64 61 74 20 28 68 61 rev-test-dat (ha
c0c0: 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 sh-table-ref/def
c0d0: 61 75 6c 74 20 63 75 72 72 2d 74 65 73 74 73 2d ault curr-tests-
c0e0: 68 61 73 68 20 66 75 6c 6c 2d 6e 61 6d 65 20 23 hash full-name #
c0f0: 66 29 29 0a 09 20 20 20 20 20 20 28 74 65 73 74 f)).. (test
c100: 2d 73 74 65 70 73 20 20 20 20 20 20 28 6f 70 65 -steps (ope
c110: 6e 2d 72 75 6e 2d 63 6c 6f 73 65 20 64 62 3a 67 n-run-close db:g
c120: 65 74 2d 73 74 65 70 73 2d 66 6f 72 2d 74 65 73 et-steps-for-tes
c130: 74 20 64 62 20 28 64 62 3a 74 65 73 74 2d 67 65 t db (db:test-ge
c140: 74 2d 69 64 20 74 65 73 74 64 61 74 29 29 29 0a t-id testdat))).
c150: 09 20 20 20 20 20 20 28 6e 65 77 2d 74 65 73 74 . (new-test
c160: 2d 72 65 63 6f 72 64 20 23 66 29 29 0a 09 20 3b -record #f)).. ;
c170: 3b 20 72 65 70 6c 61 63 65 20 74 68 65 73 65 20 ; replace these
c180: 77 69 74 68 20 69 6e 73 65 72 74 20 2e 2e 2e 20 with insert ...
c190: 73 65 6c 65 63 74 0a 09 20 28 61 70 70 6c 79 20 select.. (apply
c1a0: 73 71 6c 69 74 65 33 3a 65 78 65 63 75 74 65 20 sqlite3:execute
c1b0: 0a 09 09 64 62 20 0a 09 09 28 63 6f 6e 63 20 22 ...db ...(conc "
c1c0: 49 4e 53 45 52 54 20 4f 52 20 52 45 50 4c 41 43 INSERT OR REPLAC
c1d0: 45 20 49 4e 54 4f 20 74 65 73 74 73 20 28 72 75 E INTO tests (ru
c1e0: 6e 5f 69 64 2c 74 65 73 74 6e 61 6d 65 2c 73 74 n_id,testname,st
c1f0: 61 74 65 2c 73 74 61 74 75 73 2c 65 76 65 6e 74 ate,status,event
c200: 5f 74 69 6d 65 2c 68 6f 73 74 2c 63 70 75 6c 6f _time,host,cpulo
c210: 61 64 2c 64 69 73 6b 66 72 65 65 2c 75 6e 61 6d ad,diskfree,unam
c220: 65 2c 72 75 6e 64 69 72 2c 69 74 65 6d 5f 70 61 e,rundir,item_pa
c230: 74 68 2c 72 75 6e 5f 64 75 72 61 74 69 6f 6e 2c th,run_duration,
c240: 66 69 6e 61 6c 5f 6c 6f 67 66 2c 63 6f 6d 6d 65 final_logf,comme
c250: 6e 74 29 20 22 0a 09 09 20 20 20 20 20 20 22 56 nt) "... "V
c260: 41 4c 55 45 53 20 28 3f 2c 3f 2c 3f 2c 3f 2c 3f ALUES (?,?,?,?,?
c270: 2c 3f 2c 3f 2c 3f 2c 3f 2c 3f 2c 3f 2c 3f 2c 3f ,?,?,?,?,?,?,?,?
c280: 2c 3f 29 3b 22 29 0a 09 09 6e 65 77 2d 72 75 6e ,?);")...new-run
c290: 2d 69 64 20 28 63 64 64 72 20 28 76 65 63 74 6f -id (cddr (vecto
c2a0: 72 2d 3e 6c 69 73 74 20 74 65 73 74 64 61 74 29 r->list testdat)
c2b0: 29 29 0a 09 20 28 73 65 74 21 20 6e 65 77 2d 74 )).. (set! new-t
c2c0: 65 73 74 64 61 74 20 28 63 61 72 20 28 6f 70 65 estdat (car (ope
c2d0: 6e 2d 72 75 6e 2d 63 6c 6f 73 65 20 64 62 3a 67 n-run-close db:g
c2e0: 65 74 2d 74 65 73 74 73 2d 66 6f 72 2d 72 75 6e et-tests-for-run
c2f0: 20 64 62 20 6e 65 77 2d 72 75 6e 2d 69 64 20 28 db new-run-id (
c300: 63 6f 6e 63 20 74 65 73 74 6e 61 6d 65 20 22 2f conc testname "/
c310: 22 20 69 74 65 6d 2d 70 61 74 68 29 20 27 28 29 " item-path) '()
c320: 20 27 28 29 29 29 29 0a 09 20 28 68 61 73 68 2d '()))).. (hash-
c330: 74 61 62 6c 65 2d 73 65 74 21 20 63 75 72 72 2d table-set! curr-
c340: 74 65 73 74 73 2d 68 61 73 68 20 66 75 6c 6c 2d tests-hash full-
c350: 6e 61 6d 65 20 6e 65 77 2d 74 65 73 74 64 61 74 name new-testdat
c360: 29 20 3b 3b 20 74 68 69 73 20 63 6f 75 6c 64 20 ) ;; this could
c370: 62 65 20 63 6f 6e 66 75 73 69 6e 67 2c 20 77 68 be confusing, wh
c380: 69 63 68 20 72 65 63 6f 72 64 20 73 68 6f 75 6c ich record shoul
c390: 64 20 67 6f 20 69 6e 74 6f 20 74 68 65 20 6c 6f d go into the lo
c3a0: 6f 6b 75 70 20 74 61 62 6c 65 3f 0a 09 20 3b 3b okup table?.. ;;
c3b0: 20 4e 6f 77 20 64 75 70 6c 69 63 61 74 65 20 74 Now duplicate t
c3c0: 68 65 20 74 65 73 74 20 73 74 65 70 73 0a 09 20 he test steps..
c3d0: 28 64 65 62 75 67 3a 70 72 69 6e 74 20 34 20 22 (debug:print 4 "
c3e0: 43 6f 70 79 69 6e 67 20 72 65 63 6f 72 64 73 20 Copying records
c3f0: 69 6e 20 74 65 73 74 5f 73 74 65 70 73 20 66 72 in test_steps fr
c400: 6f 6d 20 74 65 73 74 5f 69 64 3d 22 20 28 64 62 om test_id=" (db
c410: 3a 74 65 73 74 2d 67 65 74 2d 69 64 20 74 65 73 :test-get-id tes
c420: 74 64 61 74 29 20 22 20 74 6f 20 22 20 28 64 62 tdat) " to " (db
c430: 3a 74 65 73 74 2d 67 65 74 2d 69 64 20 6e 65 77 :test-get-id new
c440: 2d 74 65 73 74 64 61 74 29 29 0a 09 20 28 6f 70 -testdat)).. (op
c450: 65 6e 2d 72 75 6e 2d 63 6c 6f 73 65 20 0a 09 20 en-run-close ..
c460: 20 28 6c 61 6d 62 64 61 20 28 29 0a 09 20 20 20 (lambda ()..
c470: 20 28 73 71 6c 69 74 65 33 3a 65 78 65 63 75 74 (sqlite3:execut
c480: 65 20 0a 09 20 20 20 20 20 64 62 20 0a 09 20 20 e .. db ..
c490: 20 20 20 28 63 6f 6e 63 20 22 49 4e 53 45 52 54 (conc "INSERT
c4a0: 20 4f 52 20 52 45 50 4c 41 43 45 20 49 4e 54 4f OR REPLACE INTO
c4b0: 20 74 65 73 74 5f 73 74 65 70 73 20 28 74 65 73 test_steps (tes
c4c0: 74 5f 69 64 2c 73 74 65 70 6e 61 6d 65 2c 73 74 t_id,stepname,st
c4d0: 61 74 65 2c 73 74 61 74 75 73 2c 65 76 65 6e 74 ate,status,event
c4e0: 5f 74 69 6d 65 2c 63 6f 6d 6d 65 6e 74 29 20 22 _time,comment) "
c4f0: 0a 09 09 20 20 20 22 53 45 4c 45 43 54 20 22 20 ... "SELECT "
c500: 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 69 64 20 (db:test-get-id
c510: 6e 65 77 2d 74 65 73 74 64 61 74 29 20 22 2c 73 new-testdat) ",s
c520: 74 65 70 6e 61 6d 65 2c 73 74 61 74 65 2c 73 74 tepname,state,st
c530: 61 74 75 73 2c 65 76 65 6e 74 5f 74 69 6d 65 2c atus,event_time,
c540: 63 6f 6d 6d 65 6e 74 20 46 52 4f 4d 20 74 65 73 comment FROM tes
c550: 74 5f 73 74 65 70 73 20 57 48 45 52 45 20 74 65 t_steps WHERE te
c560: 73 74 5f 69 64 3d 3f 3b 22 29 0a 09 20 20 20 20 st_id=?;")..
c570: 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 69 64 (db:test-get-id
c580: 20 74 65 73 74 64 61 74 29 29 0a 09 20 20 20 20 testdat))..
c590: 3b 3b 20 4e 6f 77 20 64 75 70 6c 69 63 61 74 65 ;; Now duplicate
c5a0: 20 74 68 65 20 74 65 73 74 20 64 61 74 61 0a 09 the test data..
c5b0: 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 (debug:print
c5c0: 20 34 20 22 43 6f 70 79 69 6e 67 20 72 65 63 6f 4 "Copying reco
c5d0: 72 64 73 20 69 6e 20 74 65 73 74 5f 64 61 74 61 rds in test_data
c5e0: 20 66 72 6f 6d 20 74 65 73 74 5f 69 64 3d 22 20 from test_id="
c5f0: 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 69 64 20 (db:test-get-id
c600: 74 65 73 74 64 61 74 29 20 22 20 74 6f 20 22 20 testdat) " to "
c610: 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 69 64 20 (db:test-get-id
c620: 6e 65 77 2d 74 65 73 74 64 61 74 29 29 0a 09 20 new-testdat))..
c630: 20 20 20 28 73 71 6c 69 74 65 33 3a 65 78 65 63 (sqlite3:exec
c640: 75 74 65 20 0a 09 20 20 20 20 20 64 62 20 0a 09 ute .. db ..
c650: 20 20 20 20 20 28 63 6f 6e 63 20 22 49 4e 53 45 (conc "INSE
c660: 52 54 20 4f 52 20 52 45 50 4c 41 43 45 20 49 4e RT OR REPLACE IN
c670: 54 4f 20 74 65 73 74 5f 64 61 74 61 20 28 74 65 TO test_data (te
c680: 73 74 5f 69 64 2c 63 61 74 65 67 6f 72 79 2c 76 st_id,category,v
c690: 61 72 69 61 62 6c 65 2c 76 61 6c 75 65 2c 65 78 ariable,value,ex
c6a0: 70 65 63 74 65 64 2c 74 6f 6c 2c 75 6e 69 74 73 pected,tol,units
c6b0: 2c 63 6f 6d 6d 65 6e 74 29 20 22 0a 09 09 20 20 ,comment) "...
c6c0: 20 22 53 45 4c 45 43 54 20 22 20 28 64 62 3a 74 "SELECT " (db:t
c6d0: 65 73 74 2d 67 65 74 2d 69 64 20 6e 65 77 2d 74 est-get-id new-t
c6e0: 65 73 74 64 61 74 29 20 22 2c 63 61 74 65 67 6f estdat) ",catego
c6f0: 72 79 2c 76 61 72 69 61 62 6c 65 2c 76 61 6c 75 ry,variable,valu
c700: 65 2c 65 78 70 65 63 74 65 64 2c 74 6f 6c 2c 75 e,expected,tol,u
c710: 6e 69 74 73 2c 63 6f 6d 6d 65 6e 74 20 46 52 4f nits,comment FRO
c720: 4d 20 74 65 73 74 5f 64 61 74 61 20 57 48 45 52 M test_data WHER
c730: 45 20 74 65 73 74 5f 69 64 3d 3f 3b 22 29 0a 09 E test_id=?;")..
c740: 20 20 20 20 20 28 64 62 3a 74 65 73 74 2d 67 65 (db:test-ge
c750: 74 2d 69 64 20 74 65 73 74 64 61 74 29 29 29 29 t-id testdat))))
c760: 0a 09 20 29 29 0a 20 20 20 20 20 70 72 65 76 2d .. )). prev-
c770: 74 65 73 74 73 29 29 29 0a 09 20 0a 20 20 20 20 tests))).. .
c780: 20 0a .