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 29 29 tests-delay* 1))
14a0: 0a 09 28 62 65 67 69 6e 0a 09 20 20 28 73 65 74 ..(begin.. (set
14b0: 21 20 2a 72 75 6e 73 3a 63 61 6e 2d 72 75 6e 2d ! *runs:can-run-
14c0: 6d 6f 72 65 2d 74 65 73 74 73 2d 64 65 6c 61 79 more-tests-delay
14d0: 2a 20 28 2b 20 2a 72 75 6e 73 3a 63 61 6e 2d 72 * (+ *runs:can-r
14e0: 75 6e 2d 6d 6f 72 65 2d 74 65 73 74 73 2d 64 65 un-more-tests-de
14f0: 6c 61 79 2a 20 30 2e 30 30 39 29 29 0a 09 20 20 lay* 0.009))..
1500: 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 (debug:print-inf
1510: 6f 20 31 34 20 22 63 61 6e 2d 72 75 6e 2d 6d 6f o 14 "can-run-mo
1520: 72 65 2d 74 65 73 74 73 2d 64 65 6c 61 79 3a 20 re-tests-delay:
1530: 22 20 2a 72 75 6e 73 3a 63 61 6e 2d 72 75 6e 2d " *runs:can-run-
1540: 6d 6f 72 65 2d 74 65 73 74 73 2d 64 65 6c 61 79 more-tests-delay
1550: 2a 29 29 29 0a 20 20 20 20 28 69 66 20 28 6e 6f *))). (if (no
1560: 74 20 28 65 71 3f 20 2a 6c 61 73 74 2d 6e 75 6d t (eq? *last-num
1570: 2d 72 75 6e 6e 69 6e 67 2d 74 65 73 74 73 2a 20 -running-tests*
1580: 6e 75 6d 2d 72 75 6e 6e 69 6e 67 29 29 0a 09 28 num-running))..(
1590: 62 65 67 69 6e 0a 09 20 20 28 64 65 62 75 67 3a begin.. (debug:
15a0: 70 72 69 6e 74 20 32 20 22 6d 61 78 2d 63 6f 6e print 2 "max-con
15b0: 63 75 72 72 65 6e 74 2d 6a 6f 62 73 3a 20 22 20 current-jobs: "
15c0: 6d 61 78 2d 63 6f 6e 63 75 72 72 65 6e 74 2d 6a max-concurrent-j
15d0: 6f 62 73 20 22 2c 20 6e 75 6d 2d 72 75 6e 6e 69 obs ", num-runni
15e0: 6e 67 3a 20 22 20 6e 75 6d 2d 72 75 6e 6e 69 6e ng: " num-runnin
15f0: 67 29 0a 09 20 20 28 73 65 74 21 20 2a 6c 61 73 g).. (set! *las
1600: 74 2d 6e 75 6d 2d 72 75 6e 6e 69 6e 67 2d 74 65 t-num-running-te
1610: 73 74 73 2a 20 6e 75 6d 2d 72 75 6e 6e 69 6e 67 sts* num-running
1620: 29 29 29 0a 20 20 20 20 28 69 66 20 28 6e 6f 74 ))). (if (not
1630: 20 28 65 71 3f 20 30 20 2a 67 6c 6f 62 61 6c 65 (eq? 0 *globale
1640: 78 69 74 73 74 61 74 75 73 2a 29 29 0a 09 28 6c xitstatus*))..(l
1650: 69 73 74 20 23 66 20 6e 75 6d 2d 72 75 6e 6e 69 ist #f num-runni
1660: 6e 67 20 6e 75 6d 2d 72 75 6e 6e 69 6e 67 2d 69 ng num-running-i
1670: 6e 2d 6a 6f 62 67 72 6f 75 70 20 6d 61 78 2d 63 n-jobgroup max-c
1680: 6f 6e 63 75 72 72 65 6e 74 2d 6a 6f 62 73 20 6a oncurrent-jobs j
1690: 6f 62 2d 67 72 6f 75 70 2d 6c 69 6d 69 74 29 0a ob-group-limit).
16a0: 09 28 6c 65 74 20 28 28 63 61 6e 2d 6e 6f 74 2d .(let ((can-not-
16b0: 72 75 6e 2d 6d 6f 72 65 20 28 63 6f 6e 64 0a 09 run-more (cond..
16c0: 09 09 09 20 3b 3b 20 69 66 20 6d 61 78 2d 63 6f ... ;; if max-co
16d0: 6e 63 75 72 72 65 6e 74 2d 6a 6f 62 73 20 69 73 ncurrent-jobs is
16e0: 20 73 65 74 20 61 6e 64 20 74 68 65 20 6e 75 6d set and the num
16f0: 62 65 72 20 72 75 6e 6e 69 6e 67 20 69 73 20 67 ber running is g
1700: 72 65 61 74 65 72 20 0a 09 09 09 09 20 3b 3b 20 reater ..... ;;
1710: 74 68 61 6e 20 69 74 20 74 68 61 6e 20 63 61 6e than it than can
1720: 6e 6f 74 20 72 75 6e 20 6d 6f 72 65 20 6a 6f 62 not run more job
1730: 73 0a 09 09 09 09 20 28 28 61 6e 64 20 6d 61 78 s..... ((and max
1740: 2d 63 6f 6e 63 75 72 72 65 6e 74 2d 6a 6f 62 73 -concurrent-jobs
1750: 20 28 3e 3d 20 6e 75 6d 2d 72 75 6e 6e 69 6e 67 (>= num-running
1760: 20 6d 61 78 2d 63 6f 6e 63 75 72 72 65 6e 74 2d max-concurrent-
1770: 6a 6f 62 73 29 29 0a 09 09 09 09 20 20 28 64 65 jobs))..... (de
1780: 62 75 67 3a 70 72 69 6e 74 20 30 20 22 57 41 52 bug:print 0 "WAR
1790: 4e 49 4e 47 3a 20 4d 61 78 20 72 75 6e 6e 69 6e NING: Max runnin
17a0: 67 20 6a 6f 62 73 20 65 78 63 65 65 64 65 64 2c g jobs exceeded,
17b0: 20 63 75 72 72 65 6e 74 20 6e 75 6d 62 65 72 20 current number
17c0: 72 75 6e 6e 69 6e 67 3a 20 22 20 6e 75 6d 2d 72 running: " num-r
17d0: 75 6e 6e 69 6e 67 20 0a 09 09 09 09 09 20 20 20 unning ......
17e0: 20 20 20 20 22 2c 20 6d 61 78 5f 63 6f 6e 63 75 ", max_concu
17f0: 72 72 65 6e 74 5f 6a 6f 62 73 3a 20 22 20 6d 61 rrent_jobs: " ma
1800: 78 2d 63 6f 6e 63 75 72 72 65 6e 74 2d 6a 6f 62 x-concurrent-job
1810: 73 29 0a 09 09 09 09 20 20 23 74 29 0a 09 09 09 s)..... #t)....
1820: 09 20 3b 3b 20 69 66 20 6a 6f 62 2d 67 72 6f 75 . ;; if job-grou
1830: 70 2d 6c 69 6d 69 74 20 69 73 20 73 65 74 20 61 p-limit is set a
1840: 6e 64 20 6e 75 6d 62 65 72 20 6f 66 20 6a 6f 62 nd number of job
1850: 73 20 69 6e 20 74 68 65 20 67 72 6f 75 70 20 69 s in the group i
1860: 73 20 67 72 65 61 74 65 72 0a 09 09 09 09 20 3b s greater..... ;
1870: 3b 20 74 68 61 6e 20 74 68 65 20 6c 69 6d 69 74 ; than the limit
1880: 20 74 68 65 6e 20 63 61 6e 6e 6f 74 20 72 75 6e then cannot run
1890: 20 6d 6f 72 65 20 6a 6f 62 73 20 6f 66 20 74 68 more jobs of th
18a0: 69 73 20 6b 69 6e 64 0a 09 09 09 09 20 28 28 61 is kind..... ((a
18b0: 6e 64 20 6a 6f 62 2d 67 72 6f 75 70 2d 6c 69 6d nd job-group-lim
18c0: 69 74 0a 09 09 09 09 20 20 20 20 20 20 20 28 3e it..... (>
18d0: 3d 20 6e 75 6d 2d 72 75 6e 6e 69 6e 67 2d 69 6e = num-running-in
18e0: 2d 6a 6f 62 67 72 6f 75 70 20 6a 6f 62 2d 67 72 -jobgroup job-gr
18f0: 6f 75 70 2d 6c 69 6d 69 74 29 29 0a 09 09 09 09 oup-limit)).....
1900: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 31 (debug:print 1
1910: 20 22 57 41 52 4e 49 4e 47 3a 20 6e 75 6d 62 65 "WARNING: numbe
1920: 72 20 6f 66 20 6a 6f 62 73 20 22 20 6e 75 6d 2d r of jobs " num-
1930: 72 75 6e 6e 69 6e 67 2d 69 6e 2d 6a 6f 62 67 72 running-in-jobgr
1940: 6f 75 70 20 0a 09 09 09 09 09 20 20 20 20 20 20 oup ......
1950: 20 22 20 69 6e 20 22 20 6a 6f 62 67 72 6f 75 70 " in " jobgroup
1960: 20 22 20 65 78 63 65 65 64 65 64 2c 20 77 69 6c " exceeded, wil
1970: 6c 20 6e 6f 74 20 72 75 6e 20 22 20 28 74 65 73 l not run " (tes
1980: 74 73 3a 74 65 73 74 71 75 65 75 65 2d 67 65 74 ts:testqueue-get
1990: 2d 74 65 73 74 6e 61 6d 65 20 74 65 73 74 2d 72 -testname test-r
19a0: 65 63 6f 72 64 29 29 0a 09 09 09 09 20 20 23 74 ecord))..... #t
19b0: 29 0a 09 09 09 09 20 28 65 6c 73 65 20 23 66 29 )..... (else #f)
19c0: 29 29 29 0a 09 20 20 28 6c 69 73 74 20 28 6e 6f ))).. (list (no
19d0: 74 20 63 61 6e 2d 6e 6f 74 2d 72 75 6e 2d 6d 6f t can-not-run-mo
19e0: 72 65 29 20 6e 75 6d 2d 72 75 6e 6e 69 6e 67 20 re) num-running
19f0: 6e 75 6d 2d 72 75 6e 6e 69 6e 67 2d 69 6e 2d 6a num-running-in-j
1a00: 6f 62 67 72 6f 75 70 20 6d 61 78 2d 63 6f 6e 63 obgroup max-conc
1a10: 75 72 72 65 6e 74 2d 6a 6f 62 73 20 6a 6f 62 2d urrent-jobs job-
1a20: 67 72 6f 75 70 2d 6c 69 6d 69 74 29 29 29 29 29 group-limit)))))
1a30: 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ..;;============
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 0a 3b 3b 20 4e 65 ==========.;; Ne
1a80: 77 20 6d 65 74 68 6f 64 6f 6c 6f 67 79 2e 20 54 w methodology. T
1a90: 68 65 73 65 20 72 6f 75 74 69 6e 65 73 20 77 69 hese routines wi
1aa0: 6c 6c 20 72 65 70 6c 61 63 65 20 74 68 65 20 61 ll replace the a
1ab0: 62 6f 76 65 20 69 6e 20 74 69 6d 65 2e 20 46 6f bove in time. Fo
1ac0: 72 0a 3b 3b 20 6e 6f 77 20 74 68 65 20 63 6f 64 r.;; now the cod
1ad0: 65 20 69 73 20 64 75 70 6c 69 63 61 74 65 64 2e e is duplicated.
1ae0: 20 54 68 69 73 20 73 74 75 66 66 20 69 73 20 69 This stuff is i
1af0: 6e 69 74 69 61 6c 6c 79 20 75 73 65 64 20 69 6e nitially used in
1b00: 20 74 68 65 20 6d 6f 6e 69 74 6f 72 0a 3b 3b 20 the monitor.;;
1b10: 62 61 73 65 64 20 63 6f 64 65 2e 0a 3b 3b 3d 3d based code..;;==
1b20: 3d 3d 3d 3d 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 0a 0a 0a 3b 3b 20 54 68 69 73 20 69 ====...;; This i
1b70: 73 20 61 20 64 75 70 6c 69 63 61 74 65 20 6f 66 s a duplicate of
1b80: 20 72 75 6e 2d 74 65 73 74 73 20 28 77 68 69 63 run-tests (whic
1b90: 68 20 68 61 73 20 62 65 65 6e 20 64 65 70 72 65 h has been depre
1ba0: 63 61 74 65 64 29 2e 20 55 73 65 20 74 68 69 73 cated). Use this
1bb0: 20 6f 6e 65 20 69 6e 73 74 65 61 64 20 6f 66 20 one instead of
1bc0: 72 75 6e 20 74 65 73 74 73 2e 0a 3b 3b 20 6b 65 run tests..;; ke
1bd0: 79 76 61 6c 73 2e 0a 3b 3b 0a 3b 3b 20 20 74 65 yvals..;;.;; te
1be0: 73 74 2d 6e 61 6d 65 73 3a 20 43 6f 6d 6d 61 20 st-names: Comma
1bf0: 73 65 70 61 72 61 74 65 64 20 70 61 74 74 65 72 separated patter
1c00: 6e 73 20 73 61 6d 65 20 61 73 20 74 65 73 74 2d ns same as test-
1c10: 70 61 74 74 73 20 62 75 74 20 75 73 65 64 20 69 patts but used i
1c20: 6e 20 73 65 6c 65 63 74 69 6f 6e 20 0a 3b 3b 20 n selection .;;
1c30: 20 20 20 20 20 20 20 20 20 20 20 20 20 6f 66 20 of
1c40: 74 65 73 74 73 20 74 6f 20 72 75 6e 2e 20 54 68 tests to run. Th
1c50: 65 20 69 74 65 6d 20 70 6f 72 74 69 6f 6e 73 20 e item portions
1c60: 61 72 65 20 6e 6f 74 20 72 65 73 70 65 63 74 65 are not respecte
1c70: 64 2e 0a 3b 3b 20 20 20 20 20 20 20 20 20 20 20 d..;;
1c80: 20 20 20 46 49 58 4d 45 3a 20 65 72 72 6f 72 20 FIXME: error
1c90: 6f 75 74 20 69 66 20 2f 70 61 74 74 20 73 70 65 out if /patt spe
1ca0: 63 69 66 69 65 64 0a 3b 3b 20 20 20 20 20 20 20 cified.;;
1cb0: 20 20 20 20 20 0a 28 64 65 66 69 6e 65 20 28 72 .(define (r
1cc0: 75 6e 73 3a 72 75 6e 2d 74 65 73 74 73 20 74 61 uns:run-tests ta
1cd0: 72 67 65 74 20 72 75 6e 6e 61 6d 65 20 74 65 73 rget runname tes
1ce0: 74 2d 6e 61 6d 65 73 20 74 65 73 74 2d 70 61 74 t-names test-pat
1cf0: 74 73 20 75 73 65 72 20 66 6c 61 67 73 29 0a 20 ts user flags).
1d00: 20 28 63 6f 6d 6d 6f 6e 3a 63 6c 65 61 72 2d 63 (common:clear-c
1d10: 61 63 68 65 73 29 20 3b 3b 20 63 6c 65 61 72 20 aches) ;; clear
1d20: 61 6c 6c 20 63 61 63 68 65 73 0a 20 20 28 6c 65 all caches. (le
1d30: 74 2a 20 28 28 64 62 20 20 20 20 20 20 20 20 20 t* ((db
1d40: 20 23 66 29 0a 09 20 28 6b 65 79 73 20 20 20 20 #f).. (keys
1d50: 20 20 20 20 28 63 64 62 3a 72 65 6d 6f 74 65 2d (cdb:remote-
1d60: 72 75 6e 20 64 62 3a 67 65 74 2d 6b 65 79 73 20 run db:get-keys
1d70: 23 66 29 29 0a 09 20 28 6b 65 79 76 61 6c 6c 73 #f)).. (keyvalls
1d80: 74 20 20 20 28 6b 65 79 73 3a 74 61 72 67 65 74 t (keys:target
1d90: 2d 3e 6b 65 79 76 61 6c 20 6b 65 79 73 20 74 61 ->keyval keys ta
1da0: 72 67 65 74 29 29 0a 09 20 28 72 75 6e 2d 69 64 rget)).. (run-id
1db0: 20 20 20 20 20 20 28 63 64 62 3a 72 65 6d 6f 74 (cdb:remot
1dc0: 65 2d 72 75 6e 20 64 62 3a 72 65 67 69 73 74 65 e-run db:registe
1dd0: 72 2d 72 75 6e 20 23 66 20 6b 65 79 73 20 6b 65 r-run #f keys ke
1de0: 79 76 61 6c 6c 73 74 20 72 75 6e 6e 61 6d 65 20 yvallst runname
1df0: 22 6e 65 77 22 20 22 6e 2f 61 22 20 75 73 65 72 "new" "n/a" user
1e00: 29 29 20 20 3b 3b 20 20 74 65 73 74 2d 6e 61 6d )) ;; test-nam
1e10: 65 29 29 29 0a 09 20 28 6b 65 79 76 61 6c 73 20 e))).. (keyvals
1e20: 20 20 20 20 28 69 66 20 72 75 6e 2d 69 64 20 28 (if run-id (
1e30: 63 64 62 3a 72 65 6d 6f 74 65 2d 72 75 6e 20 64 cdb:remote-run d
1e40: 62 3a 67 65 74 2d 6b 65 79 2d 76 61 6c 73 20 23 b:get-key-vals #
1e50: 66 20 72 75 6e 2d 69 64 29 20 23 66 29 29 0a 09 f run-id) #f))..
1e60: 20 28 64 65 66 65 72 72 65 64 20 20 20 20 27 28 (deferred '(
1e70: 29 29 20 3b 3b 20 64 65 6c 61 79 20 72 75 6e 6e )) ;; delay runn
1e80: 69 6e 67 20 74 68 65 73 65 20 73 69 6e 63 65 20 ing these since
1e90: 74 68 65 79 20 68 61 76 65 20 61 20 77 61 69 74 they have a wait
1ea0: 6f 6e 20 63 6c 61 75 73 65 0a 09 20 3b 3b 20 6b on clause.. ;; k
1eb0: 65 65 70 67 6f 69 6e 67 20 69 73 20 74 68 65 20 eepgoing is the
1ec0: 64 65 66 61 63 74 6f 20 6d 6f 64 61 6c 69 74 79 defacto modality
1ed0: 20 6e 6f 77 2c 20 77 69 6c 6c 20 61 64 64 20 68 now, will add h
1ee0: 69 74 2d 6e 2d 72 75 6e 20 61 20 62 69 74 20 6c it-n-run a bit l
1ef0: 61 74 65 72 0a 09 20 3b 3b 20 28 6b 65 65 70 67 ater.. ;; (keepg
1f00: 6f 69 6e 67 20 20 20 28 68 61 73 68 2d 74 61 62 oing (hash-tab
1f10: 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 66 le-ref/default f
1f20: 6c 61 67 73 20 22 2d 6b 65 65 70 67 6f 69 6e 67 lags "-keepgoing
1f30: 22 20 23 66 29 29 0a 09 20 28 72 75 6e 63 6f 6e " #f)).. (runcon
1f40: 66 69 67 66 20 20 20 28 63 6f 6e 63 20 20 2a 74 figf (conc *t
1f50: 6f 70 70 61 74 68 2a 20 22 2f 72 75 6e 63 6f 6e oppath* "/runcon
1f60: 66 69 67 73 2e 63 6f 6e 66 69 67 22 29 29 0a 09 figs.config"))..
1f70: 20 28 72 65 71 75 69 72 65 64 2d 74 65 73 74 73 (required-tests
1f80: 20 27 28 29 29 0a 09 20 28 74 65 73 74 2d 72 65 '()).. (test-re
1f90: 63 6f 72 64 73 20 28 6d 61 6b 65 2d 68 61 73 68 cords (make-hash
1fa0: 2d 74 61 62 6c 65 29 29 29 0a 0a 20 20 20 20 28 -table))).. (
1fb0: 73 65 74 2d 6d 65 67 61 74 65 73 74 2d 65 6e 76 set-megatest-env
1fc0: 2d 76 61 72 73 20 72 75 6e 2d 69 64 29 20 3b 3b -vars run-id) ;;
1fd0: 20 74 68 65 73 65 20 6d 61 79 20 62 65 20 6e 65 these may be ne
1fe0: 65 64 65 64 20 62 79 20 74 68 65 20 6c 61 75 6e eded by the laun
1ff0: 63 68 69 6e 67 20 70 72 6f 63 65 73 73 0a 0a 20 ching process..
2000: 20 20 20 28 69 66 20 28 66 69 6c 65 2d 65 78 69 (if (file-exi
2010: 73 74 73 3f 20 72 75 6e 63 6f 6e 66 69 67 66 29 sts? runconfigf)
2020: 0a 09 28 73 65 74 75 70 2d 65 6e 76 2d 64 65 66 ..(setup-env-def
2030: 61 75 6c 74 73 20 72 75 6e 63 6f 6e 66 69 67 66 aults runconfigf
2040: 20 72 75 6e 2d 69 64 20 2a 61 6c 72 65 61 64 79 run-id *already
2050: 2d 73 65 65 6e 2d 72 75 6e 63 6f 6e 66 69 67 2d -seen-runconfig-
2060: 69 6e 66 6f 2a 20 6b 65 79 73 20 6b 65 79 76 61 info* keys keyva
2070: 6c 73 20 22 70 72 65 2d 6c 61 75 6e 63 68 2d 65 ls "pre-launch-e
2080: 6e 76 2d 76 61 72 73 22 29 0a 09 28 64 65 62 75 nv-vars")..(debu
2090: 67 3a 70 72 69 6e 74 20 30 20 22 57 41 52 4e 49 g:print 0 "WARNI
20a0: 4e 47 3a 20 59 6f 75 20 64 6f 20 6e 6f 74 20 68 NG: You do not h
20b0: 61 76 65 20 61 20 72 75 6e 20 63 6f 6e 66 69 67 ave a run config
20c0: 20 66 69 6c 65 3a 20 22 20 72 75 6e 63 6f 6e 66 file: " runconf
20d0: 69 67 66 29 29 0a 20 20 20 20 0a 20 20 20 20 3b igf)). . ;
20e0: 3b 20 6c 6f 6f 6b 20 75 70 20 61 6c 6c 20 74 65 ; look up all te
20f0: 73 74 73 20 6d 61 74 63 68 69 6e 67 20 74 68 65 sts matching the
2100: 20 63 6f 6d 6d 61 20 73 65 70 61 72 61 74 65 64 comma separated
2110: 20 6c 69 73 74 20 6f 66 20 67 6c 6f 62 73 20 69 list of globs i
2120: 6e 0a 20 20 20 20 3b 3b 20 74 65 73 74 2d 70 61 n. ;; test-pa
2130: 74 74 73 20 28 75 73 69 6e 67 20 25 20 61 73 20 tts (using % as
2140: 77 69 6c 64 63 61 72 64 29 0a 0a 20 20 20 20 28 wildcard).. (
2150: 73 65 74 21 20 74 65 73 74 2d 6e 61 6d 65 73 20 set! test-names
2160: 28 74 65 73 74 73 3a 67 65 74 2d 76 61 6c 69 64 (tests:get-valid
2170: 2d 74 65 73 74 73 20 2a 74 6f 70 70 61 74 68 2a -tests *toppath*
2180: 20 74 65 73 74 2d 6e 61 6d 65 73 29 29 0a 20 20 test-names)).
2190: 20 20 28 73 65 74 21 20 74 65 73 74 2d 6e 61 6d (set! test-nam
21a0: 65 73 20 28 64 65 6c 65 74 65 2d 64 75 70 6c 69 es (delete-dupli
21b0: 63 61 74 65 73 20 74 65 73 74 2d 6e 61 6d 65 73 cates test-names
21c0: 29 29 0a 0a 20 20 20 20 28 64 65 62 75 67 3a 70 )).. (debug:p
21d0: 72 69 6e 74 2d 69 6e 66 6f 20 30 20 22 74 65 73 rint-info 0 "tes
21e0: 74 20 6e 61 6d 65 73 20 22 20 74 65 73 74 2d 6e t names " test-n
21f0: 61 6d 65 73 29 0a 0a 20 20 20 20 3b 3b 20 6f 6e ames).. ;; on
2200: 20 74 68 65 20 66 69 72 73 74 20 70 61 73 73 20 the first pass
2210: 6f 72 20 63 61 6c 6c 20 74 6f 20 72 75 6e 2d 74 or call to run-t
2220: 65 73 74 73 20 73 65 74 20 46 41 49 4c 53 20 74 ests set FAILS t
2230: 6f 20 4e 4f 54 5f 53 54 41 52 54 45 44 20 69 66 o NOT_STARTED if
2240: 0a 20 20 20 20 3b 3b 20 2d 6b 65 65 70 67 6f 69 . ;; -keepgoi
2250: 6e 67 20 69 73 20 73 70 65 63 69 66 69 65 64 0a ng is specified.
2260: 20 20 20 20 28 69 66 20 28 65 71 3f 20 2a 70 61 (if (eq? *pa
2270: 73 73 6e 75 6d 2a 20 30 29 0a 09 28 62 65 67 69 ssnum* 0)..(begi
2280: 6e 0a 09 20 20 3b 3b 20 68 61 76 65 20 74 6f 20 n.. ;; have to
2290: 64 65 6c 65 74 65 20 74 65 73 74 20 72 65 63 6f delete test reco
22a0: 72 64 73 20 77 68 65 72 65 20 4e 4f 54 5f 53 54 rds where NOT_ST
22b0: 41 52 54 45 44 20 73 69 6e 63 65 20 74 68 65 79 ARTED since they
22c0: 20 63 61 6e 20 63 61 75 73 65 20 2d 6b 65 65 70 can cause -keep
22d0: 67 6f 69 6e 67 20 74 6f 20 0a 09 20 20 3b 3b 20 going to .. ;;
22e0: 67 65 74 20 73 74 75 63 6b 20 64 75 65 20 74 6f get stuck due to
22f0: 20 62 65 63 6f 6d 69 6e 67 20 69 6e 61 63 63 65 becoming inacce
2300: 73 73 69 62 6c 65 20 66 72 6f 6d 20 61 20 66 61 ssible from a fa
2310: 69 6c 65 64 20 74 65 73 74 2e 20 49 2e 65 2e 20 iled test. I.e.
2320: 69 66 20 74 65 73 74 20 42 20 64 65 70 65 6e 64 if test B depend
2330: 73 20 0a 09 20 20 3b 3b 20 6f 6e 20 74 65 73 74 s .. ;; on test
2340: 20 41 20 62 75 74 20 74 65 73 74 20 42 20 72 65 A but test B re
2350: 61 63 68 65 64 20 74 68 65 20 70 6f 69 6e 74 20 ached the point
2360: 6f 6e 20 62 65 69 6e 67 20 72 65 67 69 73 74 65 on being registe
2370: 72 65 64 20 61 73 20 4e 4f 54 5f 53 54 41 52 54 red as NOT_START
2380: 45 44 20 61 6e 64 20 74 65 73 74 0a 09 20 20 3b ED and test.. ;
2390: 3b 20 41 20 66 61 69 6c 65 64 20 66 6f 72 20 73 ; A failed for s
23a0: 6f 6d 65 20 72 65 61 73 6f 6e 20 74 68 65 6e 20 ome reason then
23b0: 6f 6e 20 72 65 2d 72 75 6e 20 75 73 69 6e 67 20 on re-run using
23c0: 2d 6b 65 65 70 67 6f 69 6e 67 20 74 68 65 20 72 -keepgoing the r
23d0: 75 6e 20 63 61 6e 20 6e 65 76 65 72 20 63 6f 6d un can never com
23e0: 70 6c 65 74 65 2e 0a 09 20 20 28 63 64 62 3a 64 plete... (cdb:d
23f0: 65 6c 65 74 65 2d 74 65 73 74 73 2d 69 6e 2d 73 elete-tests-in-s
2400: 74 61 74 65 20 2a 72 75 6e 72 65 6d 6f 74 65 2a tate *runremote*
2410: 20 72 75 6e 2d 69 64 20 22 4e 4f 54 5f 53 54 41 run-id "NOT_STA
2420: 52 54 45 44 22 29 0a 09 20 20 28 63 64 62 3a 72 RTED").. (cdb:r
2430: 65 6d 6f 74 65 2d 72 75 6e 20 64 62 3a 73 65 74 emote-run db:set
2440: 2d 74 65 73 74 73 2d 73 74 61 74 65 2d 73 74 61 -tests-state-sta
2450: 74 75 73 20 23 66 20 72 75 6e 2d 69 64 20 74 65 tus #f run-id te
2460: 73 74 2d 6e 61 6d 65 73 20 23 66 20 22 46 41 49 st-names #f "FAI
2470: 4c 22 20 22 4e 4f 54 5f 53 54 41 52 54 45 44 22 L" "NOT_STARTED"
2480: 20 22 46 41 49 4c 22 29 29 29 0a 0a 20 20 20 20 "FAIL")))..
2490: 3b 3b 20 66 72 6f 6d 20 68 65 72 65 20 6f 6e 20 ;; from here on
24a0: 6f 75 74 20 74 68 65 20 64 62 20 77 69 6c 6c 20 out the db will
24b0: 62 65 20 6f 70 65 6e 65 64 20 61 6e 64 20 63 6c be opened and cl
24c0: 6f 73 65 64 20 6f 6e 20 65 76 65 72 79 20 63 61 osed on every ca
24d0: 6c 6c 20 72 75 6e 73 3a 72 75 6e 2d 74 65 73 74 ll runs:run-test
24e0: 73 2d 71 75 65 75 65 0a 20 20 20 20 3b 3b 20 28 s-queue. ;; (
24f0: 73 71 6c 69 74 65 33 3a 66 69 6e 61 6c 69 7a 65 sqlite3:finalize
2500: 21 20 64 62 29 20 0a 20 20 20 20 3b 3b 20 6e 6f ! db) . ;; no
2510: 77 20 61 64 64 20 6e 6f 6e 2d 64 69 72 65 63 74 w add non-direct
2520: 6c 79 20 72 65 66 65 72 65 6e 63 65 64 20 64 65 ly referenced de
2530: 70 65 6e 64 65 6e 63 69 65 73 20 28 69 2e 65 2e pendencies (i.e.
2540: 20 77 61 69 74 6f 6e 29 0a 20 20 20 20 28 69 66 waiton). (if
2550: 20 28 6e 6f 74 20 28 6e 75 6c 6c 3f 20 74 65 73 (not (null? tes
2560: 74 2d 6e 61 6d 65 73 29 29 0a 09 28 6c 65 74 20 t-names))..(let
2570: 6c 6f 6f 70 20 28 28 68 65 64 20 28 63 61 72 20 loop ((hed (car
2580: 74 65 73 74 2d 6e 61 6d 65 73 29 29 0a 09 09 20 test-names))...
2590: 20 20 28 74 61 6c 20 28 63 64 72 20 74 65 73 74 (tal (cdr test
25a0: 2d 6e 61 6d 65 73 29 29 29 20 20 20 20 20 20 20 -names)))
25b0: 20 20 3b 3b 20 27 72 65 74 75 72 6e 2d 70 72 6f ;; 'return-pro
25c0: 63 73 20 74 65 6c 6c 73 20 74 68 65 20 63 6f 6e cs tells the con
25d0: 66 69 67 20 72 65 61 64 65 72 20 74 6f 20 70 72 fig reader to pr
25e0: 65 70 20 72 75 6e 6e 69 6e 67 20 73 79 73 74 65 ep running syste
25f0: 6d 20 62 75 74 20 72 65 74 75 72 6e 20 61 20 70 m but return a p
2600: 72 6f 63 0a 09 20 20 28 64 65 62 75 67 3a 70 72 roc.. (debug:pr
2610: 69 6e 74 2d 69 6e 66 6f 20 34 20 22 68 65 64 3d int-info 4 "hed=
2620: 22 20 68 65 64 20 22 20 61 74 20 74 6f 70 20 6f " hed " at top o
2630: 66 20 6c 6f 6f 70 22 29 0a 09 20 20 28 6c 65 74 f loop").. (let
2640: 2a 20 28 28 63 6f 6e 66 69 67 20 20 28 74 65 73 * ((config (tes
2650: 74 73 3a 67 65 74 2d 74 65 73 74 63 6f 6e 66 69 ts:get-testconfi
2660: 67 20 68 65 64 20 27 72 65 74 75 72 6e 2d 70 72 g hed 'return-pr
2670: 6f 63 73 29 29 0a 09 09 20 28 77 61 69 74 6f 6e ocs))... (waiton
2680: 73 20 28 6c 65 74 20 28 28 69 6e 73 74 72 20 28 s (let ((instr (
2690: 69 66 20 63 6f 6e 66 69 67 20 0a 09 09 09 09 09 if config ......
26a0: 20 20 20 28 63 6f 6e 66 69 67 2d 6c 6f 6f 6b 75 (config-looku
26b0: 70 20 63 6f 6e 66 69 67 20 22 72 65 71 75 69 72 p config "requir
26c0: 65 6d 65 6e 74 73 22 20 22 77 61 69 74 6f 6e 22 ements" "waiton"
26d0: 29 0a 09 09 09 09 09 20 20 20 28 62 65 67 69 6e )...... (begin
26e0: 20 3b 3b 20 4e 6f 20 63 6f 6e 66 69 67 20 6d 65 ;; No config me
26f0: 61 6e 73 20 74 68 69 73 20 69 73 20 61 20 6e 6f ans this is a no
2700: 6e 2d 65 78 69 73 74 61 6e 74 20 74 65 73 74 0a n-existant test.
2710: 09 09 09 09 09 20 20 20 20 20 28 64 65 62 75 67 ..... (debug
2720: 3a 70 72 69 6e 74 20 30 20 22 45 52 52 4f 52 3a :print 0 "ERROR:
2730: 20 6e 6f 6e 2d 65 78 69 73 74 65 6e 74 20 72 65 non-existent re
2740: 71 75 69 72 65 64 20 74 65 73 74 20 5c 22 22 20 quired test \""
2750: 68 65 64 20 22 5c 22 22 29 0a 09 09 09 09 09 20 hed "\"")......
2760: 20 20 20 20 28 69 66 20 64 62 20 28 73 71 6c 69 (if db (sqli
2770: 74 65 33 3a 66 69 6e 61 6c 69 7a 65 21 20 64 62 te3:finalize! db
2780: 29 29 0a 09 09 09 09 09 20 20 20 20 20 28 65 78 ))...... (ex
2790: 69 74 20 31 29 29 29 29 29 0a 09 09 09 20 20 20 it 1)))))....
27a0: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e (debug:print-in
27b0: 66 6f 20 38 20 22 77 61 69 74 6f 6e 73 20 73 74 fo 8 "waitons st
27c0: 72 69 6e 67 20 69 73 20 22 20 69 6e 73 74 72 29 ring is " instr)
27d0: 0a 09 09 09 20 20 20 20 28 73 74 72 69 6e 67 2d .... (string-
27e0: 73 70 6c 69 74 20 28 63 6f 6e 64 0a 09 09 09 09 split (cond.....
27f0: 09 20 20 20 28 28 70 72 6f 63 65 64 75 72 65 3f . ((procedure?
2800: 20 69 6e 73 74 72 29 0a 09 09 09 09 09 20 20 20 instr)......
2810: 20 28 6c 65 74 20 28 28 72 65 73 20 28 69 6e 73 (let ((res (ins
2820: 74 72 29 29 29 0a 09 09 09 09 09 20 20 20 20 20 tr)))......
2830: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e (debug:print-in
2840: 66 6f 20 38 20 22 77 61 69 74 6f 6e 20 70 72 6f fo 8 "waiton pro
2850: 63 65 64 75 72 65 20 72 65 73 75 6c 74 73 20 69 cedure results i
2860: 6e 20 73 74 72 69 6e 67 20 22 20 72 65 73 20 22 n string " res "
2870: 20 66 6f 72 20 74 65 73 74 20 22 20 68 65 64 29 for test " hed)
2880: 0a 09 09 09 09 09 20 20 20 20 20 20 72 65 73 29 ...... res)
2890: 29 0a 09 09 09 09 09 20 20 20 28 28 73 74 72 69 )...... ((stri
28a0: 6e 67 3f 20 69 6e 73 74 72 29 20 20 20 20 20 69 ng? instr) i
28b0: 6e 73 74 72 29 0a 09 09 09 09 09 20 20 20 28 65 nstr)...... (e
28c0: 6c 73 65 20 0a 09 09 09 09 09 20 20 20 20 3b 3b lse ...... ;;
28d0: 20 4e 4f 54 45 3a 20 54 68 69 73 20 69 73 20 61 NOTE: This is a
28e0: 63 74 75 61 6c 6c 79 20 74 68 65 20 63 61 73 65 ctually the case
28f0: 20 6f 66 20 2a 6e 6f 2a 20 77 61 69 74 6f 6e 73 of *no* waitons
2900: 21 20 3b 3b 20 28 64 65 62 75 67 3a 70 72 69 6e ! ;; (debug:prin
2910: 74 20 30 20 22 45 52 52 4f 52 3a 20 73 6f 6d 65 t 0 "ERROR: some
2920: 74 68 69 6e 67 20 77 65 6e 74 20 77 72 6f 6e 67 thing went wrong
2930: 20 69 6e 20 70 72 6f 63 65 73 73 69 6e 67 20 77 in processing w
2940: 61 69 74 6f 6e 73 20 66 6f 72 20 74 65 73 74 20 aitons for test
2950: 22 20 68 65 64 29 0a 09 09 09 09 09 20 20 20 20 " hed)......
2960: 22 22 29 29 29 29 29 29 0a 09 20 20 20 20 28 64 "")))))).. (d
2970: 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 ebug:print-info
2980: 38 20 22 77 61 69 74 6f 6e 73 3a 20 22 20 77 61 8 "waitons: " wa
2990: 69 74 6f 6e 73 29 0a 09 20 20 20 20 3b 3b 20 63 itons).. ;; c
29a0: 68 65 63 6b 20 66 6f 72 20 68 65 64 20 69 6e 20 heck for hed in
29b0: 77 61 69 74 6f 6e 73 20 3d 3e 20 74 68 69 73 20 waitons => this
29c0: 77 6f 75 6c 64 20 62 65 20 63 69 72 63 75 6c 61 would be circula
29d0: 72 2c 20 72 65 6d 6f 76 65 20 69 74 20 61 6e 64 r, remove it and
29e0: 20 69 73 73 75 65 20 61 6e 0a 09 20 20 20 20 3b issue an.. ;
29f0: 3b 20 65 72 72 6f 72 0a 09 20 20 20 20 28 69 66 ; error.. (if
2a00: 20 28 6d 65 6d 62 65 72 20 68 65 64 20 77 61 69 (member hed wai
2a10: 74 6f 6e 73 29 0a 09 09 28 62 65 67 69 6e 0a 09 tons)...(begin..
2a20: 09 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 . (debug:print
2a30: 30 20 22 45 52 52 4f 52 3a 20 74 65 73 74 20 22 0 "ERROR: test "
2a40: 20 68 65 64 20 22 20 68 61 73 20 6c 69 73 74 65 hed " has liste
2a50: 64 20 69 74 73 65 6c 66 20 61 73 20 61 20 77 61 d itself as a wa
2a60: 69 74 6f 6e 2c 20 70 6c 65 61 73 65 20 63 6f 72 iton, please cor
2a70: 72 65 63 74 20 74 68 69 73 21 22 29 0a 09 09 20 rect this!")...
2a80: 20 28 73 65 74 21 20 77 61 69 74 6f 6e 73 20 28 (set! waitons (
2a90: 66 69 6c 74 65 72 20 28 6c 61 6d 62 64 61 20 28 filter (lambda (
2aa0: 78 29 28 6e 6f 74 20 28 65 71 75 61 6c 3f 20 78 x)(not (equal? x
2ab0: 20 68 65 64 29 29 29 20 77 61 69 74 6f 6e 73 29 hed))) waitons)
2ac0: 29 29 29 0a 09 20 20 20 20 0a 09 20 20 20 20 3b ))).. .. ;
2ad0: 3b 20 28 69 74 65 6d 73 20 20 20 28 69 74 65 6d ; (items (item
2ae0: 73 3a 67 65 74 2d 69 74 65 6d 73 2d 66 72 6f 6d s:get-items-from
2af0: 2d 63 6f 6e 66 69 67 20 63 6f 6e 66 69 67 29 29 -config config))
2b00: 29 0a 09 20 20 20 20 28 69 66 20 28 6e 6f 74 20 ).. (if (not
2b10: 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f (hash-table-ref/
2b20: 64 65 66 61 75 6c 74 20 74 65 73 74 2d 72 65 63 default test-rec
2b30: 6f 72 64 73 20 68 65 64 20 23 66 29 29 0a 09 09 ords hed #f))...
2b40: 28 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 (hash-table-set!
2b50: 20 74 65 73 74 2d 72 65 63 6f 72 64 73 0a 09 09 test-records...
2b60: 09 09 20 68 65 64 20 28 76 65 63 74 6f 72 20 68 .. hed (vector h
2b70: 65 64 20 20 20 20 20 3b 3b 20 30 0a 09 09 09 09 ed ;; 0.....
2b80: 09 20 20 20 20 20 63 6f 6e 66 69 67 20 20 3b 3b . config ;;
2b90: 20 31 0a 09 09 09 09 09 20 20 20 20 20 77 61 69 1...... wai
2ba0: 74 6f 6e 73 20 3b 3b 20 32 0a 09 09 09 09 09 20 tons ;; 2......
2bb0: 20 20 20 20 28 63 6f 6e 66 69 67 2d 6c 6f 6f 6b (config-look
2bc0: 75 70 20 63 6f 6e 66 69 67 20 22 72 65 71 75 69 up config "requi
2bd0: 72 65 6d 65 6e 74 73 22 20 22 70 72 69 6f 72 69 rements" "priori
2be0: 74 79 22 29 20 20 20 20 20 3b 3b 20 70 72 69 6f ty") ;; prio
2bf0: 72 69 74 79 20 33 0a 09 09 09 09 09 20 20 20 20 rity 3......
2c00: 20 28 6c 65 74 20 28 28 69 74 65 6d 73 20 20 20 (let ((items
2c10: 20 20 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 (hash-table-r
2c20: 65 66 2f 64 65 66 61 75 6c 74 20 63 6f 6e 66 69 ef/default confi
2c30: 67 20 22 69 74 65 6d 73 22 20 23 66 29 29 20 3b g "items" #f)) ;
2c40: 3b 20 69 74 65 6d 73 20 34 0a 09 09 09 09 09 09 ; items 4.......
2c50: 20 20 20 28 69 74 65 6d 73 74 61 62 6c 65 20 28 (itemstable (
2c60: 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 hash-table-ref/d
2c70: 65 66 61 75 6c 74 20 63 6f 6e 66 69 67 20 22 69 efault config "i
2c80: 74 65 6d 73 74 61 62 6c 65 22 20 23 66 29 29 29 temstable" #f)))
2c90: 20 0a 09 09 09 09 09 20 20 20 20 20 20 20 3b 3b ...... ;;
2ca0: 20 69 66 20 65 69 74 68 65 72 20 69 74 65 6d 73 if either items
2cb0: 20 6f 72 20 69 74 65 6d 73 20 74 61 62 6c 65 20 or items table
2cc0: 69 73 20 61 20 70 72 6f 63 20 72 65 74 75 72 6e is a proc return
2cd0: 20 69 74 20 73 6f 20 74 65 73 74 20 72 75 6e 6e it so test runn
2ce0: 69 6e 67 0a 09 09 09 09 09 20 20 20 20 20 20 20 ing......
2cf0: 3b 3b 20 70 72 6f 63 65 73 73 20 63 61 6e 20 6b ;; process can k
2d00: 6e 6f 77 20 74 6f 20 63 61 6c 6c 20 69 74 65 6d now to call item
2d10: 73 3a 67 65 74 2d 69 74 65 6d 73 2d 66 72 6f 6d s:get-items-from
2d20: 2d 63 6f 6e 66 69 67 0a 09 09 09 09 09 20 20 20 -config......
2d30: 20 20 20 20 3b 3b 20 69 66 20 65 69 74 68 65 72 ;; if either
2d40: 20 69 73 20 61 20 6c 69 73 74 20 61 6e 64 20 6e is a list and n
2d50: 6f 6e 65 20 69 73 20 61 20 70 72 6f 63 20 67 6f one is a proc go
2d60: 20 61 68 65 61 64 20 61 6e 64 20 63 61 6c 6c 20 ahead and call
2d70: 67 65 74 2d 69 74 65 6d 73 0a 09 09 09 09 09 20 get-items......
2d80: 20 20 20 20 20 20 3b 3b 20 6f 74 68 65 72 77 69 ;; otherwi
2d90: 73 65 20 72 65 74 75 72 6e 20 23 66 20 2d 20 74 se return #f - t
2da0: 68 69 73 20 69 73 20 6e 6f 74 20 61 6e 20 69 74 his is not an it
2db0: 65 72 61 74 65 64 20 74 65 73 74 0a 09 09 09 09 erated test.....
2dc0: 09 20 20 20 20 20 20 20 28 63 6f 6e 64 0a 09 09 . (cond...
2dd0: 09 09 09 09 28 28 70 72 6f 63 65 64 75 72 65 3f ....((procedure?
2de0: 20 69 74 65 6d 73 29 20 20 20 20 20 20 0a 09 09 items) ...
2df0: 09 09 09 09 20 28 64 65 62 75 67 3a 70 72 69 6e .... (debug:prin
2e00: 74 2d 69 6e 66 6f 20 34 20 22 69 74 65 6d 73 20 t-info 4 "items
2e10: 69 73 20 61 20 70 72 6f 63 65 64 75 72 65 2c 20 is a procedure,
2e20: 77 69 6c 6c 20 63 61 6c 63 20 6c 61 74 65 72 22 will calc later"
2e30: 29 0a 09 09 09 09 09 09 20 69 74 65 6d 73 29 20 )....... items)
2e40: 20 20 20 20 20 20 20 20 20 20 20 3b 3b 20 63 61 ;; ca
2e50: 6c 63 20 6c 61 74 65 72 0a 09 09 09 09 09 09 28 lc later.......(
2e60: 28 70 72 6f 63 65 64 75 72 65 3f 20 69 74 65 6d (procedure? item
2e70: 73 74 61 62 6c 65 29 0a 09 09 09 09 09 09 20 28 stable)....... (
2e80: 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f debug:print-info
2e90: 20 34 20 22 69 74 65 6d 73 74 61 62 6c 65 20 69 4 "itemstable i
2ea0: 73 20 61 20 70 72 6f 63 65 64 75 72 65 2c 20 77 s a procedure, w
2eb0: 69 6c 6c 20 63 61 6c 63 20 6c 61 74 65 72 22 29 ill calc later")
2ec0: 0a 09 09 09 09 09 09 20 69 74 65 6d 73 74 61 62 ....... itemstab
2ed0: 6c 65 29 20 20 20 20 20 20 20 3b 3b 20 63 61 6c le) ;; cal
2ee0: 63 20 6c 61 74 65 72 0a 09 09 09 09 09 09 28 28 c later.......((
2ef0: 66 69 6c 74 65 72 20 28 6c 61 6d 62 64 61 20 28 filter (lambda (
2f00: 78 29 0a 09 09 09 09 09 09 09 20 20 20 28 6c 65 x)........ (le
2f10: 74 20 28 28 76 61 6c 20 28 63 61 72 20 78 29 29 t ((val (car x))
2f20: 29 0a 09 09 09 09 09 09 09 20 20 20 20 20 28 69 )........ (i
2f30: 66 20 28 70 72 6f 63 65 64 75 72 65 3f 20 76 61 f (procedure? va
2f40: 6c 29 20 76 61 6c 20 23 66 29 29 29 0a 09 09 09 l) val #f)))....
2f50: 09 09 09 09 20 28 61 70 70 65 6e 64 20 28 69 66 .... (append (if
2f60: 20 28 6c 69 73 74 3f 20 69 74 65 6d 73 29 20 69 (list? items) i
2f70: 74 65 6d 73 20 27 28 29 29 0a 09 09 09 09 09 09 tems '()).......
2f80: 09 09 20 28 69 66 20 28 6c 69 73 74 3f 20 69 74 .. (if (list? it
2f90: 65 6d 73 74 61 62 6c 65 29 20 69 74 65 6d 73 74 emstable) itemst
2fa0: 61 62 6c 65 20 27 28 29 29 29 29 0a 09 09 09 09 able '()))).....
2fb0: 09 09 20 27 68 61 76 65 2d 70 72 6f 63 65 64 75 .. 'have-procedu
2fc0: 72 65 29 0a 09 09 09 09 09 09 28 28 6f 72 20 28 re).......((or (
2fd0: 6c 69 73 74 3f 20 69 74 65 6d 73 29 28 6c 69 73 list? items)(lis
2fe0: 74 3f 20 69 74 65 6d 73 74 61 62 6c 65 29 29 20 t? itemstable))
2ff0: 3b 3b 20 63 61 6c 63 20 6e 6f 77 0a 09 09 09 09 ;; calc now.....
3000: 09 09 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d .. (debug:print-
3010: 69 6e 66 6f 20 34 20 22 69 74 65 6d 73 20 61 6e info 4 "items an
3020: 64 20 69 74 65 6d 73 74 61 62 6c 65 20 61 72 65 d itemstable are
3030: 20 6c 69 73 74 73 2c 20 63 61 6c 63 20 6e 6f 77 lists, calc now
3040: 5c 6e 22 0a 09 09 09 09 09 09 09 20 20 20 20 20 \n"........
3050: 20 22 20 20 20 20 69 74 65 6d 73 3a 20 22 20 69 " items: " i
3060: 74 65 6d 73 20 22 20 69 74 65 6d 73 74 61 62 6c tems " itemstabl
3070: 65 3a 20 22 20 69 74 65 6d 73 74 61 62 6c 65 29 e: " itemstable)
3080: 0a 09 09 09 09 09 09 20 28 69 74 65 6d 73 3a 67 ....... (items:g
3090: 65 74 2d 69 74 65 6d 73 2d 66 72 6f 6d 2d 63 6f et-items-from-co
30a0: 6e 66 69 67 20 63 6f 6e 66 69 67 29 29 0a 09 09 nfig config))...
30b0: 09 09 09 09 28 65 6c 73 65 20 23 66 29 29 29 20 ....(else #f)))
30c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
30d0: 20 20 20 20 20 20 20 20 20 20 3b 3b 20 6e 6f 74 ;; not
30e0: 20 69 74 65 72 61 74 65 64 0a 09 09 09 09 09 20 iterated......
30f0: 20 20 20 20 23 66 20 20 20 20 20 20 3b 3b 20 69 #f ;; i
3100: 74 65 6d 73 64 61 74 20 35 0a 09 09 09 09 09 20 temsdat 5......
3110: 20 20 20 20 23 66 20 20 20 20 20 20 3b 3b 20 73 #f ;; s
3120: 70 61 72 65 20 2d 20 75 73 65 64 20 66 6f 72 20 pare - used for
3130: 69 74 65 6d 2d 70 61 74 68 0a 09 09 09 09 09 20 item-path......
3140: 20 20 20 20 29 29 29 0a 09 20 20 20 20 28 66 6f ))).. (fo
3150: 72 2d 65 61 63 68 20 0a 09 20 20 20 20 20 28 6c r-each .. (l
3160: 61 6d 62 64 61 20 28 77 61 69 74 6f 6e 29 0a 09 ambda (waiton)..
3170: 20 20 20 20 20 20 20 28 69 66 20 28 61 6e 64 20 (if (and
3180: 77 61 69 74 6f 6e 20 28 6e 6f 74 20 28 6d 65 6d waiton (not (mem
3190: 62 65 72 20 77 61 69 74 6f 6e 20 74 65 73 74 2d ber waiton test-
31a0: 6e 61 6d 65 73 29 29 29 0a 09 09 20 20 20 28 62 names)))... (b
31b0: 65 67 69 6e 0a 09 09 20 20 20 20 20 28 73 65 74 egin... (set
31c0: 21 20 72 65 71 75 69 72 65 64 2d 74 65 73 74 73 ! required-tests
31d0: 20 28 63 6f 6e 73 20 77 61 69 74 6f 6e 20 72 65 (cons waiton re
31e0: 71 75 69 72 65 64 2d 74 65 73 74 73 29 29 0a 09 quired-tests))..
31f0: 09 20 20 20 20 20 28 73 65 74 21 20 74 65 73 74 . (set! test
3200: 2d 6e 61 6d 65 73 20 28 63 6f 6e 73 20 77 61 69 -names (cons wai
3210: 74 6f 6e 20 74 65 73 74 2d 6e 61 6d 65 73 29 29 ton test-names))
3220: 29 29 29 20 3b 3b 20 77 61 73 20 61 6e 20 61 70 ))) ;; was an ap
3230: 70 65 6e 64 2c 20 6e 6f 77 20 61 20 63 6f 6e 73 pend, now a cons
3240: 0a 09 20 20 20 20 20 77 61 69 74 6f 6e 73 29 0a .. waitons).
3250: 09 20 20 20 20 28 6c 65 74 20 28 28 72 65 6d 74 . (let ((remt
3260: 65 73 74 73 20 28 64 65 6c 65 74 65 2d 64 75 70 ests (delete-dup
3270: 6c 69 63 61 74 65 73 20 28 61 70 70 65 6e 64 20 licates (append
3280: 77 61 69 74 6f 6e 73 20 74 61 6c 29 29 29 29 0a waitons tal)))).
3290: 09 20 20 20 20 20 20 28 69 66 20 28 6e 6f 74 20 . (if (not
32a0: 28 6e 75 6c 6c 3f 20 72 65 6d 74 65 73 74 73 29 (null? remtests)
32b0: 29 0a 09 09 20 20 28 6c 6f 6f 70 20 28 63 61 72 )... (loop (car
32c0: 20 72 65 6d 74 65 73 74 73 29 28 63 64 72 20 72 remtests)(cdr r
32d0: 65 6d 74 65 73 74 73 29 29 29 29 29 29 29 0a 0a emtests)))))))..
32e0: 20 20 20 20 28 69 66 20 28 6e 6f 74 20 28 6e 75 (if (not (nu
32f0: 6c 6c 3f 20 72 65 71 75 69 72 65 64 2d 74 65 73 ll? required-tes
3300: 74 73 29 29 0a 09 28 64 65 62 75 67 3a 70 72 69 ts))..(debug:pri
3310: 6e 74 2d 69 6e 66 6f 20 31 20 22 41 64 64 69 6e nt-info 1 "Addin
3320: 67 20 22 20 72 65 71 75 69 72 65 64 2d 74 65 73 g " required-tes
3330: 74 73 20 22 20 74 6f 20 74 68 65 20 72 75 6e 20 ts " to the run
3340: 71 75 65 75 65 22 29 29 0a 20 20 20 20 3b 3b 20 queue")). ;;
3350: 4e 4f 54 45 3a 20 74 68 65 73 65 20 61 72 65 20 NOTE: these are
3360: 61 6c 6c 20 70 61 72 65 6e 74 20 74 65 73 74 73 all parent tests
3370: 2c 20 69 74 65 6d 73 20 61 72 65 20 6e 6f 74 20 , items are not
3380: 65 78 70 61 6e 64 65 64 20 79 65 74 2e 0a 20 20 expanded yet..
3390: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 (debug:print-i
33a0: 6e 66 6f 20 34 20 22 74 65 73 74 2d 72 65 63 6f nfo 4 "test-reco
33b0: 72 64 73 3d 22 20 28 68 61 73 68 2d 74 61 62 6c rds=" (hash-tabl
33c0: 65 2d 3e 61 6c 69 73 74 20 74 65 73 74 2d 72 65 e->alist test-re
33d0: 63 6f 72 64 73 29 29 0a 20 20 20 20 28 72 75 6e cords)). (run
33e0: 73 3a 72 75 6e 2d 74 65 73 74 73 2d 71 75 65 75 s:run-tests-queu
33f0: 65 20 72 75 6e 2d 69 64 20 72 75 6e 6e 61 6d 65 e run-id runname
3400: 20 74 65 73 74 2d 72 65 63 6f 72 64 73 20 6b 65 test-records ke
3410: 79 76 61 6c 6c 73 74 20 66 6c 61 67 73 20 74 65 yvallst flags te
3420: 73 74 2d 70 61 74 74 73 29 0a 20 20 20 20 28 64 st-patts). (d
3430: 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 ebug:print-info
3440: 34 20 22 41 6c 6c 20 64 6f 6e 65 20 62 79 20 68 4 "All done by h
3450: 65 72 65 22 29 29 29 0a 0a 28 64 65 66 69 6e 65 ere")))..(define
3460: 20 28 72 75 6e 73 3a 63 61 6c 63 2d 66 61 69 6c (runs:calc-fail
3470: 73 20 70 72 65 72 65 71 73 2d 6e 6f 74 2d 6d 65 s prereqs-not-me
3480: 74 29 0a 20 20 28 66 69 6c 74 65 72 20 28 6c 61 t). (filter (la
3490: 6d 62 64 61 20 28 74 65 73 74 29 0a 09 20 20 20 mbda (test)..
34a0: 20 28 61 6e 64 20 28 76 65 63 74 6f 72 3f 20 74 (and (vector? t
34b0: 65 73 74 29 20 3b 3b 20 6e 6f 74 20 28 73 74 72 est) ;; not (str
34c0: 69 6e 67 3f 20 74 65 73 74 29 29 0a 09 09 20 28 ing? test))... (
34d0: 65 71 75 61 6c 3f 20 28 64 62 3a 74 65 73 74 2d equal? (db:test-
34e0: 67 65 74 2d 73 74 61 74 65 20 74 65 73 74 29 20 get-state test)
34f0: 22 43 4f 4d 50 4c 45 54 45 44 22 29 0a 09 09 20 "COMPLETED")...
3500: 28 6e 6f 74 20 28 6d 65 6d 62 65 72 20 28 64 62 (not (member (db
3510: 3a 74 65 73 74 2d 67 65 74 2d 73 74 61 74 75 73 :test-get-status
3520: 20 74 65 73 74 29 0a 09 09 09 20 20 20 20 20 20 test)....
3530: 27 28 22 50 41 53 53 22 20 22 57 41 52 4e 22 20 '("PASS" "WARN"
3540: 22 43 48 45 43 4b 22 20 22 57 41 49 56 45 44 22 "CHECK" "WAIVED"
3550: 20 22 53 4b 49 50 22 29 29 29 29 29 0a 09 20 20 "SKIP")))))..
3560: 70 72 65 72 65 71 73 2d 6e 6f 74 2d 6d 65 74 29 prereqs-not-met)
3570: 29 0a 0a 28 64 65 66 69 6e 65 20 28 72 75 6e 73 )..(define (runs
3580: 3a 63 61 6c 63 2d 6e 6f 74 2d 63 6f 6d 70 6c 65 :calc-not-comple
3590: 74 65 64 20 70 72 65 72 65 71 73 2d 6e 6f 74 2d ted prereqs-not-
35a0: 6d 65 74 29 0a 20 20 28 66 69 6c 74 65 72 0a 20 met). (filter.
35b0: 20 20 28 6c 61 6d 62 64 61 20 28 74 29 0a 20 20 (lambda (t).
35c0: 20 20 20 28 6f 72 20 28 6e 6f 74 20 28 76 65 63 (or (not (vec
35d0: 74 6f 72 3f 20 74 29 29 0a 09 20 28 6e 6f 74 20 tor? t)).. (not
35e0: 28 65 71 75 61 6c 3f 20 22 43 4f 4d 50 4c 45 54 (equal? "COMPLET
35f0: 45 44 22 20 28 64 62 3a 74 65 73 74 2d 67 65 74 ED" (db:test-get
3600: 2d 73 74 61 74 65 20 74 29 29 29 29 29 0a 20 20 -state t))))).
3610: 20 70 72 65 72 65 71 73 2d 6e 6f 74 2d 6d 65 74 prereqs-not-met
3620: 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 72 75 6e ))..(define (run
3630: 73 3a 70 72 65 74 74 79 2d 73 74 72 69 6e 67 20 s:pretty-string
3640: 6c 73 74 29 0a 20 20 28 6d 61 70 20 28 6c 61 6d lst). (map (lam
3650: 62 64 61 20 28 74 29 0a 09 20 28 69 66 20 28 6e bda (t).. (if (n
3660: 6f 74 20 28 76 65 63 74 6f 72 3f 20 74 29 29 0a ot (vector? t)).
3670: 09 20 20 20 20 20 28 63 6f 6e 63 20 74 29 0a 09 . (conc t)..
3680: 20 20 20 20 20 28 63 6f 6e 63 20 28 64 62 3a 74 (conc (db:t
3690: 65 73 74 2d 67 65 74 2d 74 65 73 74 6e 61 6d 65 est-get-testname
36a0: 20 74 29 20 22 3a 22 20 28 64 62 3a 74 65 73 74 t) ":" (db:test
36b0: 2d 67 65 74 2d 73 74 61 74 65 20 74 29 20 22 2f -get-state t) "/
36c0: 22 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 73 " (db:test-get-s
36d0: 74 61 74 75 73 20 74 29 29 29 29 0a 20 20 20 20 tatus t)))).
36e0: 20 20 20 6c 73 74 29 29 0a 0a 28 64 65 66 69 6e lst))..(defin
36f0: 65 20 28 72 75 6e 73 3a 6d 61 6b 65 2d 66 75 6c e (runs:make-ful
3700: 6c 2d 74 65 73 74 2d 6e 61 6d 65 20 74 65 73 74 l-test-name test
3710: 6e 61 6d 65 20 69 74 65 6d 70 61 74 68 29 0a 20 name itempath).
3720: 20 28 69 66 20 28 65 71 75 61 6c 3f 20 69 74 65 (if (equal? ite
3730: 6d 70 61 74 68 20 22 22 29 20 74 65 73 74 6e 61 mpath "") testna
3740: 6d 65 20 28 63 6f 6e 63 20 74 65 73 74 6e 61 6d me (conc testnam
3750: 65 20 22 2f 22 20 69 74 65 6d 70 61 74 68 29 29 e "/" itempath))
3760: 29 0a 0a 3b 3b 20 74 65 73 74 2d 72 65 63 6f 72 )..;; test-recor
3770: 64 73 20 69 73 20 61 20 68 61 73 68 20 74 61 62 ds is a hash tab
3780: 6c 65 20 74 65 73 74 6e 61 6d 65 3a 69 74 65 6d le testname:item
3790: 5f 70 61 74 68 20 3d 3e 20 76 65 63 74 6f 72 20 _path => vector
37a0: 3c 20 74 65 73 74 6e 61 6d 65 20 74 65 73 74 63 < testname testc
37b0: 6f 6e 66 69 67 20 77 61 69 74 6f 6e 73 20 70 72 onfig waitons pr
37c0: 69 6f 72 69 74 79 20 69 74 65 6d 73 2d 69 6e 66 iority items-inf
37d0: 6f 20 2e 2e 2e 20 3e 0a 28 64 65 66 69 6e 65 20 o ... >.(define
37e0: 28 72 75 6e 73 3a 72 75 6e 2d 74 65 73 74 73 2d (runs:run-tests-
37f0: 71 75 65 75 65 20 72 75 6e 2d 69 64 20 72 75 6e queue run-id run
3800: 6e 61 6d 65 20 74 65 73 74 2d 72 65 63 6f 72 64 name test-record
3810: 73 20 6b 65 79 76 61 6c 6c 73 74 20 66 6c 61 67 s keyvallst flag
3820: 73 20 74 65 73 74 2d 70 61 74 74 73 29 0a 20 20 s test-patts).
3830: 20 20 3b 3b 20 41 74 20 74 68 69 73 20 70 6f 69 ;; At this poi
3840: 6e 74 20 74 68 65 20 6c 69 73 74 20 6f 66 20 70 nt the list of p
3850: 61 72 65 6e 74 20 74 65 73 74 73 20 69 73 20 65 arent tests is e
3860: 78 70 61 6e 64 65 64 20 0a 20 20 20 20 3b 3b 20 xpanded . ;;
3870: 4e 42 2f 2f 20 53 68 6f 75 6c 64 20 65 78 70 61 NB// Should expa
3880: 6e 64 20 69 74 65 6d 73 20 68 65 72 65 20 61 6e nd items here an
3890: 64 20 74 68 65 6e 20 69 6e 73 65 72 74 20 69 6e d then insert in
38a0: 74 6f 20 74 68 65 20 72 75 6e 20 71 75 65 75 65 to the run queue
38b0: 2e 0a 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 .. (debug:print
38c0: 20 35 20 22 74 65 73 74 2d 72 65 63 6f 72 64 73 5 "test-records
38d0: 3a 20 22 20 74 65 73 74 2d 72 65 63 6f 72 64 73 : " test-records
38e0: 20 22 2c 20 6b 65 79 76 61 6c 6c 73 74 3a 20 22 ", keyvallst: "
38f0: 20 6b 65 79 76 61 6c 6c 73 74 20 22 20 66 6c 61 keyvallst " fla
3900: 67 73 3a 20 22 20 28 68 61 73 68 2d 74 61 62 6c gs: " (hash-tabl
3910: 65 2d 3e 61 6c 69 73 74 20 66 6c 61 67 73 29 29 e->alist flags))
3920: 0a 20 20 28 6c 65 74 20 28 28 73 6f 72 74 65 64 . (let ((sorted
3930: 2d 74 65 73 74 2d 6e 61 6d 65 73 20 28 74 65 73 -test-names (tes
3940: 74 73 3a 73 6f 72 74 2d 62 79 2d 70 72 69 6f 72 ts:sort-by-prior
3950: 69 74 79 2d 61 6e 64 2d 77 61 69 74 6f 6e 20 74 ity-and-waiton t
3960: 65 73 74 2d 72 65 63 6f 72 64 73 29 29 0a 09 28 est-records))..(
3970: 74 65 73 74 2d 72 65 67 69 73 74 65 72 79 20 20 test-registery
3980: 20 20 28 6d 61 6b 65 2d 68 61 73 68 2d 74 61 62 (make-hash-tab
3990: 6c 65 29 29 0a 09 28 6e 75 6d 2d 72 65 74 72 69 le))..(num-retri
39a0: 65 73 20 20 20 20 20 20 20 20 30 29 0a 09 28 6d es 0)..(m
39b0: 61 78 2d 72 65 74 72 69 65 73 20 20 20 20 20 20 ax-retries
39c0: 20 28 63 6f 6e 66 69 67 2d 6c 6f 6f 6b 75 70 20 (config-lookup
39d0: 2a 63 6f 6e 66 69 67 64 61 74 2a 20 22 73 65 74 *configdat* "set
39e0: 75 70 22 20 22 6d 61 78 72 65 74 72 69 65 73 22 up" "maxretries"
39f0: 29 29 29 0a 20 20 20 20 28 73 65 74 21 20 6d 61 ))). (set! ma
3a00: 78 2d 72 65 74 72 69 65 73 20 28 69 66 20 28 61 x-retries (if (a
3a10: 6e 64 20 6d 61 78 2d 72 65 74 72 69 65 73 20 28 nd max-retries (
3a20: 73 74 72 69 6e 67 2d 3e 6e 75 6d 62 65 72 20 6d string->number m
3a30: 61 78 2d 72 65 74 72 69 65 73 29 29 28 73 74 72 ax-retries))(str
3a40: 69 6e 67 2d 3e 6e 75 6d 62 65 72 20 6d 61 78 2d ing->number max-
3a50: 72 65 74 72 69 65 73 29 20 31 30 30 29 29 0a 20 retries) 100)).
3a60: 20 20 20 28 69 66 20 28 6e 6f 74 20 28 6e 75 6c (if (not (nul
3a70: 6c 3f 20 73 6f 72 74 65 64 2d 74 65 73 74 2d 6e l? sorted-test-n
3a80: 61 6d 65 73 29 29 0a 09 28 6c 65 74 20 6c 6f 6f ames))..(let loo
3a90: 70 20 28 28 68 65 64 20 20 20 20 20 20 20 20 20 p ((hed
3aa0: 28 63 61 72 20 73 6f 72 74 65 64 2d 74 65 73 74 (car sorted-test
3ab0: 2d 6e 61 6d 65 73 29 29 0a 09 09 20 20 20 28 74 -names))... (t
3ac0: 61 6c 20 20 20 20 20 20 20 20 20 28 63 64 72 20 al (cdr
3ad0: 73 6f 72 74 65 64 2d 74 65 73 74 2d 6e 61 6d 65 sorted-test-name
3ae0: 73 29 29 0a 09 09 20 20 20 28 72 65 72 75 6e 73 s))... (reruns
3af0: 20 20 20 20 20 20 27 28 29 29 29 0a 09 20 20 28 '())).. (
3b00: 69 66 20 28 6e 6f 74 20 28 6e 75 6c 6c 3f 20 72 if (not (null? r
3b10: 65 72 75 6e 73 29 29 28 64 65 62 75 67 3a 70 72 eruns))(debug:pr
3b20: 69 6e 74 2d 69 6e 66 6f 20 34 20 22 72 65 72 75 int-info 4 "reru
3b30: 6e 73 3d 22 20 72 65 72 75 6e 73 29 29 0a 09 20 ns=" reruns))..
3b40: 20 3b 3b 20 28 70 72 69 6e 74 20 22 54 6f 70 20 ;; (print "Top
3b50: 6f 66 20 6c 6f 6f 70 2c 20 68 65 64 3d 22 20 68 of loop, hed=" h
3b60: 65 64 20 22 2c 20 74 61 6c 3d 22 20 74 61 6c 20 ed ", tal=" tal
3b70: 22 20 2c 72 65 72 75 6e 73 3d 22 20 72 65 72 75 " ,reruns=" reru
3b80: 6e 73 29 0a 09 20 20 28 6c 65 74 2a 20 28 28 74 ns).. (let* ((t
3b90: 65 73 74 2d 72 65 63 6f 72 64 20 28 68 61 73 68 est-record (hash
3ba0: 2d 74 61 62 6c 65 2d 72 65 66 20 74 65 73 74 2d -table-ref test-
3bb0: 72 65 63 6f 72 64 73 20 68 65 64 29 29 0a 09 09 records hed))...
3bc0: 20 28 74 65 73 74 2d 6e 61 6d 65 20 20 20 28 74 (test-name (t
3bd0: 65 73 74 73 3a 74 65 73 74 71 75 65 75 65 2d 67 ests:testqueue-g
3be0: 65 74 2d 74 65 73 74 6e 61 6d 65 20 74 65 73 74 et-testname test
3bf0: 2d 72 65 63 6f 72 64 29 29 0a 09 09 20 28 74 63 -record))... (tc
3c00: 6f 6e 66 69 67 20 20 20 20 20 28 74 65 73 74 73 onfig (tests
3c10: 3a 74 65 73 74 71 75 65 75 65 2d 67 65 74 2d 74 :testqueue-get-t
3c20: 65 73 74 63 6f 6e 66 69 67 20 74 65 73 74 2d 72 estconfig test-r
3c30: 65 63 6f 72 64 29 29 0a 09 09 20 28 74 65 73 74 ecord))... (test
3c40: 6d 6f 64 65 20 20 20 20 28 6c 65 74 20 28 28 6d mode (let ((m
3c50: 20 28 63 6f 6e 66 69 67 2d 6c 6f 6f 6b 75 70 20 (config-lookup
3c60: 74 63 6f 6e 66 69 67 20 22 72 65 71 75 69 72 65 tconfig "require
3c70: 6d 65 6e 74 73 22 20 22 6d 6f 64 65 22 29 29 29 ments" "mode")))
3c80: 0a 09 09 09 09 28 69 66 20 6d 20 28 73 74 72 69 .....(if m (stri
3c90: 6e 67 2d 3e 73 79 6d 62 6f 6c 20 6d 29 20 27 6e ng->symbol m) 'n
3ca0: 6f 72 6d 61 6c 29 29 29 0a 09 09 20 28 77 61 69 ormal)))... (wai
3cb0: 74 6f 6e 73 20 20 20 20 20 28 74 65 73 74 73 3a tons (tests:
3cc0: 74 65 73 74 71 75 65 75 65 2d 67 65 74 2d 77 61 testqueue-get-wa
3cd0: 69 74 6f 6e 73 20 20 20 20 74 65 73 74 2d 72 65 itons test-re
3ce0: 63 6f 72 64 29 29 0a 09 09 20 28 70 72 69 6f 72 cord))... (prior
3cf0: 69 74 79 20 20 20 20 28 74 65 73 74 73 3a 74 65 ity (tests:te
3d00: 73 74 71 75 65 75 65 2d 67 65 74 2d 70 72 69 6f stqueue-get-prio
3d10: 72 69 74 79 20 20 20 74 65 73 74 2d 72 65 63 6f rity test-reco
3d20: 72 64 29 29 0a 09 09 20 28 69 74 65 6d 64 61 74 rd))... (itemdat
3d30: 20 20 20 20 20 28 74 65 73 74 73 3a 74 65 73 74 (tests:test
3d40: 71 75 65 75 65 2d 67 65 74 2d 69 74 65 6d 64 61 queue-get-itemda
3d50: 74 20 20 20 20 74 65 73 74 2d 72 65 63 6f 72 64 t test-record
3d60: 29 29 20 3b 3b 20 69 74 65 6d 64 61 74 20 63 61 )) ;; itemdat ca
3d70: 6e 20 62 65 20 61 20 73 74 72 69 6e 67 2c 20 6c n be a string, l
3d80: 69 73 74 20 6f 72 20 23 66 0a 09 09 20 28 69 74 ist or #f... (it
3d90: 65 6d 73 20 20 20 20 20 20 20 28 74 65 73 74 73 ems (tests
3da0: 3a 74 65 73 74 71 75 65 75 65 2d 67 65 74 2d 69 :testqueue-get-i
3db0: 74 65 6d 73 20 20 20 20 20 20 74 65 73 74 2d 72 tems test-r
3dc0: 65 63 6f 72 64 29 29 0a 09 09 20 28 69 74 65 6d ecord))... (item
3dd0: 2d 70 61 74 68 20 20 20 28 69 74 65 6d 2d 6c 69 -path (item-li
3de0: 73 74 2d 3e 70 61 74 68 20 69 74 65 6d 64 61 74 st->path itemdat
3df0: 29 29 0a 09 09 20 28 6e 65 77 74 61 6c 20 20 20 ))... (newtal
3e00: 20 20 20 28 61 70 70 65 6e 64 20 74 61 6c 20 28 (append tal (
3e10: 6c 69 73 74 20 68 65 64 29 29 29 29 0a 09 20 20 list hed))))..
3e20: 20 20 0a 09 20 20 20 20 28 64 65 62 75 67 3a 70 .. (debug:p
3e30: 72 69 6e 74 20 36 0a 09 09 09 20 22 74 65 73 74 rint 6.... "test
3e40: 2d 6e 61 6d 65 3a 20 22 20 74 65 73 74 2d 6e 61 -name: " test-na
3e50: 6d 65 0a 09 09 09 20 22 5c 6e 20 20 68 65 64 3a me.... "\n hed:
3e60: 20 20 20 20 20 20 20 20 20 22 20 68 65 64 0a 09 " hed..
3e70: 09 09 20 22 5c 6e 20 20 69 74 65 6d 64 61 74 3a .. "\n itemdat:
3e80: 20 20 20 20 20 22 20 69 74 65 6d 64 61 74 0a 09 " itemdat..
3e90: 09 09 20 22 5c 6e 20 20 69 74 65 6d 73 3a 20 20 .. "\n items:
3ea0: 20 20 20 20 20 22 20 69 74 65 6d 73 0a 09 09 09 " items....
3eb0: 20 22 5c 6e 20 20 69 74 65 6d 2d 70 61 74 68 3a "\n item-path:
3ec0: 20 20 20 22 20 69 74 65 6d 2d 70 61 74 68 0a 09 " item-path..
3ed0: 09 09 20 22 5c 6e 20 20 77 61 69 74 6f 6e 73 3a .. "\n waitons:
3ee0: 20 20 20 20 20 22 20 77 61 69 74 6f 6e 73 0a 09 " waitons..
3ef0: 09 09 20 22 5c 6e 20 20 6e 75 6d 2d 72 65 74 72 .. "\n num-retr
3f00: 69 65 73 3a 20 22 20 6e 75 6d 2d 72 65 74 72 69 ies: " num-retri
3f10: 65 73 0a 09 09 09 20 22 5c 6e 20 20 74 61 6c 3a es.... "\n tal:
3f20: 20 20 20 20 20 20 20 20 20 22 20 74 61 6c 0a 09 " tal..
3f30: 09 09 20 22 5c 6e 20 20 72 65 72 75 6e 73 3a 20 .. "\n reruns:
3f40: 20 20 20 20 20 22 20 72 65 72 75 6e 73 29 0a 0a " reruns)..
3f50: 09 20 20 20 20 3b 3b 20 63 68 65 63 6b 20 66 6f . ;; check fo
3f60: 72 20 68 65 64 20 69 6e 20 77 61 69 74 6f 6e 73 r hed in waitons
3f70: 20 3d 3e 20 74 68 69 73 20 77 6f 75 6c 64 20 62 => this would b
3f80: 65 20 63 69 72 63 75 6c 61 72 2c 20 72 65 6d 6f e circular, remo
3f90: 76 65 20 69 74 20 61 6e 64 20 69 73 73 75 65 20 ve it and issue
3fa0: 61 6e 0a 09 20 20 20 20 3b 3b 20 65 72 72 6f 72 an.. ;; error
3fb0: 0a 09 20 20 20 20 28 69 66 20 28 6d 65 6d 62 65 .. (if (membe
3fc0: 72 20 74 65 73 74 2d 6e 61 6d 65 20 77 61 69 74 r test-name wait
3fd0: 6f 6e 73 29 0a 09 09 28 62 65 67 69 6e 0a 09 09 ons)...(begin...
3fe0: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 (debug:print 0
3ff0: 20 22 45 52 52 4f 52 3a 20 74 65 73 74 20 22 20 "ERROR: test "
4000: 74 65 73 74 2d 6e 61 6d 65 20 22 20 68 61 73 20 test-name " has
4010: 6c 69 73 74 65 64 20 69 74 73 65 6c 66 20 61 73 listed itself as
4020: 20 61 20 77 61 69 74 6f 6e 2c 20 70 6c 65 61 73 a waiton, pleas
4030: 65 20 63 6f 72 72 65 63 74 20 74 68 69 73 21 22 e correct this!"
4040: 29 0a 09 09 20 20 28 73 65 74 21 20 77 61 69 74 )... (set! wait
4050: 6f 6e 20 28 66 69 6c 74 65 72 20 28 6c 61 6d 62 on (filter (lamb
4060: 64 61 20 28 78 29 28 6e 6f 74 20 28 65 71 75 61 da (x)(not (equa
4070: 6c 3f 20 78 20 68 65 64 29 29 29 20 77 61 69 74 l? x hed))) wait
4080: 6f 6e 73 29 29 29 29 0a 0a 09 20 20 20 20 28 63 ons))))... (c
4090: 6f 6e 64 20 3b 3b 20 4f 55 54 45 52 20 43 4f 4e ond ;; OUTER CON
40a0: 44 0a 09 20 20 20 20 20 28 28 6e 6f 74 20 69 74 D.. ((not it
40b0: 65 6d 73 29 20 3b 3b 20 77 68 65 6e 20 66 61 6c ems) ;; when fal
40c0: 73 65 20 74 68 65 20 74 65 73 74 20 69 73 20 6f se the test is o
40d0: 6b 20 74 6f 20 62 65 20 68 61 6e 64 65 64 20 6f k to be handed o
40e0: 66 66 20 74 6f 20 6c 61 75 6e 63 68 20 28 62 75 ff to launch (bu
40f0: 74 20 6e 6f 74 20 62 65 66 6f 72 65 29 0a 09 20 t not before)..
4100: 20 20 20 20 20 28 6c 65 74 2a 20 28 28 72 75 6e (let* ((run
4110: 2d 6c 69 6d 69 74 73 2d 69 6e 66 6f 20 20 20 20 -limits-info
4120: 20 20 20 20 20 28 6f 70 65 6e 2d 72 75 6e 2d 63 (open-run-c
4130: 6c 6f 73 65 20 72 75 6e 73 3a 63 61 6e 2d 72 75 lose runs:can-ru
4140: 6e 2d 6d 6f 72 65 2d 74 65 73 74 73 20 74 65 73 n-more-tests tes
4150: 74 2d 72 65 63 6f 72 64 29 29 20 3b 3b 20 6c 6f t-record)) ;; lo
4160: 6f 6b 20 61 74 20 74 68 65 20 74 65 73 74 20 6a ok at the test j
4170: 6f 62 67 72 6f 75 70 20 61 6e 64 20 74 6f 74 20 obgroup and tot
4180: 6a 6f 62 73 20 72 75 6e 6e 69 6e 67 0a 09 09 20 jobs running...
4190: 20 20 20 20 28 68 61 76 65 2d 72 65 73 6f 75 72 (have-resour
41a0: 63 65 73 20 20 20 20 20 20 20 20 20 20 28 63 61 ces (ca
41b0: 72 20 72 75 6e 2d 6c 69 6d 69 74 73 2d 69 6e 66 r run-limits-inf
41c0: 6f 29 29 0a 09 09 20 20 20 20 20 28 6e 75 6d 2d o))... (num-
41d0: 72 75 6e 6e 69 6e 67 20 20 20 20 20 20 20 20 20 running
41e0: 20 20 20 20 28 6c 69 73 74 2d 72 65 66 20 72 75 (list-ref ru
41f0: 6e 2d 6c 69 6d 69 74 73 2d 69 6e 66 6f 20 31 29 n-limits-info 1)
4200: 29 0a 09 09 20 20 20 20 20 28 6e 75 6d 2d 72 75 )... (num-ru
4210: 6e 6e 69 6e 67 2d 69 6e 2d 6a 6f 62 67 72 6f 75 nning-in-jobgrou
4220: 70 20 28 6c 69 73 74 2d 72 65 66 20 72 75 6e 2d p (list-ref run-
4230: 6c 69 6d 69 74 73 2d 69 6e 66 6f 20 32 29 29 0a limits-info 2)).
4240: 09 09 20 20 20 20 20 28 6d 61 78 2d 63 6f 6e 63 .. (max-conc
4250: 75 72 72 65 6e 74 2d 6a 6f 62 73 20 20 20 20 20 urrent-jobs
4260: 28 6c 69 73 74 2d 72 65 66 20 72 75 6e 2d 6c 69 (list-ref run-li
4270: 6d 69 74 73 2d 69 6e 66 6f 20 33 29 29 0a 09 09 mits-info 3))...
4280: 20 20 20 20 20 28 6a 6f 62 2d 67 72 6f 75 70 2d (job-group-
4290: 6c 69 6d 69 74 20 20 20 20 20 20 20 20 20 28 6c limit (l
42a0: 69 73 74 2d 72 65 66 20 72 75 6e 2d 6c 69 6d 69 ist-ref run-limi
42b0: 74 73 2d 69 6e 66 6f 20 34 29 29 0a 09 09 20 20 ts-info 4))...
42c0: 20 20 20 28 70 72 65 72 65 71 73 2d 6e 6f 74 2d (prereqs-not-
42d0: 6d 65 74 20 20 20 20 20 20 20 20 20 28 6f 70 65 met (ope
42e0: 6e 2d 72 75 6e 2d 63 6c 6f 73 65 20 64 62 3a 67 n-run-close db:g
42f0: 65 74 2d 70 72 65 72 65 71 73 2d 6e 6f 74 2d 6d et-prereqs-not-m
4300: 65 74 20 23 66 20 72 75 6e 2d 69 64 20 77 61 69 et #f run-id wai
4310: 74 6f 6e 73 20 69 74 65 6d 2d 70 61 74 68 20 6d tons item-path m
4320: 6f 64 65 3a 20 74 65 73 74 6d 6f 64 65 29 29 0a ode: testmode)).
4330: 09 09 20 20 20 20 20 28 66 61 69 6c 73 20 20 20 .. (fails
4340: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
4350: 28 72 75 6e 73 3a 63 61 6c 63 2d 66 61 69 6c 73 (runs:calc-fails
4360: 20 70 72 65 72 65 71 73 2d 6e 6f 74 2d 6d 65 74 prereqs-not-met
4370: 29 29 0a 09 09 20 20 20 20 20 28 6e 6f 6e 2d 63 ))... (non-c
4380: 6f 6d 70 6c 65 74 65 64 20 20 20 20 20 20 20 20 ompleted
4390: 20 20 20 28 72 75 6e 73 3a 63 61 6c 63 2d 6e 6f (runs:calc-no
43a0: 74 2d 63 6f 6d 70 6c 65 74 65 64 20 70 72 65 72 t-completed prer
43b0: 65 71 73 2d 6e 6f 74 2d 6d 65 74 29 29 29 0a 09 eqs-not-met)))..
43c0: 09 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e .(debug:print-in
43d0: 66 6f 20 38 20 22 68 61 76 65 2d 72 65 73 6f 75 fo 8 "have-resou
43e0: 72 63 65 73 3a 20 22 20 68 61 76 65 2d 72 65 73 rces: " have-res
43f0: 6f 75 72 63 65 73 20 22 20 70 72 65 72 65 71 73 ources " prereqs
4400: 2d 6e 6f 74 2d 6d 65 74 3a 20 22 20 0a 09 09 09 -not-met: " ....
4410: 20 20 20 20 20 28 73 74 72 69 6e 67 2d 69 6e 74 (string-int
4420: 65 72 73 70 65 72 73 65 20 0a 09 09 09 20 20 20 ersperse ....
4430: 20 20 20 28 6d 61 70 20 28 6c 61 6d 62 64 61 20 (map (lambda
4440: 28 74 29 0a 09 09 09 09 20 20 20 20 20 28 69 66 (t)..... (if
4450: 20 28 76 65 63 74 6f 72 3f 20 74 29 0a 09 09 09 (vector? t)....
4460: 09 09 20 28 63 6f 6e 63 20 28 64 62 3a 74 65 73 .. (conc (db:tes
4470: 74 2d 67 65 74 2d 73 74 61 74 65 20 74 29 20 22 t-get-state t) "
4480: 2f 22 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d /" (db:test-get-
4490: 73 74 61 74 75 73 20 74 29 29 0a 09 09 09 09 09 status t))......
44a0: 20 28 63 6f 6e 63 20 22 20 57 41 52 4e 49 4e 47 (conc " WARNING
44b0: 3a 20 74 20 69 73 20 6e 6f 74 20 61 20 76 65 63 : t is not a vec
44c0: 74 6f 72 3d 22 20 74 20 29 29 29 0a 09 09 09 09 tor=" t ))).....
44d0: 20 20 20 70 72 65 72 65 71 73 2d 6e 6f 74 2d 6d prereqs-not-m
44e0: 65 74 29 20 22 2c 20 22 29 20 22 20 66 61 69 6c et) ", ") " fail
44f0: 73 3a 20 22 20 66 61 69 6c 73 29 0a 09 09 28 64 s: " fails)...(d
4500: 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 ebug:print-info
4510: 34 20 22 68 65 64 3d 22 20 68 65 64 20 22 5c 6e 4 "hed=" hed "\n
4520: 20 20 74 65 73 74 2d 72 65 63 6f 72 64 3d 22 20 test-record="
4530: 74 65 73 74 2d 72 65 63 6f 72 64 20 22 5c 6e 20 test-record "\n
4540: 20 74 65 73 74 2d 6e 61 6d 65 3a 20 22 20 74 65 test-name: " te
4550: 73 74 2d 6e 61 6d 65 20 22 5c 6e 20 20 69 74 65 st-name "\n ite
4560: 6d 2d 70 61 74 68 3a 20 22 20 69 74 65 6d 2d 70 m-path: " item-p
4570: 61 74 68 20 22 5c 6e 20 20 74 65 73 74 2d 70 61 ath "\n test-pa
4580: 74 74 73 3a 20 22 20 74 65 73 74 2d 70 61 74 74 tts: " test-patt
4590: 73 29 0a 0a 09 09 3b 3b 20 44 6f 6e 27 74 20 6b s)....;; Don't k
45a0: 6e 6f 77 20 61 74 20 74 68 69 73 20 74 69 6d 65 now at this time
45b0: 20 69 66 20 74 68 65 20 74 65 73 74 20 68 61 76 if the test hav
45c0: 65 20 62 65 65 6e 20 6c 61 75 6e 63 68 65 64 20 e been launched
45d0: 61 74 20 73 6f 6d 65 20 74 69 6d 65 20 69 6e 20 at some time in
45e0: 74 68 65 20 70 61 73 74 0a 09 09 3b 3b 20 69 2e the past...;; i.
45f0: 65 2e 20 69 73 20 74 68 69 73 20 61 20 72 65 2d e. is this a re-
4600: 6c 61 75 6e 63 68 3f 0a 09 09 28 64 65 62 75 67 launch?...(debug
4610: 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 34 20 22 72 :print-info 4 "r
4620: 75 6e 2d 6c 69 6d 69 74 73 2d 69 6e 66 6f 20 3d un-limits-info =
4630: 20 22 20 72 75 6e 2d 6c 69 6d 69 74 73 2d 69 6e " run-limits-in
4640: 66 6f 29 0a 09 09 28 63 6f 6e 64 20 3b 3b 20 49 fo)...(cond ;; I
4650: 4e 4e 45 52 20 43 4f 4e 44 20 23 31 20 66 6f 72 NNER COND #1 for
4660: 20 61 20 6c 61 75 6e 63 68 61 62 6c 65 20 74 65 a launchable te
4670: 73 74 0a 09 09 20 3b 3b 20 43 68 65 63 6b 20 69 st... ;; Check i
4680: 74 65 6d 20 70 61 74 68 20 61 67 61 69 6e 73 74 tem path against
4690: 20 69 74 65 6d 2d 70 61 74 74 73 0a 09 09 20 28 item-patts... (
46a0: 28 6e 6f 74 20 28 74 65 73 74 73 3a 6d 61 74 63 (not (tests:matc
46b0: 68 20 74 65 73 74 2d 70 61 74 74 73 20 28 74 65 h test-patts (te
46c0: 73 74 73 3a 74 65 73 74 71 75 65 75 65 2d 67 65 sts:testqueue-ge
46d0: 74 2d 74 65 73 74 6e 61 6d 65 20 74 65 73 74 2d t-testname test-
46e0: 72 65 63 6f 72 64 29 20 69 74 65 6d 2d 70 61 74 record) item-pat
46f0: 68 29 29 20 3b 3b 20 54 68 69 73 20 74 65 73 74 h)) ;; This test
4700: 2f 69 74 65 6d 70 61 74 68 20 69 73 20 6e 6f 74 /itempath is not
4710: 20 74 6f 20 62 65 20 72 75 6e 0a 09 09 20 20 3b to be run... ;
4720: 3b 20 65 6c 73 65 20 74 68 65 20 72 75 6e 20 69 ; else the run i
4730: 73 20 73 74 75 63 6b 2c 20 74 65 6d 70 6f 72 61 s stuck, tempora
4740: 72 69 6c 79 20 6f 72 20 70 65 72 6d 61 6e 65 6e rily or permanen
4750: 74 6c 79 0a 09 09 20 20 3b 3b 20 62 75 74 20 73 tly... ;; but s
4760: 68 6f 75 6c 64 20 63 68 65 63 6b 20 69 66 20 69 hould check if i
4770: 74 20 69 73 20 64 75 65 20 74 6f 20 6c 61 63 6b t is due to lack
4780: 20 6f 66 20 72 65 73 6f 75 72 63 65 73 20 76 73 of resources vs
4790: 2e 20 70 72 65 72 65 71 75 69 73 69 74 65 73 0a . prerequisites.
47a0: 09 09 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 .. (debug:print
47b0: 2d 69 6e 66 6f 20 31 20 22 53 6b 69 70 70 69 6e -info 1 "Skippin
47c0: 67 20 22 20 28 74 65 73 74 73 3a 74 65 73 74 71 g " (tests:testq
47d0: 75 65 75 65 2d 67 65 74 2d 74 65 73 74 6e 61 6d ueue-get-testnam
47e0: 65 20 74 65 73 74 2d 72 65 63 6f 72 64 29 20 22 e test-record) "
47f0: 20 22 20 69 74 65 6d 2d 70 61 74 68 20 22 20 61 " item-path " a
4800: 73 20 69 74 20 64 6f 65 73 6e 27 74 20 6d 61 74 s it doesn't mat
4810: 63 68 20 22 20 74 65 73 74 2d 70 61 74 74 73 29 ch " test-patts)
4820: 0a 09 09 20 20 3b 3b 20 28 74 68 72 65 61 64 2d ... ;; (thread-
4830: 73 6c 65 65 70 21 20 2a 67 6c 6f 62 61 6c 2d 64 sleep! *global-d
4840: 65 6c 74 61 2a 29 0a 09 09 20 20 28 69 66 20 28 elta*)... (if (
4850: 6e 6f 74 20 28 6e 75 6c 6c 3f 20 74 61 6c 29 29 not (null? tal))
4860: 0a 09 09 20 20 20 20 20 20 28 6c 6f 6f 70 20 28 ... (loop (
4870: 63 61 72 20 74 61 6c 29 28 63 64 72 20 74 61 6c car tal)(cdr tal
4880: 29 20 72 65 72 75 6e 73 29 29 29 0a 09 09 20 28 ) reruns)))... (
4890: 20 3b 3b 20 28 61 6e 64 0a 09 09 20 20 28 6e 6f ;; (and... (no
48a0: 74 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 t (hash-table-re
48b0: 66 2f 64 65 66 61 75 6c 74 20 74 65 73 74 2d 72 f/default test-r
48c0: 65 67 69 73 74 65 72 79 20 28 72 75 6e 73 3a 6d egistery (runs:m
48d0: 61 6b 65 2d 66 75 6c 6c 2d 74 65 73 74 2d 6e 61 ake-full-test-na
48e0: 6d 65 20 74 65 73 74 2d 6e 61 6d 65 20 69 74 65 me test-name ite
48f0: 6d 2d 70 61 74 68 29 20 23 66 29 29 0a 09 09 20 m-path) #f))...
4900: 20 20 20 20 20 3b 3b 20 28 61 6e 64 20 6d 61 78 ;; (and max
4910: 2d 63 6f 6e 63 75 72 72 65 6e 74 2d 6a 6f 62 73 -concurrent-jobs
4920: 20 28 3e 20 28 2d 20 6d 61 78 2d 63 6f 6e 63 75 (> (- max-concu
4930: 72 72 65 6e 74 2d 6a 6f 62 73 20 6e 75 6d 2d 72 rrent-jobs num-r
4940: 75 6e 6e 69 6e 67 29 20 35 29 29 29 0a 09 09 20 unning) 5)))...
4950: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e (debug:print-in
4960: 66 6f 20 34 20 22 50 72 65 2d 72 65 67 69 73 74 fo 4 "Pre-regist
4970: 65 72 69 6e 67 20 74 65 73 74 20 22 20 74 65 73 ering test " tes
4980: 74 2d 6e 61 6d 65 20 22 2f 22 20 69 74 65 6d 2d t-name "/" item-
4990: 70 61 74 68 20 22 20 74 6f 20 63 72 65 61 74 65 path " to create
49a0: 20 70 6c 61 63 65 68 6f 6c 64 65 72 22 20 29 0a placeholder" ).
49b0: 09 09 20 20 28 6f 70 65 6e 2d 72 75 6e 2d 63 6c .. (open-run-cl
49c0: 6f 73 65 20 64 62 3a 74 65 73 74 73 2d 72 65 67 ose db:tests-reg
49d0: 69 73 74 65 72 2d 74 65 73 74 20 23 66 20 72 75 ister-test #f ru
49e0: 6e 2d 69 64 20 74 65 73 74 2d 6e 61 6d 65 20 69 n-id test-name i
49f0: 74 65 6d 2d 70 61 74 68 29 0a 09 09 20 20 28 68 tem-path)... (h
4a00: 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 74 ash-table-set! t
4a10: 65 73 74 2d 72 65 67 69 73 74 65 72 79 20 28 72 est-registery (r
4a20: 75 6e 73 3a 6d 61 6b 65 2d 66 75 6c 6c 2d 74 65 uns:make-full-te
4a30: 73 74 2d 6e 61 6d 65 20 74 65 73 74 2d 6e 61 6d st-name test-nam
4a40: 65 20 69 74 65 6d 2d 70 61 74 68 29 20 23 74 29 e item-path) #t)
4a50: 0a 09 09 20 20 3b 3b 20 28 74 68 72 65 61 64 2d ... ;; (thread-
4a60: 73 6c 65 65 70 21 20 2a 67 6c 6f 62 61 6c 2d 64 sleep! *global-d
4a70: 65 6c 74 61 2a 29 0a 28 72 75 6e 73 3a 73 68 72 elta*).(runs:shr
4a80: 69 6e 6b 2d 63 61 6e 2d 72 75 6e 2d 6d 6f 72 65 ink-can-run-more
4a90: 2d 74 65 73 74 73 2d 64 65 6c 61 79 29 0a 09 09 -tests-delay)...
4aa0: 20 20 28 6c 6f 6f 70 20 28 63 61 72 20 6e 65 77 (loop (car new
4ab0: 74 61 6c 29 28 63 64 72 20 6e 65 77 74 61 6c 29 tal)(cdr newtal)
4ac0: 20 72 65 72 75 6e 73 29 29 0a 09 09 20 28 28 6e reruns))... ((n
4ad0: 6f 74 20 68 61 76 65 2d 72 65 73 6f 75 72 63 65 ot have-resource
4ae0: 73 29 20 3b 3b 20 73 69 6d 70 6c 79 20 74 72 79 s) ;; simply try
4af0: 20 61 67 61 69 6e 20 61 66 74 65 72 20 77 61 69 again after wai
4b00: 74 69 6e 67 20 61 20 73 65 63 6f 6e 64 0a 09 09 ting a second...
4b10: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 (debug:print-i
4b20: 6e 66 6f 20 31 20 22 6e 6f 20 72 65 73 6f 75 72 nfo 1 "no resour
4b30: 63 65 73 20 74 6f 20 72 75 6e 20 6e 65 77 20 74 ces to run new t
4b40: 65 73 74 73 2c 20 77 61 69 74 69 6e 67 20 2e 2e ests, waiting ..
4b50: 2e 22 29 0a 09 09 20 20 3b 3b 20 28 74 68 72 65 .")... ;; (thre
4b60: 61 64 2d 73 6c 65 65 70 21 20 28 2b 20 32 20 2a ad-sleep! (+ 2 *
4b70: 67 6c 6f 62 61 6c 2d 64 65 6c 74 61 2a 29 29 0a global-delta*)).
4b80: 09 09 20 20 3b 3b 20 63 6f 75 6c 64 20 68 61 76 .. ;; could hav
4b90: 65 20 64 6f 6e 65 20 68 65 64 20 74 61 6c 20 68 e done hed tal h
4ba0: 65 72 65 20 62 75 74 20 64 6f 69 6e 67 20 63 61 ere but doing ca
4bb0: 72 2f 63 64 72 20 6f 66 20 6e 65 77 74 61 6c 20 r/cdr of newtal
4bc0: 74 6f 20 72 6f 74 61 74 65 20 74 65 73 74 73 0a to rotate tests.
4bd0: 09 09 20 20 28 6c 6f 6f 70 20 28 63 61 72 20 6e .. (loop (car n
4be0: 65 77 74 61 6c 29 28 63 64 72 20 6e 65 77 74 61 ewtal)(cdr newta
4bf0: 6c 29 20 72 65 72 75 6e 73 29 29 0a 09 09 20 28 l) reruns))... (
4c00: 28 61 6e 64 20 68 61 76 65 2d 72 65 73 6f 75 72 (and have-resour
4c10: 63 65 73 0a 09 09 20 20 20 20 20 20 20 28 6f 72 ces... (or
4c20: 20 28 6e 75 6c 6c 3f 20 70 72 65 72 65 71 73 2d (null? prereqs-
4c30: 6e 6f 74 2d 6d 65 74 29 0a 09 09 09 20 20 20 28 not-met).... (
4c40: 61 6e 64 20 28 65 71 3f 20 74 65 73 74 6d 6f 64 and (eq? testmod
4c50: 65 20 27 74 6f 70 6c 65 76 65 6c 29 0a 09 09 09 e 'toplevel)....
4c60: 09 28 6e 75 6c 6c 3f 20 6e 6f 6e 2d 63 6f 6d 70 .(null? non-comp
4c70: 6c 65 74 65 64 29 29 29 29 0a 09 09 20 20 28 72 leted))))... (r
4c80: 75 6e 3a 74 65 73 74 20 72 75 6e 2d 69 64 20 72 un:test run-id r
4c90: 75 6e 6e 61 6d 65 20 6b 65 79 76 61 6c 6c 73 74 unname keyvallst
4ca0: 20 74 65 73 74 2d 72 65 63 6f 72 64 20 66 6c 61 test-record fla
4cb0: 67 73 20 23 66 29 0a 28 72 75 6e 73 3a 73 68 72 gs #f).(runs:shr
4cc0: 69 6e 6b 2d 63 61 6e 2d 72 75 6e 2d 6d 6f 72 65 ink-can-run-more
4cd0: 2d 74 65 73 74 73 2d 64 65 6c 61 79 29 0a 09 09 -tests-delay)...
4ce0: 20 20 3b 3b 20 28 74 68 72 65 61 64 2d 73 6c 65 ;; (thread-sle
4cf0: 65 70 21 20 2a 67 6c 6f 62 61 6c 2d 64 65 6c 74 ep! *global-delt
4d00: 61 2a 29 0a 09 09 20 20 28 69 66 20 28 6e 6f 74 a*)... (if (not
4d10: 20 28 6e 75 6c 6c 3f 20 74 61 6c 29 29 0a 09 09 (null? tal))...
4d20: 20 20 20 20 20 20 28 6c 6f 6f 70 20 28 63 61 72 (loop (car
4d30: 20 74 61 6c 29 28 63 64 72 20 74 61 6c 29 20 72 tal)(cdr tal) r
4d40: 65 72 75 6e 73 29 29 29 0a 09 09 20 28 65 6c 73 eruns)))... (els
4d50: 65 20 3b 3b 20 6d 75 73 74 20 62 65 20 77 65 20 e ;; must be we
4d60: 68 61 76 65 20 75 6e 6d 65 74 20 70 72 65 72 65 have unmet prere
4d70: 71 75 69 73 69 74 65 73 0a 09 09 20 20 20 20 28 quisites... (
4d80: 64 65 62 75 67 3a 70 72 69 6e 74 20 34 20 22 46 debug:print 4 "F
4d90: 41 49 4c 53 3a 20 22 20 66 61 69 6c 73 29 0a 09 AILS: " fails)..
4da0: 09 20 20 20 20 3b 3b 20 49 66 20 6f 6e 65 20 6f . ;; If one o
4db0: 72 20 6d 6f 72 65 20 6f 66 20 74 68 65 20 70 72 r more of the pr
4dc0: 65 72 65 71 73 2d 6e 6f 74 2d 6d 65 74 20 61 72 ereqs-not-met ar
4dd0: 65 20 46 41 49 4c 20 74 68 65 6e 20 77 65 20 63 e FAIL then we c
4de0: 61 6e 20 69 73 73 75 65 0a 09 09 20 20 20 20 3b an issue... ;
4df0: 3b 20 61 20 6d 65 73 73 61 67 65 20 61 6e 64 20 ; a message and
4e00: 64 72 6f 70 20 68 65 64 20 66 72 6f 6d 20 74 68 drop hed from th
4e10: 65 20 69 74 65 6d 73 20 74 6f 20 62 65 20 70 72 e items to be pr
4e20: 6f 63 65 73 73 65 64 2e 0a 09 09 20 20 20 20 28 ocessed.... (
4e30: 69 66 20 28 6e 75 6c 6c 3f 20 66 61 69 6c 73 29 if (null? fails)
4e40: 0a 09 09 09 28 62 65 67 69 6e 0a 09 09 09 20 20 ....(begin....
4e50: 3b 3b 20 63 6f 75 6c 64 6e 27 74 20 72 75 6e 2c ;; couldn't run,
4e60: 20 74 61 6b 65 20 61 20 62 72 65 61 74 68 65 72 take a breather
4e70: 0a 09 09 09 20 20 28 64 65 62 75 67 3a 70 72 69 .... (debug:pri
4e80: 6e 74 2d 69 6e 66 6f 20 34 20 22 53 68 6f 75 6c nt-info 4 "Shoul
4e90: 64 6e 27 74 20 72 65 61 6c 6c 79 20 67 65 74 20 dn't really get
4ea0: 68 65 72 65 2c 20 72 61 63 65 20 63 6f 6e 64 69 here, race condi
4eb0: 74 69 6f 6e 3f 20 55 6e 61 62 6c 65 20 74 6f 20 tion? Unable to
4ec0: 6c 61 75 6e 63 68 20 6d 6f 72 65 20 74 65 73 74 launch more test
4ed0: 73 20 61 74 20 74 68 69 73 20 6d 6f 6d 65 6e 74 s at this moment
4ee0: 2c 20 6b 69 6c 6c 69 6e 67 20 74 69 6d 65 20 2e , killing time .
4ef0: 2e 2e 22 29 0a 09 09 09 20 20 3b 3b 20 28 74 68 ..").... ;; (th
4f00: 72 65 61 64 2d 73 6c 65 65 70 21 20 28 2b 20 30 read-sleep! (+ 0
4f10: 2e 30 31 20 2a 67 6c 6f 62 61 6c 2d 64 65 6c 74 .01 *global-delt
4f20: 61 2a 29 29 20 3b 3b 20 6c 6f 6e 67 20 73 6c 65 a*)) ;; long sle
4f30: 65 70 20 68 65 72 65 20 2d 20 6e 6f 20 72 65 73 ep here - no res
4f40: 6f 75 72 63 65 73 2c 20 6d 61 79 20 61 73 20 77 ources, may as w
4f50: 65 6c 6c 20 62 65 20 70 61 74 69 65 6e 74 0a 09 ell be patient..
4f60: 09 09 20 20 3b 3b 20 77 65 20 6d 61 64 65 20 6e .. ;; we made n
4f70: 65 77 20 74 61 6c 20 62 79 20 73 74 69 63 6b 69 ew tal by sticki
4f80: 6e 67 20 68 65 64 20 61 74 20 74 68 65 20 62 61 ng hed at the ba
4f90: 63 6b 20 6f 66 20 74 68 65 20 6c 69 73 74 0a 09 ck of the list..
4fa0: 09 09 20 20 28 6c 6f 6f 70 20 28 63 61 72 20 6e .. (loop (car n
4fb0: 65 77 74 61 6c 29 28 63 64 72 20 6e 65 77 74 61 ewtal)(cdr newta
4fc0: 6c 29 20 72 65 72 75 6e 73 29 29 0a 09 09 09 3b l) reruns))....;
4fd0: 3b 20 74 68 65 20 77 61 69 74 6f 6e 20 69 73 20 ; the waiton is
4fe0: 46 41 49 4c 20 73 6f 20 6e 6f 20 70 6f 69 6e 74 FAIL so no point
4ff0: 20 69 6e 20 74 72 79 69 6e 67 20 74 6f 20 72 75 in trying to ru
5000: 6e 20 68 65 64 20 65 76 65 72 20 61 67 61 69 6e n hed ever again
5010: 0a 09 09 09 28 69 66 20 28 6e 6f 74 20 28 6e 75 ....(if (not (nu
5020: 6c 6c 3f 20 74 61 6c 29 29 0a 09 09 09 20 20 20 ll? tal))....
5030: 20 28 69 66 20 28 76 65 63 74 6f 72 3f 20 68 65 (if (vector? he
5040: 64 29 0a 09 09 09 09 28 62 65 67 69 6e 20 28 64 d).....(begin (d
5050: 65 62 75 67 3a 70 72 69 6e 74 20 31 20 22 57 41 ebug:print 1 "WA
5060: 52 4e 3a 20 44 72 6f 70 70 69 6e 67 20 74 65 73 RN: Dropping tes
5070: 74 20 22 20 28 64 62 3a 74 65 73 74 2d 67 65 74 t " (db:test-get
5080: 2d 74 65 73 74 6e 61 6d 65 20 68 65 64 29 20 22 -testname hed) "
5090: 2f 22 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d /" (db:test-get-
50a0: 69 74 65 6d 2d 70 61 74 68 20 68 65 64 29 0a 09 item-path hed)..
50b0: 09 09 09 09 09 20 20 20 20 22 20 66 72 6f 6d 20 ..... " from
50c0: 74 68 65 20 6c 61 75 6e 63 68 20 6c 69 73 74 20 the launch list
50d0: 61 73 20 69 74 20 68 61 73 20 70 72 65 72 65 71 as it has prereq
50e0: 75 69 73 74 65 73 20 74 68 61 74 20 61 72 65 20 uistes that are
50f0: 46 41 49 4c 22 29 0a 28 72 75 6e 73 3a 73 68 72 FAIL").(runs:shr
5100: 69 6e 6b 2d 63 61 6e 2d 72 75 6e 2d 6d 6f 72 65 ink-can-run-more
5110: 2d 74 65 73 74 73 2d 64 65 6c 61 79 29 0a 09 09 -tests-delay)...
5120: 09 09 20 20 20 20 20 20 20 3b 3b 20 28 74 68 72 .. ;; (thr
5130: 65 61 64 2d 73 6c 65 65 70 21 20 2a 67 6c 6f 62 ead-sleep! *glob
5140: 61 6c 2d 64 65 6c 74 61 2a 29 0a 09 09 09 09 20 al-delta*).....
5150: 20 20 20 20 20 20 28 6c 6f 6f 70 20 28 63 61 72 (loop (car
5160: 20 74 61 6c 29 28 63 64 72 20 74 61 6c 29 20 28 tal)(cdr tal) (
5170: 63 6f 6e 73 20 68 65 64 20 72 65 72 75 6e 73 29 cons hed reruns)
5180: 29 29 0a 09 09 09 09 28 62 65 67 69 6e 0a 09 09 )).....(begin...
5190: 09 09 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 .. (debug:print
51a0: 20 31 20 22 57 41 52 4e 3a 20 54 65 73 74 20 6e 1 "WARN: Test n
51b0: 6f 74 20 70 72 6f 63 65 73 73 65 64 20 63 6f 72 ot processed cor
51c0: 72 65 63 74 6c 79 2e 20 43 6f 75 6c 64 20 62 65 rectly. Could be
51d0: 20 61 20 72 61 63 65 20 63 6f 6e 64 69 74 69 6f a race conditio
51e0: 6e 20 69 6e 20 79 6f 75 72 20 74 65 73 74 20 69 n in your test i
51f0: 6d 70 6c 65 6d 65 6e 74 61 74 69 6f 6e 3f 20 22 mplementation? "
5200: 20 68 65 64 29 20 3b 3b 20 20 22 20 61 73 20 69 hed) ;; " as i
5210: 74 20 68 61 73 20 70 72 65 72 65 71 75 69 73 74 t has prerequist
5220: 65 73 20 74 68 61 74 20 61 72 65 20 46 41 49 4c es that are FAIL
5230: 2e 20 28 4e 4f 54 45 3a 20 68 65 64 20 69 73 20 . (NOTE: hed is
5240: 6e 6f 74 20 61 20 76 65 63 74 6f 72 29 22 29 0a not a vector)").
5250: 28 72 75 6e 73 3a 73 68 72 69 6e 6b 2d 63 61 6e (runs:shrink-can
5260: 2d 72 75 6e 2d 6d 6f 72 65 2d 74 65 73 74 73 2d -run-more-tests-
5270: 64 65 6c 61 79 29 0a 09 09 09 09 20 20 3b 3b 20 delay)..... ;;
5280: 28 74 68 72 65 61 64 2d 73 6c 65 65 70 21 20 28 (thread-sleep! (
5290: 2b 20 30 2e 30 31 20 2a 67 6c 6f 62 61 6c 2d 64 + 0.01 *global-d
52a0: 65 6c 74 61 2a 29 29 0a 09 09 09 09 20 20 28 6c elta*))..... (l
52b0: 6f 6f 70 20 68 65 64 20 74 61 6c 20 72 65 72 75 oop hed tal reru
52c0: 6e 73 29 29 29 29 29 29 29 29 29 20 3b 3b 20 45 ns))))))))) ;; E
52d0: 4e 44 20 4f 46 20 49 4e 4e 45 52 20 43 4f 4e 44 ND OF INNER COND
52e0: 0a 09 20 20 20 20 20 0a 09 20 20 20 20 20 3b 3b .. .. ;;
52f0: 20 63 61 73 65 20 77 68 65 72 65 20 61 6e 20 69 case where an i
5300: 74 65 6d 73 20 63 61 6d 65 20 69 6e 20 61 73 20 tems came in as
5310: 61 20 6c 69 73 74 20 62 65 65 6e 20 70 72 6f 63 a list been proc
5320: 65 73 73 65 64 0a 09 20 20 20 20 20 28 28 61 6e essed.. ((an
5330: 64 20 28 6c 69 73 74 3f 20 69 74 65 6d 73 29 20 d (list? items)
5340: 20 20 20 20 3b 3b 20 74 68 75 73 20 77 65 20 6b ;; thus we k
5350: 6e 6f 77 20 6f 75 72 20 69 74 65 6d 73 20 61 72 now our items ar
5360: 65 20 61 6c 72 65 61 64 79 20 63 61 6c 63 75 6c e already calcul
5370: 61 74 65 64 0a 09 09 20 20 20 28 6e 6f 74 20 20 ated... (not
5380: 20 69 74 65 6d 64 61 74 29 29 20 3b 3b 20 61 6e itemdat)) ;; an
5390: 64 20 6e 6f 74 20 79 65 74 20 65 78 70 61 6e 64 d not yet expand
53a0: 65 64 20 69 6e 74 6f 20 74 68 65 20 6c 69 73 74 ed into the list
53b0: 20 6f 66 20 74 68 69 6e 67 73 20 74 6f 20 62 65 of things to be
53c0: 20 64 6f 6e 65 0a 09 20 20 20 20 20 20 28 69 66 done.. (if
53d0: 20 28 61 6e 64 20 28 64 65 62 75 67 3a 64 65 62 (and (debug:deb
53e0: 75 67 2d 6d 6f 64 65 20 31 29 20 3b 3b 20 28 3e ug-mode 1) ;; (>
53f0: 3d 20 2a 76 65 72 62 6f 73 69 74 79 2a 20 31 29 = *verbosity* 1)
5400: 0a 09 09 20 20 20 20 20 20 20 28 3e 20 28 6c 65 ... (> (le
5410: 6e 67 74 68 20 69 74 65 6d 73 29 20 30 29 0a 09 ngth items) 0)..
5420: 09 20 20 20 20 20 20 20 28 3e 20 28 6c 65 6e 67 . (> (leng
5430: 74 68 20 28 63 61 72 20 69 74 65 6d 73 29 29 20 th (car items))
5440: 30 29 29 0a 09 09 20 20 28 70 70 20 69 74 65 6d 0))... (pp item
5450: 73 29 29 0a 09 20 20 20 20 20 20 28 66 6f 72 2d s)).. (for-
5460: 65 61 63 68 0a 09 20 20 20 20 20 20 20 28 6c 61 each.. (la
5470: 6d 62 64 61 20 28 6d 79 2d 69 74 65 6d 64 61 74 mbda (my-itemdat
5480: 29 0a 09 09 20 28 6c 65 74 2a 20 28 28 6e 65 77 )... (let* ((new
5490: 2d 74 65 73 74 2d 72 65 63 6f 72 64 20 28 6c 65 -test-record (le
54a0: 74 20 28 28 6e 65 77 72 65 63 20 28 6d 61 6b 65 t ((newrec (make
54b0: 2d 74 65 73 74 73 3a 74 65 73 74 71 75 65 75 65 -tests:testqueue
54c0: 29 29 29 0a 09 09 09 09 09 20 20 20 28 76 65 63 )))...... (vec
54d0: 74 6f 72 2d 63 6f 70 79 21 20 74 65 73 74 2d 72 tor-copy! test-r
54e0: 65 63 6f 72 64 20 6e 65 77 72 65 63 29 0a 09 09 ecord newrec)...
54f0: 09 09 09 20 20 20 6e 65 77 72 65 63 29 29 0a 09 ... newrec))..
5500: 09 09 28 6d 79 2d 69 74 65 6d 2d 70 61 74 68 20 ..(my-item-path
5510: 28 69 74 65 6d 2d 6c 69 73 74 2d 3e 70 61 74 68 (item-list->path
5520: 20 6d 79 2d 69 74 65 6d 64 61 74 29 29 29 0a 09 my-itemdat)))..
5530: 09 20 20 20 28 69 66 20 28 74 65 73 74 73 3a 6d . (if (tests:m
5540: 61 74 63 68 20 74 65 73 74 2d 70 61 74 74 73 20 atch test-patts
5550: 68 65 64 20 6d 79 2d 69 74 65 6d 2d 70 61 74 68 hed my-item-path
5560: 29 20 3b 3b 20 28 70 61 74 74 2d 6c 69 73 74 2d ) ;; (patt-list-
5570: 6d 61 74 63 68 20 6d 79 2d 69 74 65 6d 2d 70 61 match my-item-pa
5580: 74 68 20 69 74 65 6d 2d 70 61 74 74 73 29 20 20 th item-patts)
5590: 20 20 20 20 20 20 20 20 20 3b 3b 20 79 65 73 2c ;; yes,
55a0: 20 77 65 20 77 61 6e 74 20 74 6f 20 70 72 6f 63 we want to proc
55b0: 65 73 73 20 74 68 69 73 20 69 74 65 6d 2c 20 4e ess this item, N
55c0: 4f 54 45 3a 20 53 68 6f 75 6c 64 20 6e 6f 74 20 OTE: Should not
55d0: 6e 65 65 64 20 74 68 69 73 20 63 68 65 63 6b 20 need this check
55e0: 68 65 72 65 21 0a 09 09 20 20 20 20 20 20 20 28 here!... (
55f0: 6c 65 74 20 28 28 6e 65 77 74 65 73 74 6e 61 6d let ((newtestnam
5600: 65 20 28 72 75 6e 73 3a 6d 61 6b 65 2d 66 75 6c e (runs:make-ful
5610: 6c 2d 74 65 73 74 2d 6e 61 6d 65 20 68 65 64 20 l-test-name hed
5620: 6d 79 2d 69 74 65 6d 2d 70 61 74 68 29 29 29 20 my-item-path)))
5630: 20 20 20 3b 3b 20 74 65 73 74 20 6e 61 6d 65 73 ;; test names
5640: 20 61 72 65 20 75 6e 69 71 75 65 20 6f 6e 20 74 are unique on t
5650: 65 73 74 6e 61 6d 65 2f 69 74 65 6d 2d 70 61 74 estname/item-pat
5660: 68 0a 09 09 09 20 28 74 65 73 74 73 3a 74 65 73 h.... (tests:tes
5670: 74 71 75 65 75 65 2d 73 65 74 2d 69 74 65 6d 73 tqueue-set-items
5680: 21 20 20 20 20 20 6e 65 77 2d 74 65 73 74 2d 72 ! new-test-r
5690: 65 63 6f 72 64 20 23 66 29 0a 09 09 09 20 28 74 ecord #f).... (t
56a0: 65 73 74 73 3a 74 65 73 74 71 75 65 75 65 2d 73 ests:testqueue-s
56b0: 65 74 2d 69 74 65 6d 64 61 74 21 20 20 20 6e 65 et-itemdat! ne
56c0: 77 2d 74 65 73 74 2d 72 65 63 6f 72 64 20 6d 79 w-test-record my
56d0: 2d 69 74 65 6d 64 61 74 29 0a 09 09 09 20 28 74 -itemdat).... (t
56e0: 65 73 74 73 3a 74 65 73 74 71 75 65 75 65 2d 73 ests:testqueue-s
56f0: 65 74 2d 69 74 65 6d 5f 70 61 74 68 21 20 6e 65 et-item_path! ne
5700: 77 2d 74 65 73 74 2d 72 65 63 6f 72 64 20 6d 79 w-test-record my
5710: 2d 69 74 65 6d 2d 70 61 74 68 29 0a 09 09 09 20 -item-path)....
5720: 28 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 (hash-table-set!
5730: 20 74 65 73 74 2d 72 65 63 6f 72 64 73 20 6e 65 test-records ne
5740: 77 74 65 73 74 6e 61 6d 65 20 6e 65 77 2d 74 65 wtestname new-te
5750: 73 74 2d 72 65 63 6f 72 64 29 0a 09 09 09 20 28 st-record).... (
5760: 73 65 74 21 20 74 61 6c 20 28 63 6f 6e 73 20 6e set! tal (cons n
5770: 65 77 74 65 73 74 6e 61 6d 65 20 74 61 6c 29 29 ewtestname tal))
5780: 29 29 29 29 20 3b 3b 20 73 69 6e 63 65 20 74 68 )))) ;; since th
5790: 65 73 65 20 61 72 65 20 69 74 65 6d 69 7a 65 64 ese are itemized
57a0: 20 63 72 65 61 74 65 20 6e 65 77 20 74 65 73 74 create new test
57b0: 20 6e 61 6d 65 73 20 74 65 73 74 6e 61 6d 65 2f names testname/
57c0: 69 74 65 6d 70 61 74 68 0a 09 20 20 20 20 20 20 itempath..
57d0: 20 69 74 65 6d 73 29 0a 09 20 20 20 20 20 20 28 items).. (
57e0: 69 66 20 28 6e 6f 74 20 28 6e 75 6c 6c 3f 20 74 if (not (null? t
57f0: 61 6c 29 29 0a 09 09 20 20 28 62 65 67 69 6e 0a al))... (begin.
5800: 09 09 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 .. (debug:pri
5810: 6e 74 2d 69 6e 66 6f 20 34 20 22 45 6e 64 20 6f nt-info 4 "End o
5820: 66 20 69 74 65 6d 73 20 6c 69 73 74 2c 20 6c 6f f items list, lo
5830: 6f 70 69 6e 67 20 77 69 74 68 20 6e 65 78 74 20 oping with next
5840: 61 66 74 65 72 20 73 68 6f 72 74 20 64 65 6c 61 after short dela
5850: 79 22 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 y").
5860: 20 20 20 20 20 20 20 20 3b 3b 20 28 74 68 72 65 ;; (thre
5870: 61 64 2d 73 6c 65 65 70 21 20 28 2b 20 30 2e 30 ad-sleep! (+ 0.0
5880: 31 20 2a 67 6c 6f 62 61 6c 2d 64 65 6c 74 61 2a 1 *global-delta*
5890: 29 29 0a 09 09 20 20 20 20 28 6c 6f 6f 70 20 28 ))... (loop (
58a0: 63 61 72 20 74 61 6c 29 28 63 64 72 20 74 61 6c car tal)(cdr tal
58b0: 29 20 72 65 72 75 6e 73 29 29 29 29 0a 0a 09 20 ) reruns))))...
58c0: 20 20 20 20 3b 3b 20 69 66 20 69 74 65 6d 73 20 ;; if items
58d0: 69 73 20 61 20 70 72 6f 63 20 74 68 65 6e 20 6e is a proc then n
58e0: 65 65 64 20 74 6f 20 72 75 6e 20 69 74 65 6d 73 eed to run items
58f0: 3a 67 65 74 2d 69 74 65 6d 73 2d 66 72 6f 6d 2d :get-items-from-
5900: 63 6f 6e 66 69 67 2c 20 67 65 74 20 74 68 65 20 config, get the
5910: 6c 69 73 74 20 61 6e 64 20 6c 6f 6f 70 20 0a 09 list and loop ..
5920: 20 20 20 20 20 3b 3b 20 20 20 20 2d 20 62 75 74 ;; - but
5930: 20 6f 6e 6c 79 20 64 6f 20 74 68 61 74 20 69 66 only do that if
5940: 20 72 65 73 6f 75 72 63 65 73 20 65 78 69 73 74 resources exist
5950: 20 74 6f 20 6b 69 63 6b 20 6f 66 66 20 74 68 65 to kick off the
5960: 20 6a 6f 62 0a 09 20 20 20 20 20 28 28 6f 72 20 job.. ((or
5970: 28 70 72 6f 63 65 64 75 72 65 3f 20 69 74 65 6d (procedure? item
5980: 73 29 28 65 71 3f 20 69 74 65 6d 73 20 27 68 61 s)(eq? items 'ha
5990: 76 65 2d 70 72 6f 63 65 64 75 72 65 29 29 0a 09 ve-procedure))..
59a0: 20 20 20 20 20 20 28 6c 65 74 20 28 28 63 61 6e (let ((can
59b0: 2d 72 75 6e 2d 6d 6f 72 65 20 20 20 20 28 72 75 -run-more (ru
59c0: 6e 73 3a 63 61 6e 2d 72 75 6e 2d 6d 6f 72 65 2d ns:can-run-more-
59d0: 74 65 73 74 73 20 74 65 73 74 2d 72 65 63 6f 72 tests test-recor
59e0: 64 29 29 29 0a 09 09 28 69 66 20 28 61 6e 64 20 d)))...(if (and
59f0: 28 6c 69 73 74 3f 20 63 61 6e 2d 72 75 6e 2d 6d (list? can-run-m
5a00: 6f 72 65 29 0a 09 09 09 20 28 63 61 72 20 63 61 ore).... (car ca
5a10: 6e 2d 72 75 6e 2d 6d 6f 72 65 29 29 0a 09 09 20 n-run-more))...
5a20: 20 20 20 28 6c 65 74 2a 20 28 28 70 72 65 72 65 (let* ((prere
5a30: 71 73 2d 6e 6f 74 2d 6d 65 74 20 28 6f 70 65 6e qs-not-met (open
5a40: 2d 72 75 6e 2d 63 6c 6f 73 65 20 64 62 3a 67 65 -run-close db:ge
5a50: 74 2d 70 72 65 72 65 71 73 2d 6e 6f 74 2d 6d 65 t-prereqs-not-me
5a60: 74 20 23 66 20 72 75 6e 2d 69 64 20 77 61 69 74 t #f run-id wait
5a70: 6f 6e 73 20 69 74 65 6d 2d 70 61 74 68 20 6d 6f ons item-path mo
5a80: 64 65 3a 20 74 65 73 74 6d 6f 64 65 29 29 0a 09 de: testmode))..
5a90: 09 09 20 20 20 28 66 61 69 6c 73 20 20 20 20 20 .. (fails
5aa0: 20 20 20 20 20 20 28 72 75 6e 73 3a 63 61 6c 63 (runs:calc
5ab0: 2d 66 61 69 6c 73 20 70 72 65 72 65 71 73 2d 6e -fails prereqs-n
5ac0: 6f 74 2d 6d 65 74 29 29 0a 09 09 09 20 20 20 28 ot-met)).... (
5ad0: 6e 6f 6e 2d 63 6f 6d 70 6c 65 74 65 64 20 20 20 non-completed
5ae0: 28 72 75 6e 73 3a 63 61 6c 63 2d 6e 6f 74 2d 63 (runs:calc-not-c
5af0: 6f 6d 70 6c 65 74 65 64 20 70 72 65 72 65 71 73 ompleted prereqs
5b00: 2d 6e 6f 74 2d 6d 65 74 29 29 29 0a 09 09 20 20 -not-met)))...
5b10: 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 (debug:print
5b20: 2d 69 6e 66 6f 20 38 20 22 63 61 6e 2d 72 75 6e -info 8 "can-run
5b30: 2d 6d 6f 72 65 3a 20 22 20 63 61 6e 2d 72 75 6e -more: " can-run
5b40: 2d 6d 6f 72 65 0a 09 09 09 09 20 20 20 22 5c 6e -more..... "\n
5b50: 20 74 65 73 74 6e 61 6d 65 3a 20 20 20 20 20 20 testname:
5b60: 20 20 22 20 68 65 64 0a 09 09 09 09 20 20 20 22 " hed..... "
5b70: 5c 6e 20 70 72 65 72 65 71 73 2d 6e 6f 74 2d 6d \n prereqs-not-m
5b80: 65 74 3a 20 22 20 28 72 75 6e 73 3a 70 72 65 74 et: " (runs:pret
5b90: 74 79 2d 73 74 72 69 6e 67 20 70 72 65 72 65 71 ty-string prereq
5ba0: 73 2d 6e 6f 74 2d 6d 65 74 29 0a 09 09 09 09 20 s-not-met).....
5bb0: 20 20 22 5c 6e 20 6e 6f 6e 2d 63 6f 6d 70 6c 65 "\n non-comple
5bc0: 74 65 64 3a 20 20 20 22 20 28 72 75 6e 73 3a 70 ted: " (runs:p
5bd0: 72 65 74 74 79 2d 73 74 72 69 6e 67 20 6e 6f 6e retty-string non
5be0: 2d 63 6f 6d 70 6c 65 74 65 64 29 20 0a 09 09 09 -completed) ....
5bf0: 09 20 20 20 22 5c 6e 20 66 61 69 6c 73 3a 20 20 . "\n fails:
5c00: 20 20 20 20 20 20 20 20 20 22 20 28 72 75 6e 73 " (runs
5c10: 3a 70 72 65 74 74 79 2d 73 74 72 69 6e 67 20 66 :pretty-string f
5c20: 61 69 6c 73 29 0a 09 09 09 09 20 20 20 22 5c 6e ails)..... "\n
5c30: 20 74 65 73 74 6d 6f 64 65 3a 20 20 20 20 20 20 testmode:
5c40: 20 20 22 20 74 65 73 74 6d 6f 64 65 0a 09 09 09 " testmode....
5c50: 09 20 20 20 22 5c 6e 20 6e 75 6d 2d 72 65 74 72 . "\n num-retr
5c60: 69 65 73 3a 20 20 20 20 20 22 20 6e 75 6d 2d 72 ies: " num-r
5c70: 65 74 72 69 65 73 0a 09 09 09 09 20 20 20 22 5c etries..... "\
5c80: 6e 20 28 65 71 3f 20 74 65 73 74 6d 6f 64 65 20 n (eq? testmode
5c90: 27 74 6f 70 6c 65 76 65 6c 29 3a 20 22 20 28 65 'toplevel): " (e
5ca0: 71 3f 20 74 65 73 74 6d 6f 64 65 20 27 74 6f 70 q? testmode 'top
5cb0: 6c 65 76 65 6c 29 0a 09 09 09 09 20 20 20 22 5c level)..... "\
5cc0: 6e 20 28 6e 75 6c 6c 3f 20 6e 6f 6e 2d 63 6f 6d n (null? non-com
5cd0: 70 6c 65 74 65 64 29 3a 20 20 20 20 22 20 28 6e pleted): " (n
5ce0: 75 6c 6c 3f 20 6e 6f 6e 2d 63 6f 6d 70 6c 65 74 ull? non-complet
5cf0: 65 64 29 0a 09 09 09 09 20 20 20 22 5c 6e 20 72 ed)..... "\n r
5d00: 65 72 75 6e 73 3a 20 20 20 20 20 20 20 20 20 20 eruns:
5d10: 22 20 72 65 72 75 6e 73 0a 09 09 09 09 20 20 20 " reruns.....
5d20: 22 5c 6e 20 69 74 65 6d 73 3a 20 20 20 20 20 20 "\n items:
5d30: 20 20 20 20 20 22 20 69 74 65 6d 73 0a 09 09 09 " items....
5d40: 09 20 20 20 22 5c 6e 20 63 61 6e 2d 72 75 6e 2d . "\n can-run-
5d50: 6d 6f 72 65 3a 20 20 20 20 22 20 63 61 6e 2d 72 more: " can-r
5d60: 75 6e 2d 6d 6f 72 65 29 0a 09 09 20 20 20 20 20 un-more)...
5d70: 20 3b 3b 20 28 74 68 72 65 61 64 2d 73 6c 65 65 ;; (thread-slee
5d80: 70 21 20 28 2b 20 30 2e 30 31 20 2a 67 6c 6f 62 p! (+ 0.01 *glob
5d90: 61 6c 2d 64 65 6c 74 61 2a 29 29 0a 09 09 20 20 al-delta*))...
5da0: 20 20 20 20 28 63 6f 6e 64 20 3b 3b 20 49 4e 4e (cond ;; INN
5db0: 45 52 20 43 4f 4e 44 20 23 32 0a 09 09 20 20 20 ER COND #2...
5dc0: 20 20 20 20 28 28 6f 72 20 28 6e 75 6c 6c 3f 20 ((or (null?
5dd0: 70 72 65 72 65 71 73 2d 6e 6f 74 2d 6d 65 74 29 prereqs-not-met)
5de0: 20 3b 3b 20 61 6c 6c 20 70 72 65 72 65 71 73 20 ;; all prereqs
5df0: 6d 65 74 2c 20 66 69 72 65 20 6f 66 66 20 74 68 met, fire off th
5e00: 65 20 74 65 73 74 0a 09 09 09 20 20 20 20 3b 3b e test.... ;;
5e10: 20 6f 72 2c 20 69 66 20 69 74 20 69 73 20 61 20 or, if it is a
5e20: 27 74 6f 70 6c 65 76 65 6c 20 74 65 73 74 20 61 'toplevel test a
5e30: 6e 64 20 61 6c 6c 20 70 72 65 72 65 71 73 20 6e nd all prereqs n
5e40: 6f 74 20 6d 65 74 20 61 72 65 20 43 4f 4d 50 4c ot met are COMPL
5e50: 45 54 45 44 20 74 68 65 6e 20 6c 61 75 6e 63 68 ETED then launch
5e60: 0a 09 09 09 20 20 20 20 28 61 6e 64 20 28 65 71 .... (and (eq
5e70: 3f 20 74 65 73 74 6d 6f 64 65 20 27 74 6f 70 6c ? testmode 'topl
5e80: 65 76 65 6c 29 0a 09 09 09 09 20 28 6e 75 6c 6c evel)..... (null
5e90: 3f 20 6e 6f 6e 2d 63 6f 6d 70 6c 65 74 65 64 29 ? non-completed)
5ea0: 29 29 0a 09 09 09 28 6c 65 74 20 28 28 74 65 73 ))....(let ((tes
5eb0: 74 2d 6e 61 6d 65 20 28 74 65 73 74 73 3a 74 65 t-name (tests:te
5ec0: 73 74 71 75 65 75 65 2d 67 65 74 2d 74 65 73 74 stqueue-get-test
5ed0: 6e 61 6d 65 20 74 65 73 74 2d 72 65 63 6f 72 64 name test-record
5ee0: 29 29 29 0a 09 09 09 20 20 28 73 65 74 65 6e 76 ))).... (setenv
5ef0: 20 22 4d 54 5f 54 45 53 54 5f 4e 41 4d 45 22 20 "MT_TEST_NAME"
5f00: 74 65 73 74 2d 6e 61 6d 65 29 20 3b 3b 20 0a 09 test-name) ;; ..
5f10: 09 09 20 20 28 73 65 74 65 6e 76 20 22 4d 54 5f .. (setenv "MT_
5f20: 52 55 4e 4e 41 4d 45 22 20 20 20 72 75 6e 6e 61 RUNNAME" runna
5f30: 6d 65 29 0a 09 09 09 20 20 28 73 65 74 2d 6d 65 me).... (set-me
5f40: 67 61 74 65 73 74 2d 65 6e 76 2d 76 61 72 73 20 gatest-env-vars
5f50: 72 75 6e 2d 69 64 29 20 3b 3b 20 74 68 65 73 65 run-id) ;; these
5f60: 20 6d 61 79 20 62 65 20 6e 65 65 64 65 64 20 62 may be needed b
5f70: 79 20 74 68 65 20 6c 61 75 6e 63 68 69 6e 67 20 y the launching
5f80: 70 72 6f 63 65 73 73 0a 09 09 09 20 20 28 6c 65 process.... (le
5f90: 74 20 28 28 69 74 65 6d 73 2d 6c 69 73 74 20 28 t ((items-list (
5fa0: 69 74 65 6d 73 3a 67 65 74 2d 69 74 65 6d 73 2d items:get-items-
5fb0: 66 72 6f 6d 2d 63 6f 6e 66 69 67 20 74 63 6f 6e from-config tcon
5fc0: 66 69 67 29 29 29 0a 09 09 09 20 20 20 20 28 69 fig))).... (i
5fd0: 66 20 28 6c 69 73 74 3f 20 69 74 65 6d 73 2d 6c f (list? items-l
5fe0: 69 73 74 29 0a 09 09 09 09 28 62 65 67 69 6e 0a ist).....(begin.
5ff0: 09 09 09 09 20 20 28 74 65 73 74 73 3a 74 65 73 .... (tests:tes
6000: 74 71 75 65 75 65 2d 73 65 74 2d 69 74 65 6d 73 tqueue-set-items
6010: 21 20 74 65 73 74 2d 72 65 63 6f 72 64 20 69 74 ! test-record it
6020: 65 6d 73 2d 6c 69 73 74 29 0a 09 09 09 09 20 20 ems-list).....
6030: 3b 3b 20 28 74 68 72 65 61 64 2d 73 6c 65 65 70 ;; (thread-sleep
6040: 21 20 2a 67 6c 6f 62 61 6c 2d 64 65 6c 74 61 2a ! *global-delta*
6050: 29 0a 09 09 09 09 20 20 28 6c 6f 6f 70 20 68 65 )..... (loop he
6060: 64 20 74 61 6c 20 72 65 72 75 6e 73 29 29 0a 09 d tal reruns))..
6070: 09 09 09 28 62 65 67 69 6e 0a 09 09 09 09 20 20 ...(begin.....
6080: 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 22 (debug:print 0 "
6090: 45 52 52 4f 52 3a 20 54 68 65 20 70 72 6f 63 20 ERROR: The proc
60a0: 66 72 6f 6d 20 72 65 61 64 69 6e 67 20 74 68 65 from reading the
60b0: 20 73 65 74 75 70 20 64 69 64 20 6e 6f 74 20 79 setup did not y
60c0: 69 65 6c 64 20 61 20 6c 69 73 74 20 2d 20 70 6c ield a list - pl
60d0: 65 61 73 65 20 72 65 70 6f 72 74 20 74 68 69 73 ease report this
60e0: 22 29 0a 09 09 09 09 20 20 28 65 78 69 74 20 31 ")..... (exit 1
60f0: 29 29 29 29 29 29 0a 09 09 20 20 20 20 20 20 20 ))))))...
6100: 28 28 6e 75 6c 6c 3f 20 66 61 69 6c 73 29 0a 09 ((null? fails)..
6110: 09 09 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 ..(debug:print-i
6120: 6e 66 6f 20 34 20 22 66 61 69 6c 73 20 69 73 20 nfo 4 "fails is
6130: 6e 75 6c 6c 2c 20 6d 6f 76 69 6e 67 20 6f 6e 20 null, moving on
6140: 69 6e 20 74 68 65 20 71 75 65 75 65 20 62 75 74 in the queue but
6150: 20 6b 65 65 70 69 6e 67 20 22 20 68 65 64 20 22 keeping " hed "
6160: 20 66 6f 72 20 6e 6f 77 22 29 0a 09 09 09 3b 3b for now")....;;
6170: 20 6f 6e 6c 79 20 69 6e 63 72 65 6d 65 6e 74 20 only increment
6180: 6e 75 6d 2d 72 65 74 72 69 65 73 20 77 68 65 6e num-retries when
6190: 20 74 68 65 72 65 20 61 72 65 20 6e 6f 20 74 65 there are no te
61a0: 73 74 73 20 72 75 6e 69 6e 67 0a 09 09 09 28 69 sts runing....(i
61b0: 66 20 28 65 71 3f 20 30 20 28 6c 69 73 74 2d 72 f (eq? 0 (list-r
61c0: 65 66 20 63 61 6e 2d 72 75 6e 2d 6d 6f 72 65 20 ef can-run-more
61d0: 31 29 29 0a 09 09 09 20 20 20 20 28 62 65 67 69 1)).... (begi
61e0: 6e 0a 09 09 09 20 20 20 20 20 20 28 69 66 20 28 n.... (if (
61f0: 3e 20 6e 75 6d 2d 72 65 74 72 69 65 73 20 31 30 > num-retries 10
6200: 30 29 20 3b 3b 20 66 69 72 73 74 20 31 30 30 20 0) ;; first 100
6210: 72 65 74 72 69 65 73 20 61 72 65 20 6c 6f 77 20 retries are low
6220: 74 69 6d 65 20 63 6f 73 74 0a 09 09 09 09 20 20 time cost.....
6230: 28 74 68 72 65 61 64 2d 73 6c 65 65 70 21 20 28 (thread-sleep! (
6240: 2b 20 32 20 2a 67 6c 6f 62 61 6c 2d 64 65 6c 74 + 2 *global-delt
6250: 61 2a 29 29 0a 09 09 09 09 20 20 28 74 68 72 65 a*))..... (thre
6260: 61 64 2d 73 6c 65 65 70 21 20 28 2b 20 30 2e 30 ad-sleep! (+ 0.0
6270: 31 20 2a 67 6c 6f 62 61 6c 2d 64 65 6c 74 61 2a 1 *global-delta*
6280: 29 29 29 0a 09 09 09 20 20 20 20 20 20 28 73 65 ))).... (se
6290: 74 21 20 6e 75 6d 2d 72 65 74 72 69 65 73 20 28 t! num-retries (
62a0: 2b 20 6e 75 6d 2d 72 65 74 72 69 65 73 20 31 29 + num-retries 1)
62b0: 29 29 29 0a 09 09 09 28 69 66 20 28 3e 20 6e 75 )))....(if (> nu
62c0: 6d 2d 72 65 74 72 69 65 73 20 20 6d 61 78 2d 72 m-retries max-r
62d0: 65 74 72 69 65 73 29 0a 09 09 09 20 20 20 20 28 etries).... (
62e0: 69 66 20 28 6e 6f 74 20 28 6e 75 6c 6c 3f 20 74 if (not (null? t
62f0: 61 6c 29 29 0a 09 09 09 09 28 6c 6f 6f 70 20 28 al)).....(loop (
6300: 63 61 72 20 74 61 6c 29 28 63 64 72 20 74 61 6c car tal)(cdr tal
6310: 29 20 72 65 72 75 6e 73 29 29 0a 09 09 09 20 20 ) reruns))....
6320: 20 20 28 6c 6f 6f 70 20 28 63 61 72 20 6e 65 77 (loop (car new
6330: 74 61 6c 29 28 63 64 72 20 6e 65 77 74 61 6c 29 tal)(cdr newtal)
6340: 20 72 65 72 75 6e 73 29 29 29 20 3b 3b 20 61 6e reruns))) ;; an
6350: 20 69 73 73 75 65 20 77 69 74 68 20 70 72 65 72 issue with prer
6360: 65 71 73 20 6e 6f 74 20 79 65 74 20 6d 65 74 3f eqs not yet met?
6370: 0a 09 09 20 20 20 20 20 20 20 28 28 61 6e 64 20 ... ((and
6380: 28 6e 6f 74 20 28 6e 75 6c 6c 3f 20 66 61 69 6c (not (null? fail
6390: 73 29 29 28 65 71 3f 20 74 65 73 74 6d 6f 64 65 s))(eq? testmode
63a0: 20 27 6e 6f 72 6d 61 6c 29 29 0a 09 09 09 28 64 'normal))....(d
63b0: 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 ebug:print-info
63c0: 31 20 22 74 65 73 74 20 22 20 20 68 65 64 20 22 1 "test " hed "
63d0: 20 28 6d 6f 64 65 3d 22 20 74 65 73 74 6d 6f 64 (mode=" testmod
63e0: 65 20 22 29 20 68 61 73 20 66 61 69 6c 65 64 20 e ") has failed
63f0: 70 72 65 72 65 71 75 69 73 69 74 65 28 73 29 3b prerequisite(s);
6400: 20 22 0a 09 09 09 09 20 20 20 20 20 28 73 74 72 "..... (str
6410: 69 6e 67 2d 69 6e 74 65 72 73 70 65 72 73 65 20 ing-intersperse
6420: 28 6d 61 70 20 28 6c 61 6d 62 64 61 20 28 74 29 (map (lambda (t)
6430: 28 63 6f 6e 63 20 28 64 62 3a 74 65 73 74 2d 67 (conc (db:test-g
6440: 65 74 2d 74 65 73 74 6e 61 6d 65 20 74 29 20 22 et-testname t) "
6450: 3a 22 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d :" (db:test-get-
6460: 73 74 61 74 65 20 74 29 22 2f 22 28 64 62 3a 74 state t)"/"(db:t
6470: 65 73 74 2d 67 65 74 2d 73 74 61 74 75 73 20 74 est-get-status t
6480: 29 29 29 20 66 61 69 6c 73 29 20 22 2c 20 22 29 ))) fails) ", ")
6490: 0a 09 09 09 09 20 20 20 20 20 22 2c 20 72 65 6d ..... ", rem
64a0: 6f 76 69 6e 67 20 69 74 20 66 72 6f 6d 20 74 6f oving it from to
64b0: 2d 64 6f 20 6c 69 73 74 22 29 0a 09 09 09 28 69 -do list")....(i
64c0: 66 20 28 6e 6f 74 20 28 6e 75 6c 6c 3f 20 74 61 f (not (null? ta
64d0: 6c 29 29 0a 09 09 09 20 20 20 20 28 62 65 67 69 l)).... (begi
64e0: 6e 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 n.
64f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
6500: 3b 3b 20 28 74 68 72 65 61 64 2d 73 6c 65 65 70 ;; (thread-sleep
6510: 21 20 2a 67 6c 6f 62 61 6c 2d 64 65 6c 74 61 2a ! *global-delta*
6520: 29 0a 09 09 09 20 20 20 20 20 20 28 6c 6f 6f 70 ).... (loop
6530: 20 28 63 61 72 20 74 61 6c 29 28 63 64 72 20 74 (car tal)(cdr t
6540: 61 6c 29 28 63 6f 6e 73 20 68 65 64 20 72 65 72 al)(cons hed rer
6550: 75 6e 73 29 29 29 29 29 0a 09 09 20 20 20 20 20 uns)))))...
6560: 20 20 28 65 6c 73 65 0a 09 09 09 28 64 65 62 75 (else....(debu
6570: 67 3a 70 72 69 6e 74 20 38 20 22 45 52 52 4f 52 g:print 8 "ERROR
6580: 3a 20 4e 6f 20 68 61 6e 64 6c 65 72 20 66 6f 72 : No handler for
6590: 20 74 68 69 73 20 63 6f 6e 64 69 74 69 6f 6e 2e this condition.
65a0: 22 29 0a 09 09 09 28 74 68 72 65 61 64 2d 73 6c ")....(thread-sl
65b0: 65 65 70 21 20 28 2b 20 31 20 2a 67 6c 6f 62 61 eep! (+ 1 *globa
65c0: 6c 2d 64 65 6c 74 61 2a 29 29 0a 09 09 09 28 6c l-delta*))....(l
65d0: 6f 6f 70 20 28 63 61 72 20 6e 65 77 74 61 6c 29 oop (car newtal)
65e0: 28 63 64 72 20 6e 65 77 74 61 6c 29 20 72 65 72 (cdr newtal) rer
65f0: 75 6e 73 29 29 29 29 20 3b 3b 20 45 4e 44 20 4f uns)))) ;; END O
6600: 46 20 49 46 20 43 41 4e 20 52 55 4e 20 4d 4f 52 F IF CAN RUN MOR
6610: 45 0a 0a 09 09 20 20 20 20 3b 3b 20 69 66 20 63 E.... ;; if c
6620: 61 6e 27 74 20 72 75 6e 20 6d 6f 72 65 20 6a 75 an't run more ju
6630: 73 74 20 6c 6f 6f 70 20 77 69 74 68 20 6e 65 78 st loop with nex
6640: 74 20 70 6f 73 73 69 62 6c 65 20 74 65 73 74 0a t possible test.
6650: 09 09 20 20 20 20 28 62 65 67 69 6e 0a 09 09 20 .. (begin...
6660: 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e (debug:prin
6670: 74 2d 69 6e 66 6f 20 34 20 22 70 72 6f 63 65 73 t-info 4 "proces
6680: 73 69 6e 67 20 74 68 65 20 63 61 73 65 20 77 69 sing the case wi
6690: 74 68 20 61 20 6c 61 6d 62 64 61 20 66 6f 72 20 th a lambda for
66a0: 69 74 65 6d 73 20 6f 72 20 27 68 61 76 65 2d 70 items or 'have-p
66b0: 72 6f 63 65 64 75 72 65 2e 20 4d 6f 76 69 6e 67 rocedure. Moving
66c0: 20 74 68 72 6f 75 67 68 20 74 68 65 20 71 75 65 through the que
66d0: 75 65 20 77 69 74 68 6f 75 74 20 64 72 6f 70 70 ue without dropp
66e0: 69 6e 67 20 22 20 68 65 64 29 0a 09 09 20 20 20 ing " hed)...
66f0: 20 20 20 3b 3b 20 28 74 68 72 65 61 64 2d 73 6c ;; (thread-sl
6700: 65 65 70 21 20 28 2b 20 32 20 2a 67 6c 6f 62 61 eep! (+ 2 *globa
6710: 6c 2d 64 65 6c 74 61 2a 29 29 0a 09 09 20 20 20 l-delta*))...
6720: 20 20 20 28 6c 6f 6f 70 20 28 63 61 72 20 6e 65 (loop (car ne
6730: 77 74 61 6c 29 28 63 64 72 20 6e 65 77 74 61 6c wtal)(cdr newtal
6740: 29 20 72 65 72 75 6e 73 29 29 29 29 29 20 3b 3b ) reruns))))) ;;
6750: 20 45 4e 44 20 4f 46 20 28 6f 72 20 28 70 72 6f END OF (or (pro
6760: 63 65 64 75 72 65 3f 20 69 74 65 6d 73 29 28 65 cedure? items)(e
6770: 71 3f 20 69 74 65 6d 73 20 27 68 61 76 65 2d 70 q? items 'have-p
6780: 72 6f 63 65 64 75 72 65 29 29 0a 09 20 20 20 20 rocedure))..
6790: 20 0a 09 20 20 20 20 20 3b 3b 20 74 68 69 73 20 .. ;; this
67a0: 63 61 73 65 20 73 68 6f 75 6c 64 20 6e 6f 74 20 case should not
67b0: 68 61 70 70 65 6e 2c 20 61 64 64 65 64 20 74 6f happen, added to
67c0: 20 68 65 6c 70 20 63 61 74 63 68 20 61 6e 79 20 help catch any
67d0: 62 75 67 73 0a 09 20 20 20 20 20 28 28 61 6e 64 bugs.. ((and
67e0: 20 28 6c 69 73 74 3f 20 69 74 65 6d 73 29 20 69 (list? items) i
67f0: 74 65 6d 64 61 74 29 0a 09 20 20 20 20 20 20 28 temdat).. (
6800: 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 22 45 debug:print 0 "E
6810: 52 52 4f 52 3a 20 53 68 6f 75 6c 64 20 6e 6f 74 RROR: Should not
6820: 20 68 61 76 65 20 61 20 6c 69 73 74 20 6f 66 20 have a list of
6830: 69 74 65 6d 73 20 69 6e 20 61 20 74 65 73 74 20 items in a test
6840: 61 6e 64 20 74 68 65 20 69 74 65 6d 73 70 61 74 and the itemspat
6850: 68 20 73 65 74 20 2d 20 70 6c 65 61 73 65 20 72 h set - please r
6860: 65 70 6f 72 74 20 74 68 69 73 22 29 0a 09 20 20 eport this")..
6870: 20 20 20 20 28 65 78 69 74 20 31 29 29 0a 09 20 (exit 1))..
6880: 20 20 20 20 28 28 6e 6f 74 20 28 6e 75 6c 6c 3f ((not (null?
6890: 20 72 65 72 75 6e 73 29 29 0a 09 20 20 20 20 20 reruns))..
68a0: 20 28 6c 65 74 2a 20 28 28 6e 65 77 6c 73 74 20 (let* ((newlst
68b0: 28 74 65 73 74 73 3a 66 69 6c 74 65 72 2d 6e 6f (tests:filter-no
68c0: 6e 2d 72 75 6e 6e 61 62 6c 65 20 72 75 6e 2d 69 n-runnable run-i
68d0: 64 20 74 61 6c 20 74 65 73 74 2d 72 65 63 6f 72 d tal test-recor
68e0: 64 73 29 29 20 3b 3b 20 69 2e 65 2e 20 6e 6f 74 ds)) ;; i.e. not
68f0: 20 46 41 49 4c 2c 20 57 41 49 56 45 44 2c 20 49 FAIL, WAIVED, I
6900: 4e 43 4f 4d 50 4c 45 54 45 2c 20 50 41 53 53 2c NCOMPLETE, PASS,
6910: 20 4b 49 4c 4c 45 44 2c 0a 09 09 20 20 20 20 20 KILLED,...
6920: 28 6a 75 6e 6b 65 64 20 28 6c 73 65 74 2d 64 69 (junked (lset-di
6930: 66 66 65 72 65 6e 63 65 20 65 71 75 61 6c 3f 20 fference equal?
6940: 74 61 6c 20 6e 65 77 6c 73 74 29 29 29 0a 09 09 tal newlst)))...
6950: 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 (debug:print-inf
6960: 6f 20 34 20 22 66 75 6c 6c 20 64 72 6f 70 20 74 o 4 "full drop t
6970: 68 72 6f 75 67 68 2c 20 69 66 20 72 65 72 75 6e hrough, if rerun
6980: 73 20 69 73 20 6c 65 73 73 20 74 68 61 6e 20 31 s is less than 1
6990: 30 30 20 77 65 20 77 69 6c 6c 20 66 6f 72 63 65 00 we will force
69a0: 20 72 65 74 72 79 20 74 68 65 6d 2c 20 72 65 72 retry them, rer
69b0: 75 6e 73 3d 22 20 72 65 72 75 6e 73 20 22 2c 20 uns=" reruns ",
69c0: 74 61 6c 3d 22 20 74 61 6c 29 0a 09 09 28 69 66 tal=" tal)...(if
69d0: 20 28 3c 20 6e 75 6d 2d 72 65 74 72 69 65 73 20 (< num-retries
69e0: 6d 61 78 2d 72 65 74 72 69 65 73 29 0a 09 09 20 max-retries)...
69f0: 20 20 20 28 73 65 74 21 20 6e 65 77 6c 73 74 20 (set! newlst
6a00: 28 61 70 70 65 6e 64 20 72 65 72 75 6e 73 20 6e (append reruns n
6a10: 65 77 6c 73 74 29 29 29 0a 09 09 28 73 65 74 21 ewlst)))...(set!
6a20: 20 6e 75 6d 2d 72 65 74 72 69 65 73 20 28 2b 20 num-retries (+
6a30: 6e 75 6d 2d 72 65 74 72 69 65 73 20 31 29 29 0a num-retries 1)).
6a40: 09 09 3b 3b 20 28 74 68 72 65 61 64 2d 73 6c 65 ..;; (thread-sle
6a50: 65 70 21 20 28 2b 20 31 20 2a 67 6c 6f 62 61 6c ep! (+ 1 *global
6a60: 2d 64 65 6c 74 61 2a 29 29 0a 09 09 28 69 66 20 -delta*))...(if
6a70: 28 6e 6f 74 20 28 6e 75 6c 6c 3f 20 6e 65 77 6c (not (null? newl
6a80: 73 74 29 29 0a 09 09 20 20 20 20 3b 3b 20 73 69 st))... ;; si
6a90: 6e 63 65 20 72 65 72 75 6e 73 20 68 61 76 65 20 nce reruns have
6aa0: 62 65 65 6e 20 74 61 63 6b 65 64 20 6f 6e 20 74 been tacked on t
6ab0: 6f 20 6e 65 77 6c 73 74 20 63 72 65 61 74 65 20 o newlst create
6ac0: 6e 65 77 20 72 65 72 75 6e 73 20 66 72 6f 6d 20 new reruns from
6ad0: 6a 75 6e 6b 65 64 0a 09 09 20 20 20 20 28 6c 6f junked... (lo
6ae0: 6f 70 20 28 63 61 72 20 6e 65 77 6c 73 74 29 28 op (car newlst)(
6af0: 63 64 72 20 6e 65 77 6c 73 74 29 28 64 65 6c 65 cdr newlst)(dele
6b00: 74 65 2d 64 75 70 6c 69 63 61 74 65 73 20 6a 75 te-duplicates ju
6b10: 6e 6b 65 64 29 29 29 29 29 0a 09 20 20 20 20 20 nked)))))..
6b20: 28 28 6e 6f 74 20 28 6e 75 6c 6c 3f 20 74 61 6c ((not (null? tal
6b30: 29 29 0a 09 20 20 20 20 20 20 28 64 65 62 75 67 )).. (debug
6b40: 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 34 20 22 49 :print-info 4 "I
6b50: 27 6d 20 70 72 65 74 74 79 20 73 75 72 65 20 49 'm pretty sure I
6b60: 20 73 68 6f 75 6c 64 6e 27 74 20 67 65 74 20 68 shouldn't get h
6b70: 65 72 65 2e 22 29 29 0a 09 20 20 20 20 20 28 65 ere.")).. (e
6b80: 6c 73 65 0a 09 20 20 20 20 20 20 28 64 65 62 75 lse.. (debu
6b90: 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 34 20 22 g:print-info 4 "
6ba0: 45 78 69 74 69 6e 67 20 6c 6f 6f 70 20 77 69 74 Exiting loop wit
6bb0: 68 2e 2e 2e 5c 6e 20 20 68 65 64 3d 22 20 68 65 h...\n hed=" he
6bc0: 64 20 22 5c 6e 20 20 74 61 6c 3d 22 20 74 61 6c d "\n tal=" tal
6bd0: 20 22 5c 6e 20 20 72 65 72 75 6e 73 3d 22 20 72 "\n reruns=" r
6be0: 65 72 75 6e 73 29 29 0a 09 20 20 20 20 20 29 29 eruns)).. ))
6bf0: 29 29 20 3b 3b 20 4c 45 54 2a 20 28 28 74 65 73 )) ;; LET* ((tes
6c00: 74 2d 72 65 63 6f 72 64 0a 0a 20 20 20 20 3b 3b t-record.. ;;
6c10: 20 77 65 20 67 65 74 20 68 65 72 65 20 6f 6e 20 we get here on
6c20: 22 64 72 6f 70 20 74 68 72 6f 75 67 68 22 20 2d "drop through" -
6c30: 20 6c 6f 6f 70 20 66 6f 72 20 6e 65 78 74 20 74 loop for next t
6c40: 65 73 74 20 69 6e 20 71 75 65 75 65 0a 20 20 20 est in queue.
6c50: 20 3b 3b 20 46 49 58 4d 45 21 21 21 21 20 54 48 ;; FIXME!!!! TH
6c60: 49 53 20 53 48 4f 55 4c 44 20 4e 4f 54 20 52 45 IS SHOULD NOT RE
6c70: 51 55 49 52 45 20 41 4e 20 45 58 49 54 21 21 21 QUIRE AN EXIT!!!
6c80: 21 21 21 21 0a 20 20 20 20 0a 20 20 20 20 28 64 !!!!. . (d
6c90: 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 ebug:print-info
6ca0: 31 20 22 41 6c 6c 20 74 65 73 74 73 20 6c 61 75 1 "All tests lau
6cb0: 6e 63 68 65 64 22 29 0a 20 20 20 20 28 74 68 72 nched"). (thr
6cc0: 65 61 64 2d 73 6c 65 65 70 21 20 30 2e 35 29 0a ead-sleep! 0.5).
6cd0: 20 20 20 20 3b 3b 20 46 49 58 4d 45 21 20 54 68 ;; FIXME! Th
6ce0: 69 73 20 68 61 72 73 68 20 65 78 69 74 20 73 68 is harsh exit sh
6cf0: 6f 75 6c 64 20 6e 6f 74 20 62 65 20 6e 65 63 65 ould not be nece
6d00: 73 73 61 72 79 2e 2e 2e 2e 0a 20 20 20 20 3b 3b ssary..... ;;
6d10: 20 28 69 66 20 28 6e 6f 74 20 2a 72 75 6e 72 65 (if (not *runre
6d20: 6d 6f 74 65 2a 29 28 65 78 69 74 29 29 20 3b 3b mote*)(exit)) ;;
6d30: 20 0a 20 20 20 20 23 66 29 29 20 3b 3b 20 72 65 . #f)) ;; re
6d40: 74 75 72 6e 20 61 20 23 66 20 61 73 20 61 20 68 turn a #f as a h
6d50: 69 6e 74 20 74 68 61 74 20 77 65 20 61 72 65 20 int that we are
6d60: 64 6f 6e 65 0a 20 20 3b 3b 20 48 65 72 65 20 77 done. ;; Here w
6d70: 65 20 6e 65 65 64 20 74 6f 20 63 68 65 63 6b 20 e need to check
6d80: 74 68 61 74 20 61 6c 6c 20 74 68 65 20 74 65 73 that all the tes
6d90: 74 73 20 72 65 6d 61 69 6e 69 6e 67 20 74 6f 20 ts remaining to
6da0: 62 65 20 72 75 6e 20 61 72 65 20 65 6c 69 67 69 be run are eligi
6db0: 62 6c 65 20 74 6f 20 72 75 6e 0a 20 20 3b 3b 20 ble to run. ;;
6dc0: 61 6e 64 20 61 72 65 20 6e 6f 74 20 62 6c 6f 63 and are not bloc
6dd0: 6b 65 64 20 62 79 20 66 61 69 6c 65 64 0a 20 20 ked by failed.
6de0: 0a 0a 3b 3b 20 70 61 72 65 6e 74 2d 74 65 73 74 ..;; parent-test
6df0: 20 69 73 20 74 68 65 72 65 20 61 73 20 61 20 70 is there as a p
6e00: 6c 61 63 65 68 6f 6c 64 65 72 20 66 6f 72 20 77 laceholder for w
6e10: 68 65 6e 20 70 61 72 65 6e 74 2d 74 65 73 74 73 hen parent-tests
6e20: 20 63 61 6e 20 62 65 20 72 75 6e 20 61 73 20 61 can be run as a
6e30: 20 73 65 74 75 70 20 73 74 65 70 0a 28 64 65 66 setup step.(def
6e40: 69 6e 65 20 28 72 75 6e 3a 74 65 73 74 20 72 75 ine (run:test ru
6e50: 6e 2d 69 64 20 72 75 6e 6e 61 6d 65 20 6b 65 79 n-id runname key
6e60: 76 61 6c 6c 73 74 20 74 65 73 74 2d 72 65 63 6f vallst test-reco
6e70: 72 64 20 66 6c 61 67 73 20 70 61 72 65 6e 74 2d rd flags parent-
6e80: 74 65 73 74 29 0a 20 20 3b 3b 20 41 6c 6c 20 74 test). ;; All t
6e90: 68 65 73 65 20 76 61 72 73 20 6d 69 67 68 74 20 hese vars might
6ea0: 62 65 20 72 65 66 65 72 65 6e 63 65 64 20 62 79 be referenced by
6eb0: 20 74 68 65 20 74 65 73 74 63 6f 6e 66 69 67 20 the testconfig
6ec0: 66 69 6c 65 20 72 65 61 64 65 72 0a 20 20 28 6c file reader. (l
6ed0: 65 74 2a 20 28 28 74 65 73 74 2d 6e 61 6d 65 20 et* ((test-name
6ee0: 20 20 20 28 74 65 73 74 73 3a 74 65 73 74 71 75 (tests:testqu
6ef0: 65 75 65 2d 67 65 74 2d 74 65 73 74 6e 61 6d 65 eue-get-testname
6f00: 20 20 20 74 65 73 74 2d 72 65 63 6f 72 64 29 29 test-record))
6f10: 0a 09 20 28 74 65 73 74 2d 77 61 69 74 6f 6e 73 .. (test-waitons
6f20: 20 28 74 65 73 74 73 3a 74 65 73 74 71 75 65 75 (tests:testqueu
6f30: 65 2d 67 65 74 2d 77 61 69 74 6f 6e 73 20 20 20 e-get-waitons
6f40: 20 74 65 73 74 2d 72 65 63 6f 72 64 29 29 0a 09 test-record))..
6f50: 20 28 74 65 73 74 2d 63 6f 6e 66 20 20 20 20 28 (test-conf (
6f60: 74 65 73 74 73 3a 74 65 73 74 71 75 65 75 65 2d tests:testqueue-
6f70: 67 65 74 2d 74 65 73 74 63 6f 6e 66 69 67 20 74 get-testconfig t
6f80: 65 73 74 2d 72 65 63 6f 72 64 29 29 0a 09 20 28 est-record)).. (
6f90: 69 74 65 6d 64 61 74 20 20 20 20 20 20 28 74 65 itemdat (te
6fa0: 73 74 73 3a 74 65 73 74 71 75 65 75 65 2d 67 65 sts:testqueue-ge
6fb0: 74 2d 69 74 65 6d 64 61 74 20 20 20 20 74 65 73 t-itemdat tes
6fc0: 74 2d 72 65 63 6f 72 64 29 29 0a 09 20 28 74 65 t-record)).. (te
6fd0: 73 74 2d 70 61 74 68 20 20 20 20 28 63 6f 6e 63 st-path (conc
6fe0: 20 2a 74 6f 70 70 61 74 68 2a 20 22 2f 74 65 73 *toppath* "/tes
6ff0: 74 73 2f 22 20 74 65 73 74 2d 6e 61 6d 65 29 29 ts/" test-name))
7000: 20 3b 3b 20 63 6f 75 6c 64 20 75 73 65 20 74 65 ;; could use te
7010: 73 74 73 3a 67 65 74 2d 74 65 73 74 63 6f 6e 66 sts:get-testconf
7020: 69 67 20 68 65 72 65 20 2e 2e 2e 0a 09 20 28 66 ig here ..... (f
7030: 6f 72 63 65 20 20 20 20 20 20 20 20 28 68 61 73 orce (has
7040: 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 h-table-ref/defa
7050: 75 6c 74 20 66 6c 61 67 73 20 22 2d 66 6f 72 63 ult flags "-forc
7060: 65 22 20 23 66 29 29 0a 09 20 28 72 65 72 75 6e e" #f)).. (rerun
7070: 20 20 20 20 20 20 20 20 28 68 61 73 68 2d 74 61 (hash-ta
7080: 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 ble-ref/default
7090: 66 6c 61 67 73 20 22 2d 72 65 72 75 6e 22 20 23 flags "-rerun" #
70a0: 66 29 29 0a 09 20 28 6b 65 65 70 67 6f 69 6e 67 f)).. (keepgoing
70b0: 20 20 20 20 28 68 61 73 68 2d 74 61 62 6c 65 2d (hash-table-
70c0: 72 65 66 2f 64 65 66 61 75 6c 74 20 66 6c 61 67 ref/default flag
70d0: 73 20 22 2d 6b 65 65 70 67 6f 69 6e 67 22 20 23 s "-keepgoing" #
70e0: 66 29 29 0a 09 20 28 69 74 65 6d 2d 70 61 74 68 f)).. (item-path
70f0: 20 20 20 20 20 22 22 29 0a 09 20 28 64 62 20 20 "").. (db
7100: 20 20 20 20 20 20 20 20 20 23 66 29 29 0a 20 20 #f)).
7110: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 34 (debug:print 4
7120: 0a 09 09 20 22 74 65 73 74 2d 63 6f 6e 66 69 67 ... "test-config
7130: 3a 20 22 20 28 68 61 73 68 2d 74 61 62 6c 65 2d : " (hash-table-
7140: 3e 61 6c 69 73 74 20 74 65 73 74 2d 63 6f 6e 66 >alist test-conf
7150: 29 0a 09 09 20 22 5c 6e 20 20 20 69 74 65 6d 64 )... "\n itemd
7160: 61 74 3a 20 22 20 69 74 65 6d 64 61 74 0a 09 09 at: " itemdat...
7170: 20 29 0a 20 20 20 20 3b 3b 20 73 65 74 74 69 6e ). ;; settin
7180: 67 20 69 74 65 6d 64 61 74 20 74 6f 20 61 20 6c g itemdat to a l
7190: 69 73 74 20 69 66 20 69 74 20 69 73 20 23 66 0a ist if it is #f.
71a0: 20 20 20 20 28 69 66 20 28 6e 6f 74 20 69 74 65 (if (not ite
71b0: 6d 64 61 74 29 28 73 65 74 21 20 69 74 65 6d 64 mdat)(set! itemd
71c0: 61 74 20 27 28 29 29 29 0a 20 20 20 20 28 73 65 at '())). (se
71d0: 74 21 20 69 74 65 6d 2d 70 61 74 68 20 28 69 74 t! item-path (it
71e0: 65 6d 2d 6c 69 73 74 2d 3e 70 61 74 68 20 69 74 em-list->path it
71f0: 65 6d 64 61 74 29 29 0a 20 20 20 20 28 64 65 62 emdat)). (deb
7200: 75 67 3a 70 72 69 6e 74 20 32 20 22 41 74 74 65 ug:print 2 "Atte
7210: 6d 70 74 69 6e 67 20 74 6f 20 6c 61 75 6e 63 68 mpting to launch
7220: 20 74 65 73 74 20 22 20 74 65 73 74 2d 6e 61 6d test " test-nam
7230: 65 20 28 69 66 20 28 65 71 75 61 6c 3f 20 69 74 e (if (equal? it
7240: 65 6d 2d 70 61 74 68 20 22 2f 22 29 20 22 2f 22 em-path "/") "/"
7250: 20 69 74 65 6d 2d 70 61 74 68 29 29 0a 20 20 20 item-path)).
7260: 20 28 73 65 74 65 6e 76 20 22 4d 54 5f 54 45 53 (setenv "MT_TES
7270: 54 5f 4e 41 4d 45 22 20 74 65 73 74 2d 6e 61 6d T_NAME" test-nam
7280: 65 29 20 3b 3b 20 0a 20 20 20 20 28 73 65 74 65 e) ;; . (sete
7290: 6e 76 20 22 4d 54 5f 52 55 4e 4e 41 4d 45 22 20 nv "MT_RUNNAME"
72a0: 20 20 72 75 6e 6e 61 6d 65 29 0a 20 20 20 20 28 runname). (
72b0: 73 65 74 2d 6d 65 67 61 74 65 73 74 2d 65 6e 76 set-megatest-env
72c0: 2d 76 61 72 73 20 72 75 6e 2d 69 64 29 20 3b 3b -vars run-id) ;;
72d0: 20 74 68 65 73 65 20 6d 61 79 20 62 65 20 6e 65 these may be ne
72e0: 65 64 65 64 20 62 79 20 74 68 65 20 6c 61 75 6e eded by the laun
72f0: 63 68 69 6e 67 20 70 72 6f 63 65 73 73 0a 20 20 ching process.
7300: 20 20 28 63 68 61 6e 67 65 2d 64 69 72 65 63 74 (change-direct
7310: 6f 72 79 20 2a 74 6f 70 70 61 74 68 2a 29 0a 0a ory *toppath*)..
7320: 20 20 20 20 3b 3b 20 48 65 72 65 20 69 73 20 77 ;; Here is w
7330: 68 65 72 65 20 74 68 65 20 74 65 73 74 5f 6d 65 here the test_me
7340: 74 61 20 74 61 62 6c 65 20 69 73 20 62 65 73 74 ta table is best
7350: 20 75 70 64 61 74 65 64 0a 20 20 20 20 3b 3b 20 updated. ;;
7360: 59 65 73 2c 20 61 6e 6f 74 68 65 72 20 75 73 65 Yes, another use
7370: 20 6f 66 20 61 20 67 6c 6f 62 61 6c 20 66 6f 72 of a global for
7380: 20 63 61 63 68 69 6e 67 2e 20 4e 65 65 64 20 61 caching. Need a
7390: 20 62 65 74 74 65 72 20 77 61 79 3f 0a 20 20 20 better way?.
73a0: 20 28 69 66 20 28 6e 6f 74 20 28 68 61 73 68 2d (if (not (hash-
73b0: 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c table-ref/defaul
73c0: 74 20 2a 74 65 73 74 2d 6d 65 74 61 2d 75 70 64 t *test-meta-upd
73d0: 61 74 65 64 2a 20 74 65 73 74 2d 6e 61 6d 65 20 ated* test-name
73e0: 23 66 29 29 0a 20 20 20 20 20 20 20 20 28 62 65 #f)). (be
73f0: 67 69 6e 0a 09 20 20 20 28 68 61 73 68 2d 74 61 gin.. (hash-ta
7400: 62 6c 65 2d 73 65 74 21 20 2a 74 65 73 74 2d 6d ble-set! *test-m
7410: 65 74 61 2d 75 70 64 61 74 65 64 2a 20 74 65 73 eta-updated* tes
7420: 74 2d 6e 61 6d 65 20 23 74 29 0a 20 20 20 20 20 t-name #t).
7430: 20 20 20 20 20 20 28 6f 70 65 6e 2d 72 75 6e 2d (open-run-
7440: 63 6c 6f 73 65 20 72 75 6e 73 3a 75 70 64 61 74 close runs:updat
7450: 65 2d 74 65 73 74 5f 6d 65 74 61 20 64 62 20 74 e-test_meta db t
7460: 65 73 74 2d 6e 61 6d 65 20 74 65 73 74 2d 63 6f est-name test-co
7470: 6e 66 29 29 29 0a 20 20 20 20 0a 20 20 20 20 3b nf))). . ;
7480: 3b 20 28 6c 61 6d 62 64 61 20 28 69 74 65 6d 64 ; (lambda (itemd
7490: 61 74 29 20 3b 3b 3b 20 28 28 72 69 70 65 6e 65 at) ;;; ((ripene
74a0: 73 73 20 22 6f 76 65 72 72 69 70 65 22 29 20 28 ss "overripe") (
74b0: 74 65 6d 70 65 72 61 74 75 72 65 20 22 63 6f 6f temperature "coo
74c0: 6c 22 29 20 28 73 65 61 73 6f 6e 20 22 73 75 6d l") (season "sum
74d0: 6d 65 72 22 29 29 0a 20 20 20 20 28 6c 65 74 2a mer")). (let*
74e0: 20 28 28 6e 65 77 2d 74 65 73 74 2d 70 61 74 68 ((new-test-path
74f0: 20 28 73 74 72 69 6e 67 2d 69 6e 74 65 72 73 70 (string-intersp
7500: 65 72 73 65 20 28 63 6f 6e 73 20 74 65 73 74 2d erse (cons test-
7510: 70 61 74 68 20 28 6d 61 70 20 63 61 64 72 20 69 path (map cadr i
7520: 74 65 6d 64 61 74 29 29 20 22 2f 22 29 29 0a 09 temdat)) "/"))..
7530: 20 20 20 28 6e 65 77 2d 74 65 73 74 2d 6e 61 6d (new-test-nam
7540: 65 20 28 69 66 20 28 65 71 75 61 6c 3f 20 69 74 e (if (equal? it
7550: 65 6d 2d 70 61 74 68 20 22 22 29 20 74 65 73 74 em-path "") test
7560: 2d 6e 61 6d 65 20 28 63 6f 6e 63 20 74 65 73 74 -name (conc test
7570: 2d 6e 61 6d 65 20 22 2f 22 20 69 74 65 6d 2d 70 -name "/" item-p
7580: 61 74 68 29 29 29 20 3b 3b 20 6a 75 73 74 20 6e ath))) ;; just n
7590: 65 65 64 20 69 74 20 74 6f 20 62 65 20 75 6e 69 eed it to be uni
75a0: 71 75 65 0a 09 20 20 20 28 74 65 73 74 2d 69 64 que.. (test-id
75b0: 20 20 20 20 20 20 20 28 63 64 62 3a 72 65 6d 6f (cdb:remo
75c0: 74 65 2d 72 75 6e 20 64 62 3a 67 65 74 2d 74 65 te-run db:get-te
75d0: 73 74 2d 69 64 20 23 66 20 20 72 75 6e 2d 69 64 st-id #f run-id
75e0: 20 74 65 73 74 2d 6e 61 6d 65 20 69 74 65 6d 2d test-name item-
75f0: 70 61 74 68 29 29 0a 09 20 20 20 28 74 65 73 74 path)).. (test
7600: 64 61 74 20 20 20 20 20 20 20 28 63 64 62 3a 67 dat (cdb:g
7610: 65 74 2d 74 65 73 74 2d 69 6e 66 6f 2d 62 79 2d et-test-info-by-
7620: 69 64 20 2a 72 75 6e 72 65 6d 6f 74 65 2a 20 74 id *runremote* t
7630: 65 73 74 2d 69 64 29 29 29 0a 20 20 20 20 20 20 est-id))).
7640: 28 69 66 20 28 6e 6f 74 20 74 65 73 74 64 61 74 (if (not testdat
7650: 29 0a 09 20 20 28 62 65 67 69 6e 0a 09 20 20 20 ).. (begin..
7660: 20 3b 3b 20 65 6e 73 75 72 65 20 74 68 61 74 20 ;; ensure that
7670: 74 68 65 20 70 61 74 68 20 65 78 69 73 74 73 20 the path exists
7680: 62 65 66 6f 72 65 20 72 65 67 69 73 74 65 72 69 before registeri
7690: 6e 67 20 74 68 65 20 74 65 73 74 0a 09 20 20 20 ng the test..
76a0: 20 3b 3b 20 4e 4f 50 45 3a 20 43 61 6e 6e 6f 74 ;; NOPE: Cannot
76b0: 21 20 44 6f 6e 27 74 20 6b 6e 6f 77 20 79 65 74 ! Don't know yet
76c0: 20 77 68 69 63 68 20 64 69 73 6b 20 61 72 65 61 which disk area
76d0: 20 77 69 6c 6c 20 62 65 20 61 73 73 69 67 6e 65 will be assigne
76e0: 64 2e 2e 2e 2e 0a 09 20 20 20 20 3b 3b 20 28 73 d...... ;; (s
76f0: 79 73 74 65 6d 20 28 63 6f 6e 63 20 22 6d 6b 64 ystem (conc "mkd
7700: 69 72 20 2d 70 20 22 20 6e 65 77 2d 74 65 73 74 ir -p " new-test
7710: 2d 70 61 74 68 29 29 0a 09 20 20 20 20 3b 3b 0a -path)).. ;;.
7720: 09 20 20 20 20 3b 3b 20 28 6f 70 65 6e 2d 72 75 . ;; (open-ru
7730: 6e 2d 63 6c 6f 73 65 20 74 65 73 74 73 3a 72 65 n-close tests:re
7740: 67 69 73 74 65 72 2d 74 65 73 74 20 64 62 20 72 gister-test db r
7750: 75 6e 2d 69 64 20 74 65 73 74 2d 6e 61 6d 65 20 un-id test-name
7760: 69 74 65 6d 2d 70 61 74 68 29 0a 09 20 20 20 20 item-path)..
7770: 3b 3b 0a 09 20 20 20 20 3b 3b 20 4e 42 2f 2f 20 ;;.. ;; NB//
7780: 66 6f 72 20 74 68 65 20 61 62 6f 76 65 20 6c 69 for the above li
7790: 6e 65 2e 20 49 20 77 61 6e 74 20 74 68 65 20 74 ne. I want the t
77a0: 65 73 74 20 74 6f 20 62 65 20 72 65 67 69 73 74 est to be regist
77b0: 65 72 65 64 20 6c 6f 6e 67 20 62 65 66 6f 72 65 ered long before
77c0: 20 74 68 69 73 20 72 6f 75 74 69 6e 65 20 67 65 this routine ge
77d0: 74 73 20 63 61 6c 6c 65 64 21 0a 09 20 20 20 20 ts called!..
77e0: 3b 3b 0a 09 20 20 20 20 28 73 65 74 21 20 74 65 ;;.. (set! te
77f0: 73 74 2d 69 64 20 28 6f 70 65 6e 2d 72 75 6e 2d st-id (open-run-
7800: 63 6c 6f 73 65 20 64 62 3a 67 65 74 2d 74 65 73 close db:get-tes
7810: 74 2d 69 64 20 64 62 20 72 75 6e 2d 69 64 20 74 t-id db run-id t
7820: 65 73 74 2d 6e 61 6d 65 20 69 74 65 6d 2d 70 61 est-name item-pa
7830: 74 68 29 29 0a 09 20 20 20 20 28 69 66 20 28 6e th)).. (if (n
7840: 6f 74 20 74 65 73 74 2d 69 64 29 0a 09 09 28 62 ot test-id)...(b
7850: 65 67 69 6e 0a 09 09 20 20 28 64 65 62 75 67 3a egin... (debug:
7860: 70 72 69 6e 74 20 32 20 22 57 41 52 4e 3a 20 54 print 2 "WARN: T
7870: 65 73 74 20 6e 6f 74 20 70 72 65 2d 63 72 65 61 est not pre-crea
7880: 74 65 64 3f 20 74 65 73 74 2d 6e 61 6d 65 3d 22 ted? test-name="
7890: 20 74 65 73 74 2d 6e 61 6d 65 20 22 2c 20 69 74 test-name ", it
78a0: 65 6d 2d 70 61 74 68 3d 22 20 69 74 65 6d 2d 70 em-path=" item-p
78b0: 61 74 68 20 22 2c 20 72 75 6e 2d 69 64 3d 22 20 ath ", run-id="
78c0: 72 75 6e 2d 69 64 29 0a 09 09 20 20 28 6f 70 65 run-id)... (ope
78d0: 6e 2d 72 75 6e 2d 63 6c 6f 73 65 20 64 62 3a 74 n-run-close db:t
78e0: 65 73 74 73 2d 72 65 67 69 73 74 65 72 2d 74 65 ests-register-te
78f0: 73 74 20 23 66 20 72 75 6e 2d 69 64 20 74 65 73 st #f run-id tes
7900: 74 2d 6e 61 6d 65 20 69 74 65 6d 2d 70 61 74 68 t-name item-path
7910: 29 0a 09 09 20 20 28 73 65 74 21 20 74 65 73 74 )... (set! test
7920: 2d 69 64 20 28 6f 70 65 6e 2d 72 75 6e 2d 63 6c -id (open-run-cl
7930: 6f 73 65 20 64 62 3a 67 65 74 2d 74 65 73 74 2d ose db:get-test-
7940: 69 64 20 64 62 20 72 75 6e 2d 69 64 20 74 65 73 id db run-id tes
7950: 74 2d 6e 61 6d 65 20 69 74 65 6d 2d 70 61 74 68 t-name item-path
7960: 29 29 29 29 0a 09 20 20 20 20 28 64 65 62 75 67 )))).. (debug
7970: 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 34 20 22 74 :print-info 4 "t
7980: 65 73 74 2d 69 64 3d 22 20 74 65 73 74 2d 69 64 est-id=" test-id
7990: 20 22 2c 20 72 75 6e 2d 69 64 3d 22 20 72 75 6e ", run-id=" run
79a0: 2d 69 64 20 22 2c 20 74 65 73 74 2d 6e 61 6d 65 -id ", test-name
79b0: 3d 22 20 74 65 73 74 2d 6e 61 6d 65 20 22 2c 20 =" test-name ",
79c0: 69 74 65 6d 2d 70 61 74 68 3d 5c 22 22 20 69 74 item-path=\"" it
79d0: 65 6d 2d 70 61 74 68 20 22 5c 22 22 29 0a 09 20 em-path "\"")..
79e0: 20 20 20 28 73 65 74 21 20 74 65 73 74 64 61 74 (set! testdat
79f0: 20 28 63 64 62 3a 67 65 74 2d 74 65 73 74 2d 69 (cdb:get-test-i
7a00: 6e 66 6f 2d 62 79 2d 69 64 20 2a 72 75 6e 72 65 nfo-by-id *runre
7a10: 6d 6f 74 65 2a 20 74 65 73 74 2d 69 64 29 29 29 mote* test-id)))
7a20: 29 0a 20 20 20 20 20 20 28 73 65 74 21 20 74 65 ). (set! te
7a30: 73 74 2d 69 64 20 28 64 62 3a 74 65 73 74 2d 67 st-id (db:test-g
7a40: 65 74 2d 69 64 20 74 65 73 74 64 61 74 29 29 0a et-id testdat)).
7a50: 20 20 20 20 20 20 28 63 68 61 6e 67 65 2d 64 69 (change-di
7a60: 72 65 63 74 6f 72 79 20 74 65 73 74 2d 70 61 74 rectory test-pat
7a70: 68 29 0a 20 20 20 20 20 20 28 63 61 73 65 20 28 h). (case (
7a80: 69 66 20 66 6f 72 63 65 20 3b 3b 20 28 61 72 67 if force ;; (arg
7a90: 73 3a 67 65 74 2d 61 72 67 20 22 2d 66 6f 72 63 s:get-arg "-forc
7aa0: 65 22 29 0a 09 09 27 4e 4f 54 5f 53 54 41 52 54 e")...'NOT_START
7ab0: 45 44 0a 09 09 28 69 66 20 74 65 73 74 64 61 74 ED...(if testdat
7ac0: 0a 09 09 20 20 20 20 28 73 74 72 69 6e 67 2d 3e ... (string->
7ad0: 73 79 6d 62 6f 6c 20 28 74 65 73 74 3a 67 65 74 symbol (test:get
7ae0: 2d 73 74 61 74 65 20 74 65 73 74 64 61 74 29 29 -state testdat))
7af0: 0a 09 09 20 20 20 20 27 66 61 69 6c 65 64 2d 74 ... 'failed-t
7b00: 6f 2d 69 6e 73 65 72 74 29 29 0a 09 28 28 66 61 o-insert))..((fa
7b10: 69 6c 65 64 2d 74 6f 2d 69 6e 73 65 72 74 29 0a iled-to-insert).
7b20: 09 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 . (debug:print 0
7b30: 20 22 45 52 52 4f 52 3a 20 46 61 69 6c 65 64 20 "ERROR: Failed
7b40: 74 6f 20 69 6e 73 65 72 74 20 74 68 65 20 72 65 to insert the re
7b50: 63 6f 72 64 20 69 6e 74 6f 20 74 68 65 20 64 62 cord into the db
7b60: 22 29 29 0a 09 28 28 4e 4f 54 5f 53 54 41 52 54 "))..((NOT_START
7b70: 45 44 20 43 4f 4d 50 4c 45 54 45 44 20 44 45 4c ED COMPLETED DEL
7b80: 45 54 45 44 29 0a 09 20 28 6c 65 74 20 28 28 72 ETED).. (let ((r
7b90: 75 6e 66 6c 61 67 20 23 66 29 29 0a 09 20 20 20 unflag #f))..
7ba0: 28 63 6f 6e 64 0a 09 20 20 20 20 3b 3b 20 2d 66 (cond.. ;; -f
7bb0: 6f 72 63 65 2c 20 72 75 6e 20 6e 6f 20 6d 61 74 orce, run no mat
7bc0: 74 65 72 20 77 68 61 74 0a 09 20 20 20 20 28 66 ter what.. (f
7bd0: 6f 72 63 65 20 28 73 65 74 21 20 72 75 6e 66 6c orce (set! runfl
7be0: 61 67 20 23 74 29 29 0a 09 20 20 20 20 3b 3b 20 ag #t)).. ;;
7bf0: 4e 4f 54 5f 53 54 41 52 54 45 44 2c 20 72 75 6e NOT_STARTED, run
7c00: 20 6e 6f 20 6d 61 74 74 65 72 20 77 68 61 74 0a no matter what.
7c10: 09 20 20 20 20 28 28 6d 65 6d 62 65 72 20 28 74 . ((member (t
7c20: 65 73 74 3a 67 65 74 2d 73 74 61 74 65 20 74 65 est:get-state te
7c30: 73 74 64 61 74 29 20 27 28 22 44 45 4c 45 54 45 stdat) '("DELETE
7c40: 44 22 20 22 4e 4f 54 5f 53 54 41 52 54 45 44 22 D" "NOT_STARTED"
7c50: 29 29 28 73 65 74 21 20 72 75 6e 66 6c 61 67 20 ))(set! runflag
7c60: 23 74 29 29 0a 09 20 20 20 20 3b 3b 20 6e 6f 74 #t)).. ;; not
7c70: 20 2d 72 65 72 75 6e 20 61 6e 64 20 50 41 53 53 -rerun and PASS
7c80: 2c 20 57 41 52 4e 20 6f 72 20 43 48 45 43 4b 2c , WARN or CHECK,
7c90: 20 64 6f 20 6e 6f 20 72 75 6e 0a 09 20 20 20 20 do no run..
7ca0: 28 28 61 6e 64 20 28 6f 72 20 28 6e 6f 74 20 72 ((and (or (not r
7cb0: 65 72 75 6e 29 0a 09 09 20 20 20 20 20 20 6b 65 erun)... ke
7cc0: 65 70 67 6f 69 6e 67 29 0a 09 09 20 20 3b 3b 20 epgoing)... ;;
7cd0: 52 65 71 75 69 72 65 20 74 6f 20 66 6f 72 63 65 Require to force
7ce0: 20 72 65 2d 72 75 6e 20 66 6f 72 20 43 4f 4d 50 re-run for COMP
7cf0: 4c 45 54 45 44 20 6f 72 20 2a 61 6e 79 74 68 69 LETED or *anythi
7d00: 6e 67 2a 20 2b 20 50 41 53 53 2c 57 41 52 4e 20 ng* + PASS,WARN
7d10: 6f 72 20 43 48 45 43 4b 0a 09 09 20 20 28 6f 72 or CHECK... (or
7d20: 20 28 6d 65 6d 62 65 72 20 28 74 65 73 74 3a 67 (member (test:g
7d30: 65 74 2d 73 74 61 74 75 73 20 74 65 73 74 64 61 et-status testda
7d40: 74 29 20 27 28 22 50 41 53 53 22 20 22 57 41 52 t) '("PASS" "WAR
7d50: 4e 22 20 22 43 48 45 43 4b 22 20 22 53 4b 49 50 N" "CHECK" "SKIP
7d60: 22 29 29 0a 09 09 20 20 20 20 20 20 28 6d 65 6d "))... (mem
7d70: 62 65 72 20 28 74 65 73 74 3a 67 65 74 2d 73 74 ber (test:get-st
7d80: 61 74 65 20 20 74 65 73 74 64 61 74 29 20 27 28 ate testdat) '(
7d90: 22 43 4f 4d 50 4c 45 54 45 44 22 29 29 29 29 20 "COMPLETED"))))
7da0: 0a 09 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 .. (debug:pr
7db0: 69 6e 74 2d 69 6e 66 6f 20 32 20 22 72 75 6e 6e int-info 2 "runn
7dc0: 69 6e 67 20 74 65 73 74 20 22 20 74 65 73 74 2d ing test " test-
7dd0: 6e 61 6d 65 20 22 2f 22 20 69 74 65 6d 2d 70 61 name "/" item-pa
7de0: 74 68 20 22 20 73 75 70 70 72 65 73 73 65 64 20 th " suppressed
7df0: 61 73 20 69 74 20 69 73 20 22 20 28 74 65 73 74 as it is " (test
7e00: 3a 67 65 74 2d 73 74 61 74 65 20 74 65 73 74 64 :get-state testd
7e10: 61 74 29 20 22 20 61 6e 64 20 22 20 28 74 65 73 at) " and " (tes
7e20: 74 3a 67 65 74 2d 73 74 61 74 75 73 20 74 65 73 t:get-status tes
7e30: 74 64 61 74 29 29 0a 09 20 20 20 20 20 28 73 65 tdat)).. (se
7e40: 74 21 20 72 75 6e 66 6c 61 67 20 23 66 29 29 0a t! runflag #f)).
7e50: 09 20 20 20 20 3b 3b 20 2d 72 65 72 75 6e 20 61 . ;; -rerun a
7e60: 6e 64 20 73 74 61 74 75 73 20 69 73 20 6f 6e 65 nd status is one
7e70: 20 6f 66 20 74 68 65 20 73 70 65 63 69 66 65 64 of the specifed
7e80: 2c 20 72 75 6e 20 69 74 0a 09 20 20 20 20 28 28 , run it.. ((
7e90: 61 6e 64 20 72 65 72 75 6e 0a 09 09 20 20 28 6c and rerun... (l
7ea0: 65 74 2a 20 28 28 72 65 72 75 6e 6c 73 74 20 20 et* ((rerunlst
7eb0: 20 28 73 74 72 69 6e 67 2d 73 70 6c 69 74 20 72 (string-split r
7ec0: 65 72 75 6e 20 22 2c 22 29 29 0a 09 09 09 20 28 erun ",")).... (
7ed0: 6d 75 73 74 2d 72 65 72 75 6e 20 28 6d 65 6d 62 must-rerun (memb
7ee0: 65 72 20 28 74 65 73 74 3a 67 65 74 2d 73 74 61 er (test:get-sta
7ef0: 74 75 73 20 74 65 73 74 64 61 74 29 20 72 65 72 tus testdat) rer
7f00: 75 6e 6c 73 74 29 29 29 0a 09 09 20 20 20 20 28 unlst)))... (
7f10: 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f debug:print-info
7f20: 20 33 20 22 2d 72 65 72 75 6e 20 6c 69 73 74 3a 3 "-rerun list:
7f30: 20 22 20 72 65 72 75 6e 20 22 2c 20 74 65 73 74 " rerun ", test
7f40: 2d 73 74 61 74 75 73 3a 20 22 20 28 74 65 73 74 -status: " (test
7f50: 3a 67 65 74 2d 73 74 61 74 75 73 20 74 65 73 74 :get-status test
7f60: 64 61 74 29 22 2c 20 6d 75 73 74 2d 72 65 72 75 dat)", must-reru
7f70: 6e 3a 20 22 20 6d 75 73 74 2d 72 65 72 75 6e 29 n: " must-rerun)
7f80: 0a 09 09 20 20 20 20 6d 75 73 74 2d 72 65 72 75 ... must-reru
7f90: 6e 29 29 0a 09 20 20 20 20 20 28 64 65 62 75 67 n)).. (debug
7fa0: 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 32 20 22 52 :print-info 2 "R
7fb0: 65 72 75 6e 20 66 6f 72 63 65 64 20 66 6f 72 20 erun forced for
7fc0: 74 65 73 74 20 22 20 74 65 73 74 2d 6e 61 6d 65 test " test-name
7fd0: 20 22 2f 22 20 69 74 65 6d 2d 70 61 74 68 29 0a "/" item-path).
7fe0: 09 20 20 20 20 20 28 73 65 74 21 20 72 75 6e 66 . (set! runf
7ff0: 6c 61 67 20 23 74 29 29 0a 09 20 20 20 20 3b 3b lag #t)).. ;;
8000: 20 2d 6b 65 65 70 67 6f 69 6e 67 2c 20 64 6f 20 -keepgoing, do
8010: 6e 6f 74 20 72 65 72 75 6e 20 46 41 49 4c 0a 09 not rerun FAIL..
8020: 20 20 20 20 28 28 61 6e 64 20 6b 65 65 70 67 6f ((and keepgo
8030: 69 6e 67 0a 09 09 20 20 28 6d 65 6d 62 65 72 20 ing... (member
8040: 28 74 65 73 74 3a 67 65 74 2d 73 74 61 74 75 73 (test:get-status
8050: 20 74 65 73 74 64 61 74 29 20 27 28 22 46 41 49 testdat) '("FAI
8060: 4c 22 29 29 29 0a 09 20 20 20 20 20 28 73 65 74 L"))).. (set
8070: 21 20 72 75 6e 66 6c 61 67 20 23 66 29 29 0a 09 ! runflag #f))..
8080: 20 20 20 20 28 28 61 6e 64 20 28 6e 6f 74 20 72 ((and (not r
8090: 65 72 75 6e 29 0a 09 09 20 20 28 6d 65 6d 62 65 erun)... (membe
80a0: 72 20 28 74 65 73 74 3a 67 65 74 2d 73 74 61 74 r (test:get-stat
80b0: 75 73 20 74 65 73 74 64 61 74 29 20 27 28 22 46 us testdat) '("F
80c0: 41 49 4c 22 20 22 6e 2f 61 22 29 29 29 0a 09 20 AIL" "n/a")))..
80d0: 20 20 20 20 28 73 65 74 21 20 72 75 6e 66 6c 61 (set! runfla
80e0: 67 20 23 74 29 29 0a 09 20 20 20 20 28 65 6c 73 g #t)).. (els
80f0: 65 20 28 73 65 74 21 20 72 75 6e 66 6c 61 67 20 e (set! runflag
8100: 23 66 29 29 29 0a 09 20 20 20 28 64 65 62 75 67 #f))).. (debug
8110: 3a 70 72 69 6e 74 20 36 20 22 52 55 4e 4e 49 4e :print 6 "RUNNIN
8120: 47 20 3d 3e 20 72 75 6e 66 6c 61 67 3a 20 22 20 G => runflag: "
8130: 72 75 6e 66 6c 61 67 20 22 20 53 54 41 54 45 3a runflag " STATE:
8140: 20 22 20 28 74 65 73 74 3a 67 65 74 2d 73 74 61 " (test:get-sta
8150: 74 65 20 74 65 73 74 64 61 74 29 20 22 20 53 54 te testdat) " ST
8160: 41 54 55 53 3a 20 22 20 28 74 65 73 74 3a 67 65 ATUS: " (test:ge
8170: 74 2d 73 74 61 74 75 73 20 74 65 73 74 64 61 74 t-status testdat
8180: 29 29 0a 09 20 20 20 28 69 66 20 28 6e 6f 74 20 )).. (if (not
8190: 72 75 6e 66 6c 61 67 29 0a 09 20 20 20 20 20 20 runflag)..
81a0: 20 28 69 66 20 28 6e 6f 74 20 70 61 72 65 6e 74 (if (not parent
81b0: 2d 74 65 73 74 29 0a 09 09 20 20 20 28 64 65 62 -test)... (deb
81c0: 75 67 3a 70 72 69 6e 74 20 31 20 22 4e 4f 54 45 ug:print 1 "NOTE
81d0: 3a 20 4e 6f 74 20 73 74 61 72 74 69 6e 67 20 74 : Not starting t
81e0: 65 73 74 20 22 20 6e 65 77 2d 74 65 73 74 2d 6e est " new-test-n
81f0: 61 6d 65 20 22 20 61 73 20 69 74 20 69 73 20 73 ame " as it is s
8200: 74 61 74 65 20 5c 22 22 20 28 74 65 73 74 3a 67 tate \"" (test:g
8210: 65 74 2d 73 74 61 74 65 20 74 65 73 74 64 61 74 et-state testdat
8220: 29 20 0a 09 09 09 09 22 5c 22 20 61 6e 64 20 73 ) ....."\" and s
8230: 74 61 74 75 73 20 5c 22 22 20 28 74 65 73 74 3a tatus \"" (test:
8240: 67 65 74 2d 73 74 61 74 75 73 20 74 65 73 74 64 get-status testd
8250: 61 74 29 20 22 5c 22 2c 20 75 73 65 20 2d 72 65 at) "\", use -re
8260: 72 75 6e 20 5c 22 22 20 28 74 65 73 74 3a 67 65 run \"" (test:ge
8270: 74 2d 73 74 61 74 75 73 20 74 65 73 74 64 61 74 t-status testdat
8280: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
8290: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
82a0: 20 20 22 5c 22 20 6f 72 20 2d 66 6f 72 63 65 20 "\" or -force
82b0: 74 6f 20 6f 76 65 72 72 69 64 65 22 29 29 0a 09 to override"))..
82c0: 20 20 20 20 20 20 20 3b 3b 20 4e 4f 54 45 3a 20 ;; NOTE:
82d0: 4e 6f 20 6c 6f 6e 67 65 72 20 62 65 20 63 68 65 No longer be che
82e0: 63 6b 69 6e 67 20 70 72 65 72 65 71 75 69 73 69 cking prerequisi
82f0: 74 65 73 20 68 65 72 65 21 20 57 69 6c 6c 20 6e tes here! Will n
8300: 65 76 65 72 20 67 65 74 20 68 65 72 65 20 75 6e ever get here un
8310: 6c 65 73 73 20 70 72 65 72 65 71 73 20 61 72 65 less prereqs are
8320: 0a 09 20 20 20 20 20 20 20 3b 3b 20 20 20 20 20 .. ;;
8330: 20 20 61 6c 72 65 61 64 79 20 6d 65 74 2e 0a 09 already met...
8340: 20 20 20 20 20 20 20 28 69 66 20 28 6e 6f 74 20 (if (not
8350: 28 6c 61 75 6e 63 68 2d 74 65 73 74 20 23 66 20 (launch-test #f
8360: 72 75 6e 2d 69 64 20 72 75 6e 6e 61 6d 65 20 74 run-id runname t
8370: 65 73 74 2d 63 6f 6e 66 20 6b 65 79 76 61 6c 6c est-conf keyvall
8380: 73 74 20 74 65 73 74 2d 6e 61 6d 65 20 74 65 73 st test-name tes
8390: 74 2d 70 61 74 68 20 69 74 65 6d 64 61 74 20 66 t-path itemdat f
83a0: 6c 61 67 73 29 29 0a 09 09 20 20 20 28 62 65 67 lags))... (beg
83b0: 69 6e 0a 09 09 20 20 20 20 20 28 70 72 69 6e 74 in... (print
83c0: 20 22 45 52 52 4f 52 3a 20 46 61 69 6c 65 64 20 "ERROR: Failed
83d0: 74 6f 20 6c 61 75 6e 63 68 20 74 68 65 20 74 65 to launch the te
83e0: 73 74 2e 20 45 78 69 74 69 6e 67 20 61 73 20 73 st. Exiting as s
83f0: 6f 6f 6e 20 61 73 20 70 6f 73 73 69 62 6c 65 22 oon as possible"
8400: 29 0a 09 09 20 20 20 20 20 28 73 65 74 21 20 2a )... (set! *
8410: 67 6c 6f 62 61 6c 65 78 69 74 73 74 61 74 75 73 globalexitstatus
8420: 2a 20 31 29 20 3b 3b 20 0a 09 09 20 20 20 20 20 * 1) ;; ...
8430: 28 70 72 6f 63 65 73 73 2d 73 69 67 6e 61 6c 20 (process-signal
8440: 28 63 75 72 72 65 6e 74 2d 70 72 6f 63 65 73 73 (current-process
8450: 2d 69 64 29 20 73 69 67 6e 61 6c 2f 6b 69 6c 6c -id) signal/kill
8460: 29 29 29 29 29 29 0a 09 28 28 4b 49 4c 4c 45 44 ))))))..((KILLED
8470: 29 20 0a 09 20 28 64 65 62 75 67 3a 70 72 69 6e ) .. (debug:prin
8480: 74 20 31 20 22 4e 4f 54 45 3a 20 22 20 6e 65 77 t 1 "NOTE: " new
8490: 2d 74 65 73 74 2d 6e 61 6d 65 20 22 20 69 73 20 -test-name " is
84a0: 61 6c 72 65 61 64 79 20 72 75 6e 6e 69 6e 67 20 already running
84b0: 6f 72 20 77 61 73 20 65 78 70 6c 69 63 74 6c 79 or was explictly
84c0: 20 6b 69 6c 6c 65 64 2c 20 75 73 65 20 2d 66 6f killed, use -fo
84d0: 72 63 65 20 74 6f 20 6c 61 75 6e 63 68 20 69 74 rce to launch it
84e0: 2e 22 29 29 0a 09 28 28 4c 41 55 4e 43 48 45 44 ."))..((LAUNCHED
84f0: 20 52 45 4d 4f 54 45 48 4f 53 54 53 54 41 52 54 REMOTEHOSTSTART
8500: 20 52 55 4e 4e 49 4e 47 29 20 20 0a 09 20 28 69 RUNNING) .. (i
8510: 66 20 28 3e 20 28 2d 20 28 63 75 72 72 65 6e 74 f (> (- (current
8520: 2d 73 65 63 6f 6e 64 73 29 28 2b 20 28 64 62 3a -seconds)(+ (db:
8530: 74 65 73 74 2d 67 65 74 2d 65 76 65 6e 74 5f 74 test-get-event_t
8540: 69 6d 65 20 74 65 73 74 64 61 74 29 0a 09 09 09 ime testdat)....
8550: 09 20 20 20 20 20 20 20 28 64 62 3a 74 65 73 74 . (db:test
8560: 2d 67 65 74 2d 72 75 6e 5f 64 75 72 61 74 69 6f -get-run_duratio
8570: 6e 20 74 65 73 74 64 61 74 29 29 29 0a 09 09 36 n testdat)))...6
8580: 30 30 29 20 3b 3b 20 69 2e 65 2e 20 6e 6f 20 75 00) ;; i.e. no u
8590: 70 64 61 74 65 20 66 6f 72 20 6d 6f 72 65 20 74 pdate for more t
85a0: 68 61 6e 20 36 30 30 20 73 65 63 6f 6e 64 73 0a han 600 seconds.
85b0: 09 20 20 20 20 20 28 62 65 67 69 6e 0a 09 20 20 . (begin..
85c0: 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e (debug:prin
85d0: 74 20 30 20 22 57 41 52 4e 49 4e 47 3a 20 54 65 t 0 "WARNING: Te
85e0: 73 74 20 22 20 74 65 73 74 2d 6e 61 6d 65 20 22 st " test-name "
85f0: 20 61 70 70 65 61 72 73 20 74 6f 20 62 65 20 64 appears to be d
8600: 65 61 64 2e 20 46 6f 72 63 69 6e 67 20 69 74 20 ead. Forcing it
8610: 74 6f 20 73 74 61 74 65 20 49 4e 43 4f 4d 50 4c to state INCOMPL
8620: 45 54 45 20 61 6e 64 20 73 74 61 74 75 73 20 53 ETE and status S
8630: 54 55 43 4b 2f 44 45 41 44 22 29 0a 09 20 20 20 TUCK/DEAD")..
8640: 20 20 20 20 28 74 65 73 74 73 3a 74 65 73 74 2d (tests:test-
8650: 73 65 74 2d 73 74 61 74 75 73 21 20 74 65 73 74 set-status! test
8660: 2d 69 64 20 22 49 4e 43 4f 4d 50 4c 45 54 45 22 -id "INCOMPLETE"
8670: 20 22 53 54 55 43 4b 2f 44 45 41 44 22 20 22 54 "STUCK/DEAD" "T
8680: 65 73 74 20 69 73 20 73 74 75 63 6b 20 6f 72 20 est is stuck or
8690: 64 65 61 64 22 20 23 66 29 29 0a 09 20 20 20 20 dead" #f))..
86a0: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 32 20 (debug:print 2
86b0: 22 4e 4f 54 45 3a 20 22 20 74 65 73 74 2d 6e 61 "NOTE: " test-na
86c0: 6d 65 20 22 20 69 73 20 61 6c 72 65 61 64 79 20 me " is already
86d0: 72 75 6e 6e 69 6e 67 22 29 29 29 0a 09 28 65 6c running")))..(el
86e0: 73 65 20 20 20 20 20 20 20 28 64 65 62 75 67 3a se (debug:
86f0: 70 72 69 6e 74 20 30 20 22 45 52 52 4f 52 3a 20 print 0 "ERROR:
8700: 46 61 69 6c 65 64 20 74 6f 20 6c 61 75 6e 63 68 Failed to launch
8710: 20 74 65 73 74 20 22 20 6e 65 77 2d 74 65 73 74 test " new-test
8720: 2d 6e 61 6d 65 20 22 2e 20 55 6e 72 65 63 6f 67 -name ". Unrecog
8730: 6e 69 73 65 64 20 73 74 61 74 65 20 22 20 28 74 nised state " (t
8740: 65 73 74 3a 67 65 74 2d 73 74 61 74 65 20 74 65 est:get-state te
8750: 73 74 64 61 74 29 29 29 29 29 29 29 0a 0a 3b 3b stdat)))))))..;;
8760: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8770: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8780: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8790: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
87a0: 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 45 4e 44 20 4f 46 ======.;; END OF
87b0: 20 4e 45 57 20 53 54 55 46 46 0a 3b 3b 3d 3d 3d NEW STUFF.;;===
87c0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
87d0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
87e0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
87f0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8800: 3d 3d 3d 0a 0a 28 64 65 66 69 6e 65 20 28 67 65 ===..(define (ge
8810: 74 2d 64 69 72 2d 75 70 2d 6e 20 64 69 72 20 2e t-dir-up-n dir .
8820: 20 70 61 72 61 6d 73 29 20 0a 20 20 28 6c 65 74 params) . (let
8830: 20 28 28 64 70 61 72 74 73 20 20 28 73 74 72 69 ((dparts (stri
8840: 6e 67 2d 73 70 6c 69 74 20 64 69 72 20 22 2f 22 ng-split dir "/"
8850: 29 29 0a 09 28 63 6f 75 6e 74 20 20 20 28 69 66 ))..(count (if
8860: 20 28 6e 75 6c 6c 3f 20 70 61 72 61 6d 73 29 20 (null? params)
8870: 31 20 28 63 61 72 20 70 61 72 61 6d 73 29 29 29 1 (car params)))
8880: 29 0a 20 20 20 20 28 63 6f 6e 63 20 22 2f 22 20 ). (conc "/"
8890: 28 73 74 72 69 6e 67 2d 69 6e 74 65 72 73 70 65 (string-interspe
88a0: 72 73 65 20 0a 09 20 20 20 20 20 20 20 28 74 61 rse .. (ta
88b0: 6b 65 20 64 70 61 72 74 73 20 28 2d 20 28 6c 65 ke dparts (- (le
88c0: 6e 67 74 68 20 64 70 61 72 74 73 29 20 63 6f 75 ngth dparts) cou
88d0: 6e 74 29 29 0a 09 20 20 20 20 20 20 20 22 2f 22 nt)).. "/"
88e0: 29 29 29 29 0a 3b 3b 20 52 65 6d 6f 76 65 20 72 )))).;; Remove r
88f0: 75 6e 73 0a 3b 3b 20 66 69 65 6c 64 73 20 61 72 uns.;; fields ar
8900: 65 20 70 61 73 73 69 6e 67 20 69 6e 20 74 68 72 e passing in thr
8910: 6f 75 67 68 20 0a 3b 3b 20 61 63 74 69 6f 6e 3a ough .;; action:
8920: 0a 3b 3b 20 20 20 20 27 72 65 6d 6f 76 65 2d 72 .;; 'remove-r
8930: 75 6e 73 0a 3b 3b 20 20 20 20 27 73 65 74 2d 73 uns.;; 'set-s
8940: 74 61 74 65 2d 73 74 61 74 75 73 0a 3b 3b 0a 3b tate-status.;;.;
8950: 3b 20 4e 42 2f 2f 20 73 68 6f 75 6c 64 20 70 61 ; NB// should pa
8960: 73 73 20 69 6e 20 6b 65 79 73 3f 0a 3b 3b 0a 28 ss in keys?.;;.(
8970: 64 65 66 69 6e 65 20 28 72 75 6e 73 3a 6f 70 65 define (runs:ope
8980: 72 61 74 65 2d 6f 6e 20 61 63 74 69 6f 6e 20 72 rate-on action r
8990: 75 6e 6e 61 6d 65 70 61 74 74 20 74 65 73 74 70 unnamepatt testp
89a0: 61 74 74 20 23 21 6b 65 79 20 28 73 74 61 74 65 att #!key (state
89b0: 20 23 66 29 28 73 74 61 74 75 73 20 23 66 29 28 #f)(status #f)(
89c0: 6e 65 77 2d 73 74 61 74 65 2d 73 74 61 74 75 73 new-state-status
89d0: 20 23 66 29 29 0a 20 20 28 63 6f 6d 6d 6f 6e 3a #f)). (common:
89e0: 63 6c 65 61 72 2d 63 61 63 68 65 73 29 20 3b 3b clear-caches) ;;
89f0: 20 63 6c 65 61 72 20 61 6c 6c 20 63 61 63 68 65 clear all cache
8a00: 73 0a 20 20 28 6c 65 74 2a 20 28 28 64 62 20 20 s. (let* ((db
8a10: 20 20 20 20 20 20 20 20 20 23 66 29 0a 09 20 28 #f).. (
8a20: 6b 65 79 73 20 20 20 20 20 20 20 20 20 28 6f 70 keys (op
8a30: 65 6e 2d 72 75 6e 2d 63 6c 6f 73 65 20 64 62 3a en-run-close db:
8a40: 67 65 74 2d 6b 65 79 73 20 64 62 29 29 0a 09 20 get-keys db))..
8a50: 28 72 75 6e 64 61 74 20 20 20 20 20 20 20 28 6f (rundat (o
8a60: 70 65 6e 2d 72 75 6e 2d 63 6c 6f 73 65 20 72 75 pen-run-close ru
8a70: 6e 73 3a 67 65 74 2d 72 75 6e 73 2d 62 79 2d 70 ns:get-runs-by-p
8a80: 61 74 74 20 64 62 20 6b 65 79 73 20 72 75 6e 6e att db keys runn
8a90: 61 6d 65 70 61 74 74 29 29 0a 09 20 28 68 65 61 amepatt)).. (hea
8aa0: 64 65 72 20 20 20 20 20 20 20 28 76 65 63 74 6f der (vecto
8ab0: 72 2d 72 65 66 20 72 75 6e 64 61 74 20 30 29 29 r-ref rundat 0))
8ac0: 0a 09 20 28 72 75 6e 73 20 20 20 20 20 20 20 20 .. (runs
8ad0: 20 28 76 65 63 74 6f 72 2d 72 65 66 20 72 75 6e (vector-ref run
8ae0: 64 61 74 20 31 29 29 0a 09 20 28 73 74 61 74 65 dat 1)).. (state
8af0: 73 20 20 20 20 20 20 20 28 69 66 20 73 74 61 74 s (if stat
8b00: 65 20 20 28 73 74 72 69 6e 67 2d 73 70 6c 69 74 e (string-split
8b10: 20 73 74 61 74 65 20 20 22 2c 22 29 20 27 28 29 state ",") '()
8b20: 29 29 0a 09 20 28 73 74 61 74 75 73 65 73 20 20 )).. (statuses
8b30: 20 20 20 28 69 66 20 73 74 61 74 75 73 20 28 73 (if status (s
8b40: 74 72 69 6e 67 2d 73 70 6c 69 74 20 73 74 61 74 tring-split stat
8b50: 75 73 20 22 2c 22 29 20 27 28 29 29 29 0a 09 20 us ",") '()))..
8b60: 28 73 74 61 74 65 2d 73 74 61 74 75 73 20 28 69 (state-status (i
8b70: 66 20 28 73 74 72 69 6e 67 3f 20 6e 65 77 2d 73 f (string? new-s
8b80: 74 61 74 65 2d 73 74 61 74 75 73 29 20 28 73 74 tate-status) (st
8b90: 72 69 6e 67 2d 73 70 6c 69 74 20 6e 65 77 2d 73 ring-split new-s
8ba0: 74 61 74 65 2d 73 74 61 74 75 73 20 22 2c 22 29 tate-status ",")
8bb0: 20 27 28 23 66 20 23 66 29 29 29 29 0a 20 20 20 '(#f #f)))).
8bc0: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e (debug:print-in
8bd0: 66 6f 20 34 20 22 72 75 6e 73 3a 6f 70 65 72 61 fo 4 "runs:opera
8be0: 74 65 2d 6f 6e 20 3d 3e 20 48 65 61 64 65 72 3a te-on => Header:
8bf0: 20 22 20 68 65 61 64 65 72 20 22 20 61 63 74 69 " header " acti
8c00: 6f 6e 3a 20 22 20 61 63 74 69 6f 6e 20 22 20 6e on: " action " n
8c10: 65 77 2d 73 74 61 74 65 2d 73 74 61 74 75 73 3a ew-state-status:
8c20: 20 22 20 6e 65 77 2d 73 74 61 74 65 2d 73 74 61 " new-state-sta
8c30: 74 75 73 29 0a 20 20 20 20 28 69 66 20 28 3e 20 tus). (if (>
8c40: 32 20 28 6c 65 6e 67 74 68 20 73 74 61 74 65 2d 2 (length state-
8c50: 73 74 61 74 75 73 29 29 0a 09 28 62 65 67 69 6e status))..(begin
8c60: 0a 09 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 .. (debug:print
8c70: 20 30 20 22 45 52 52 4f 52 3a 20 74 68 65 20 70 0 "ERROR: the p
8c80: 61 72 61 6d 65 74 65 72 20 74 6f 20 2d 73 65 74 arameter to -set
8c90: 2d 73 74 61 74 65 2d 73 74 61 74 75 73 20 69 73 -state-status is
8ca0: 20 61 20 63 6f 6d 6d 61 20 64 65 6c 69 6d 69 74 a comma delimit
8cb0: 65 64 20 73 74 72 69 6e 67 2e 20 45 2e 67 2e 20 ed string. E.g.
8cc0: 43 4f 4d 50 4c 45 54 45 44 2c 46 41 49 4c 22 29 COMPLETED,FAIL")
8cd0: 0a 09 20 20 28 65 78 69 74 29 29 29 0a 20 20 20 .. (exit))).
8ce0: 20 28 66 6f 72 2d 65 61 63 68 0a 20 20 20 20 20 (for-each.
8cf0: 28 6c 61 6d 62 64 61 20 28 72 75 6e 29 0a 20 20 (lambda (run).
8d00: 20 20 20 20 20 28 6c 65 74 20 28 28 72 75 6e 6b (let ((runk
8d10: 65 79 20 28 73 74 72 69 6e 67 2d 69 6e 74 65 72 ey (string-inter
8d20: 73 70 65 72 73 65 20 28 6d 61 70 20 28 6c 61 6d sperse (map (lam
8d30: 62 64 61 20 28 6b 29 0a 09 09 09 09 09 09 28 64 bda (k).......(d
8d40: 62 3a 67 65 74 2d 76 61 6c 75 65 2d 62 79 2d 68 b:get-value-by-h
8d50: 65 61 64 65 72 20 72 75 6e 20 68 65 61 64 65 72 eader run header
8d60: 20 28 76 65 63 74 6f 72 2d 72 65 66 20 6b 20 30 (vector-ref k 0
8d70: 29 29 29 20 6b 65 79 73 29 20 22 2f 22 29 29 0a ))) keys) "/")).
8d80: 09 20 20 20 20 20 28 64 69 72 73 2d 74 6f 2d 72 . (dirs-to-r
8d90: 65 6d 6f 76 65 20 28 6d 61 6b 65 2d 68 61 73 68 emove (make-hash
8da0: 2d 74 61 62 6c 65 29 29 29 0a 09 20 28 6c 65 74 -table))).. (let
8db0: 2a 20 28 28 72 75 6e 2d 69 64 20 20 20 20 28 64 * ((run-id (d
8dc0: 62 3a 67 65 74 2d 76 61 6c 75 65 2d 62 79 2d 68 b:get-value-by-h
8dd0: 65 61 64 65 72 20 72 75 6e 20 68 65 61 64 65 72 eader run header
8de0: 20 22 69 64 22 29 29 0a 09 09 28 72 75 6e 2d 73 "id"))...(run-s
8df0: 74 61 74 65 20 28 64 62 3a 67 65 74 2d 76 61 6c tate (db:get-val
8e00: 75 65 2d 62 79 2d 68 65 61 64 65 72 20 72 75 6e ue-by-header run
8e10: 20 68 65 61 64 65 72 20 22 73 74 61 74 65 22 29 header "state")
8e20: 29 0a 09 09 28 74 65 73 74 73 20 20 20 20 20 28 )...(tests (
8e30: 69 66 20 28 6e 6f 74 20 28 65 71 75 61 6c 3f 20 if (not (equal?
8e40: 72 75 6e 2d 73 74 61 74 65 20 22 6c 6f 63 6b 65 run-state "locke
8e50: 64 22 29 29 0a 09 09 09 20 20 20 20 20 20 20 28 d")).... (
8e60: 6f 70 65 6e 2d 72 75 6e 2d 63 6c 6f 73 65 20 64 open-run-close d
8e70: 62 3a 67 65 74 2d 74 65 73 74 73 2d 66 6f 72 2d b:get-tests-for-
8e80: 72 75 6e 20 64 62 20 72 75 6e 2d 69 64 0a 09 09 run db run-id...
8e90: 09 09 09 09 20 20 20 20 20 20 74 65 73 74 70 61 .... testpa
8ea0: 74 74 20 73 74 61 74 65 73 20 73 74 61 74 75 73 tt states status
8eb0: 65 73 0a 09 09 09 09 09 09 20 20 20 20 20 20 6e es....... n
8ec0: 6f 74 2d 69 6e 3a 20 20 23 66 0a 09 09 09 09 09 ot-in: #f......
8ed0: 09 20 20 20 20 20 20 73 6f 72 74 2d 62 79 3a 20 . sort-by:
8ee0: 28 63 61 73 65 20 61 63 74 69 6f 6e 0a 09 09 09 (case action....
8ef0: 09 09 09 09 09 20 28 28 72 65 6d 6f 76 65 2d 72 ..... ((remove-r
8f00: 75 6e 73 29 20 27 72 75 6e 64 69 72 29 0a 09 09 uns) 'rundir)...
8f10: 09 09 09 09 09 09 20 28 65 6c 73 65 20 20 20 20 ...... (else
8f20: 20 20 20 20 20 20 27 65 76 65 6e 74 5f 74 69 6d 'event_tim
8f30: 65 29 29 29 0a 09 09 09 20 20 20 20 20 20 20 27 e))).... '
8f40: 28 29 29 29 0a 09 09 28 6c 61 73 74 74 70 61 74 ()))...(lasttpat
8f50: 68 20 22 2f 64 6f 65 73 2f 6e 6f 74 2f 65 78 69 h "/does/not/exi
8f60: 73 74 2f 49 2f 68 6f 70 65 22 29 29 0a 09 20 20 st/I/hope"))..
8f70: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e (debug:print-in
8f80: 66 6f 20 34 20 22 72 75 6e 73 3a 6f 70 65 72 61 fo 4 "runs:opera
8f90: 74 65 2d 6f 6e 20 72 75 6e 3d 22 20 72 75 6e 20 te-on run=" run
8fa0: 22 2c 20 68 65 61 64 65 72 3d 22 20 68 65 61 64 ", header=" head
8fb0: 65 72 29 0a 09 20 20 20 28 69 66 20 28 6e 6f 74 er).. (if (not
8fc0: 20 28 6e 75 6c 6c 3f 20 74 65 73 74 73 29 29 0a (null? tests)).
8fd0: 09 20 20 20 20 20 20 20 28 62 65 67 69 6e 0a 09 . (begin..
8fe0: 09 20 28 63 61 73 65 20 61 63 74 69 6f 6e 0a 09 . (case action..
8ff0: 09 20 20 20 28 28 72 65 6d 6f 76 65 2d 72 75 6e . ((remove-run
9000: 73 29 0a 09 09 20 20 20 20 28 64 65 62 75 67 3a s)... (debug:
9010: 70 72 69 6e 74 20 31 20 22 52 65 6d 6f 76 69 6e print 1 "Removin
9020: 67 20 74 65 73 74 73 20 66 6f 72 20 72 75 6e 3a g tests for run:
9030: 20 22 20 72 75 6e 6b 65 79 20 22 20 22 20 28 64 " runkey " " (d
9040: 62 3a 67 65 74 2d 76 61 6c 75 65 2d 62 79 2d 68 b:get-value-by-h
9050: 65 61 64 65 72 20 72 75 6e 20 68 65 61 64 65 72 eader run header
9060: 20 22 72 75 6e 6e 61 6d 65 22 29 29 29 0a 09 09 "runname")))...
9070: 20 20 20 28 28 73 65 74 2d 73 74 61 74 65 2d 73 ((set-state-s
9080: 74 61 74 75 73 29 0a 09 09 20 20 20 20 28 64 65 tatus)... (de
9090: 62 75 67 3a 70 72 69 6e 74 20 31 20 22 4d 6f 64 bug:print 1 "Mod
90a0: 69 66 79 69 6e 67 20 73 74 61 74 65 20 61 6e 64 ifying state and
90b0: 20 73 74 61 75 73 20 66 6f 72 20 74 65 73 74 73 staus for tests
90c0: 20 66 6f 72 20 72 75 6e 3a 20 22 20 72 75 6e 6b for run: " runk
90d0: 65 79 20 22 20 22 20 28 64 62 3a 67 65 74 2d 76 ey " " (db:get-v
90e0: 61 6c 75 65 2d 62 79 2d 68 65 61 64 65 72 20 72 alue-by-header r
90f0: 75 6e 20 68 65 61 64 65 72 20 22 72 75 6e 6e 61 un header "runna
9100: 6d 65 22 29 29 29 0a 09 09 20 20 20 28 28 70 72 me")))... ((pr
9110: 69 6e 74 2d 72 75 6e 29 0a 09 09 20 20 20 20 28 int-run)... (
9120: 64 65 62 75 67 3a 70 72 69 6e 74 20 31 20 22 50 debug:print 1 "P
9130: 72 69 6e 74 69 6e 67 20 69 6e 66 6f 20 66 6f 72 rinting info for
9140: 20 72 75 6e 20 22 20 72 75 6e 6b 65 79 20 22 2c run " runkey ",
9150: 20 72 75 6e 3d 22 20 72 75 6e 20 22 2c 20 74 65 run=" run ", te
9160: 73 74 73 3d 22 20 74 65 73 74 73 20 22 2c 20 68 sts=" tests ", h
9170: 65 61 64 65 72 3d 22 20 68 65 61 64 65 72 29 0a eader=" header).
9180: 09 09 20 20 20 20 61 63 74 69 6f 6e 29 0a 09 09 .. action)...
9190: 20 20 20 28 65 6c 73 65 0a 09 09 20 20 20 20 28 (else... (
91a0: 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f debug:print-info
91b0: 20 30 20 22 61 63 74 69 6f 6e 20 6e 6f 74 20 72 0 "action not r
91c0: 65 63 6f 67 6e 69 73 65 64 20 22 20 61 63 74 69 ecognised " acti
91d0: 6f 6e 29 29 29 0a 09 09 20 28 66 6f 72 2d 65 61 on)))... (for-ea
91e0: 63 68 0a 09 09 20 20 28 6c 61 6d 62 64 61 20 28 ch... (lambda (
91f0: 74 65 73 74 29 0a 09 09 20 20 20 20 28 6c 65 74 test)... (let
9200: 2a 20 28 28 69 74 65 6d 2d 70 61 74 68 20 28 64 * ((item-path (d
9210: 62 3a 74 65 73 74 2d 67 65 74 2d 69 74 65 6d 2d b:test-get-item-
9220: 70 61 74 68 20 74 65 73 74 29 29 0a 09 09 09 20 path test))....
9230: 20 20 28 74 65 73 74 2d 6e 61 6d 65 20 28 64 62 (test-name (db
9240: 3a 74 65 73 74 2d 67 65 74 2d 74 65 73 74 6e 61 :test-get-testna
9250: 6d 65 20 74 65 73 74 29 29 0a 09 09 09 20 20 20 me test))....
9260: 28 72 75 6e 2d 64 69 72 20 20 20 28 64 62 3a 74 (run-dir (db:t
9270: 65 73 74 2d 67 65 74 2d 72 75 6e 64 69 72 20 74 est-get-rundir t
9280: 65 73 74 29 29 20 20 20 20 3b 3b 20 72 75 6e 20 est)) ;; run
9290: 64 69 72 20 69 73 20 66 72 6f 6d 20 74 68 65 20 dir is from the
92a0: 6c 69 6e 6b 20 74 72 65 65 0a 09 09 09 20 20 20 link tree....
92b0: 28 72 65 61 6c 2d 64 69 72 20 20 28 69 66 20 28 (real-dir (if (
92c0: 66 69 6c 65 2d 65 78 69 73 74 73 3f 20 72 75 6e file-exists? run
92d0: 2d 64 69 72 29 0a 09 09 09 09 09 20 20 28 72 65 -dir)...... (re
92e0: 73 6f 6c 76 65 2d 70 61 74 68 6e 61 6d 65 20 72 solve-pathname r
92f0: 75 6e 2d 64 69 72 29 0a 09 09 09 09 09 20 20 23 un-dir)...... #
9300: 66 29 29 0a 09 09 09 20 20 20 28 74 65 73 74 2d f)).... (test-
9310: 69 64 20 20 20 28 64 62 3a 74 65 73 74 2d 67 65 id (db:test-ge
9320: 74 2d 69 64 20 74 65 73 74 29 29 29 0a 09 09 20 t-id test)))...
9330: 20 20 20 20 20 3b 3b 20 20 20 28 74 64 62 20 20 ;; (tdb
9340: 20 20 20 20 20 28 64 62 3a 6f 70 65 6e 2d 74 65 (db:open-te
9350: 73 74 2d 64 62 20 72 75 6e 2d 64 69 72 29 29 29 st-db run-dir)))
9360: 0a 09 09 20 20 20 20 20 20 28 64 65 62 75 67 3a ... (debug:
9370: 70 72 69 6e 74 2d 69 6e 66 6f 20 34 20 22 74 65 print-info 4 "te
9380: 73 74 3d 22 20 74 65 73 74 29 20 3b 3b 20 20 20 st=" test) ;;
9390: 22 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 74 " (db:test-get-t
93a0: 65 73 74 6e 61 6d 65 20 74 65 73 74 29 20 22 20 estname test) "
93b0: 69 64 3a 20 22 20 28 64 62 3a 74 65 73 74 2d 67 id: " (db:test-g
93c0: 65 74 2d 69 64 20 74 65 73 74 29 20 22 20 22 20 et-id test) " "
93d0: 69 74 65 6d 2d 70 61 74 68 20 22 20 61 63 74 69 item-path " acti
93e0: 6f 6e 3a 20 22 20 61 63 74 69 6f 6e 29 0a 09 09 on: " action)...
93f0: 20 20 20 20 20 20 28 63 61 73 65 20 61 63 74 69 (case acti
9400: 6f 6e 0a 09 09 09 28 28 72 65 6d 6f 76 65 2d 72 on....((remove-r
9410: 75 6e 73 29 20 3b 3b 20 74 68 65 20 74 64 62 20 uns) ;; the tdb
9420: 69 73 20 66 6f 72 20 66 75 74 75 72 65 20 70 6f is for future po
9430: 73 73 69 62 6c 65 2e 20 0a 09 09 09 20 28 6f 70 ssible. .... (op
9440: 65 6e 2d 72 75 6e 2d 63 6c 6f 73 65 20 64 62 3a en-run-close db:
9450: 64 65 6c 65 74 65 2d 74 65 73 74 2d 72 65 63 6f delete-test-reco
9460: 72 64 73 20 64 62 20 23 66 20 28 64 62 3a 74 65 rds db #f (db:te
9470: 73 74 2d 67 65 74 2d 69 64 20 74 65 73 74 29 29 st-get-id test))
9480: 0a 09 09 09 20 28 64 65 62 75 67 3a 70 72 69 6e .... (debug:prin
9490: 74 2d 69 6e 66 6f 20 31 20 22 41 74 74 65 6d 70 t-info 1 "Attemp
94a0: 74 69 6e 67 20 74 6f 20 72 65 6d 6f 76 65 20 22 ting to remove "
94b0: 20 28 69 66 20 72 65 61 6c 2d 64 69 72 20 28 63 (if real-dir (c
94c0: 6f 6e 63 20 22 20 64 69 72 20 22 20 72 65 61 6c onc " dir " real
94d0: 2d 64 69 72 20 22 20 61 6e 64 20 22 29 20 22 22 -dir " and ") ""
94e0: 29 20 22 20 6c 69 6e 6b 20 22 20 72 75 6e 2d 64 ) " link " run-d
94f0: 69 72 29 0a 09 09 09 20 28 69 66 20 28 61 6e 64 ir).... (if (and
9500: 20 72 65 61 6c 2d 64 69 72 20 0a 09 09 09 09 20 real-dir .....
9510: 20 28 3e 20 28 73 74 72 69 6e 67 2d 6c 65 6e 67 (> (string-leng
9520: 74 68 20 72 65 61 6c 2d 64 69 72 29 20 35 29 0a th real-dir) 5).
9530: 09 09 09 09 20 20 28 66 69 6c 65 2d 65 78 69 73 .... (file-exis
9540: 74 73 3f 20 72 65 61 6c 2d 64 69 72 29 29 20 3b ts? real-dir)) ;
9550: 3b 20 62 61 64 20 68 65 75 72 69 73 74 69 63 20 ; bad heuristic
9560: 62 75 74 20 73 68 6f 75 6c 64 20 70 72 65 76 65 but should preve
9570: 6e 74 20 2f 74 6d 70 20 2f 68 6f 6d 65 20 65 74 nt /tmp /home et
9580: 63 2e 0a 09 09 09 20 20 20 20 20 28 62 65 67 69 c..... (begi
9590: 6e 20 3b 3b 20 6c 65 74 2a 20 28 28 72 65 61 6c n ;; let* ((real
95a0: 70 61 74 68 20 28 72 65 73 6f 6c 76 65 2d 70 61 path (resolve-pa
95b0: 74 68 6e 61 6d 65 20 72 75 6e 2d 64 69 72 29 29 thname run-dir))
95c0: 29 0a 09 09 09 20 20 20 20 20 20 20 28 64 65 62 ).... (deb
95d0: 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 31 20 ug:print-info 1
95e0: 22 52 65 63 75 72 73 69 76 65 6c 79 20 72 65 6d "Recursively rem
95f0: 6f 76 69 6e 67 20 22 20 72 65 61 6c 2d 64 69 72 oving " real-dir
9600: 29 0a 09 09 09 20 20 20 20 20 20 20 28 69 66 20 ).... (if
9610: 28 66 69 6c 65 2d 65 78 69 73 74 73 3f 20 72 65 (file-exists? re
9620: 61 6c 2d 64 69 72 29 0a 09 09 09 09 20 20 20 28 al-dir)..... (
9630: 69 66 20 28 3e 20 28 73 79 73 74 65 6d 20 28 63 if (> (system (c
9640: 6f 6e 63 20 22 72 6d 20 2d 72 66 20 22 20 72 65 onc "rm -rf " re
9650: 61 6c 2d 64 69 72 29 29 20 30 29 0a 09 09 09 09 al-dir)) 0).....
9660: 20 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 (debug:pr
9670: 69 6e 74 20 30 20 22 45 52 52 4f 52 3a 20 54 68 int 0 "ERROR: Th
9680: 65 72 65 20 77 61 73 20 61 20 70 72 6f 62 6c 65 ere was a proble
9690: 6d 20 72 65 6d 6f 76 69 6e 67 20 22 20 72 65 61 m removing " rea
96a0: 6c 2d 64 69 72 20 22 20 77 69 74 68 20 72 6d 20 l-dir " with rm
96b0: 2d 66 22 29 29 0a 09 09 09 09 20 20 20 28 64 65 -f"))..... (de
96c0: 62 75 67 3a 70 72 69 6e 74 20 30 20 22 57 41 52 bug:print 0 "WAR
96d0: 4e 49 4e 47 3a 20 74 65 73 74 20 64 69 72 20 22 NING: test dir "
96e0: 20 72 65 61 6c 2d 64 69 72 20 22 20 61 70 70 65 real-dir " appe
96f0: 61 72 73 20 74 6f 20 6e 6f 74 20 65 78 69 73 74 ars to not exist
9700: 20 6f 72 20 69 73 20 6e 6f 74 20 72 65 61 64 61 or is not reada
9710: 62 6c 65 22 29 29 29 0a 09 09 09 20 20 20 20 20 ble")))....
9720: 28 69 66 20 72 65 61 6c 2d 64 69 72 20 0a 09 09 (if real-dir ...
9730: 09 09 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 .. (debug:print
9740: 30 20 22 57 41 52 4e 49 4e 47 3a 20 64 69 72 65 0 "WARNING: dire
9750: 63 74 6f 72 79 20 22 20 72 65 61 6c 2d 64 69 72 ctory " real-dir
9760: 20 22 20 64 6f 65 73 20 6e 6f 74 20 65 78 69 73 " does not exis
9770: 74 22 29 0a 09 09 09 09 20 28 64 65 62 75 67 3a t")..... (debug:
9780: 70 72 69 6e 74 20 30 20 22 57 41 52 4e 49 4e 47 print 0 "WARNING
9790: 3a 20 6e 6f 20 72 65 61 6c 20 64 69 72 65 63 74 : no real direct
97a0: 6f 72 79 20 63 6f 72 72 6f 73 70 6f 6e 64 69 6e ory corrospondin
97b0: 67 20 74 6f 20 6c 69 6e 6b 20 22 20 72 75 6e 2d g to link " run-
97c0: 64 69 72 20 22 2c 20 6e 6f 74 68 69 6e 67 20 64 dir ", nothing d
97d0: 6f 6e 65 22 29 29 29 0a 09 09 09 20 28 69 66 20 one"))).... (if
97e0: 28 73 79 6d 62 6f 6c 69 63 2d 6c 69 6e 6b 3f 20 (symbolic-link?
97f0: 72 75 6e 2d 64 69 72 29 0a 09 09 09 20 20 20 20 run-dir)....
9800: 20 28 62 65 67 69 6e 0a 09 09 09 20 20 20 20 20 (begin....
9810: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 (debug:print-i
9820: 6e 66 6f 20 31 20 22 52 65 6d 6f 76 69 6e 67 20 nfo 1 "Removing
9830: 73 79 6d 6c 69 6e 6b 20 22 20 72 75 6e 2d 64 69 symlink " run-di
9840: 72 29 0a 09 09 09 20 20 20 20 20 20 20 28 68 61 r).... (ha
9850: 6e 64 6c 65 2d 65 78 63 65 70 74 69 6f 6e 73 0a ndle-exceptions.
9860: 09 09 09 09 65 78 6e 0a 09 09 09 09 28 64 65 62 ....exn.....(deb
9870: 75 67 3a 70 72 69 6e 74 20 30 20 22 45 52 52 4f ug:print 0 "ERRO
9880: 52 3a 20 20 46 61 69 6c 65 64 20 74 6f 20 72 65 R: Failed to re
9890: 6d 6f 76 65 20 73 79 6d 6c 69 6e 6b 20 22 20 72 move symlink " r
98a0: 75 6e 2d 64 69 72 20 28 28 63 6f 6e 64 69 74 69 un-dir ((conditi
98b0: 6f 6e 2d 70 72 6f 70 65 72 74 79 2d 61 63 63 65 on-property-acce
98c0: 73 73 6f 72 20 27 65 78 6e 20 27 6d 65 73 73 61 ssor 'exn 'messa
98d0: 67 65 29 20 65 78 6e 29 20 22 2c 20 61 74 74 65 ge) exn) ", atte
98e0: 6d 70 74 69 6e 67 20 74 6f 20 63 6f 6e 74 69 6e mpting to contin
98f0: 75 65 22 29 0a 09 09 09 09 28 64 65 6c 65 74 65 ue").....(delete
9900: 2d 66 69 6c 65 20 72 75 6e 2d 64 69 72 29 29 29 -file run-dir)))
9910: 0a 09 09 09 20 20 20 20 20 28 69 66 20 28 64 69 .... (if (di
9920: 72 65 63 74 6f 72 79 3f 20 72 75 6e 2d 64 69 72 rectory? run-dir
9930: 29 0a 09 09 09 09 20 28 69 66 20 28 3e 20 28 64 )..... (if (> (d
9940: 69 72 65 63 74 6f 72 79 2d 66 6f 6c 64 20 28 6c irectory-fold (l
9950: 61 6d 62 64 61 20 28 66 20 78 29 28 2b 20 31 20 ambda (f x)(+ 1
9960: 78 29 29 20 30 20 72 75 6e 2d 64 69 72 29 20 30 x)) 0 run-dir) 0
9970: 29 0a 09 09 09 09 20 20 20 20 20 28 64 65 62 75 )..... (debu
9980: 67 3a 70 72 69 6e 74 20 30 20 22 57 41 52 4e 49 g:print 0 "WARNI
9990: 4e 47 3a 20 72 65 66 75 73 69 6e 67 20 74 6f 20 NG: refusing to
99a0: 72 65 6d 6f 76 65 20 22 20 72 75 6e 2d 64 69 72 remove " run-dir
99b0: 20 22 20 61 73 20 69 74 20 69 73 20 6e 6f 74 20 " as it is not
99c0: 65 6d 70 74 79 22 29 0a 09 09 09 09 20 20 20 20 empty").....
99d0: 20 20 28 68 61 6e 64 6c 65 2d 65 78 63 65 70 74 (handle-except
99e0: 69 6f 6e 73 0a 09 09 09 09 20 20 20 20 20 20 20 ions.....
99f0: 65 78 6e 0a 09 09 09 09 20 20 20 20 20 20 20 28 exn..... (
9a00: 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 22 45 debug:print 0 "E
9a10: 52 52 4f 52 3a 20 20 46 61 69 6c 65 64 20 74 6f RROR: Failed to
9a20: 20 72 65 6d 6f 76 65 20 64 69 72 65 63 74 6f 72 remove director
9a30: 79 20 22 20 72 75 6e 2d 64 69 72 20 28 28 63 6f y " run-dir ((co
9a40: 6e 64 69 74 69 6f 6e 2d 70 72 6f 70 65 72 74 79 ndition-property
9a50: 2d 61 63 63 65 73 73 6f 72 20 27 65 78 6e 20 27 -accessor 'exn '
9a60: 6d 65 73 73 61 67 65 29 20 65 78 6e 29 20 22 2c message) exn) ",
9a70: 20 61 74 74 65 6d 70 74 69 6e 67 20 74 6f 20 63 attempting to c
9a80: 6f 6e 74 69 6e 75 65 22 29 0a 09 09 09 09 20 20 ontinue").....
9a90: 20 20 20 20 20 28 64 65 6c 65 74 65 2d 64 69 72 (delete-dir
9aa0: 65 63 74 6f 72 79 20 72 75 6e 2d 64 69 72 29 29 ectory run-dir))
9ab0: 29 0a 09 09 09 09 20 28 69 66 20 72 75 6e 2d 64 )..... (if run-d
9ac0: 69 72 0a 09 09 09 09 20 20 20 20 20 28 64 65 62 ir..... (deb
9ad0: 75 67 3a 70 72 69 6e 74 20 30 20 22 57 41 52 4e ug:print 0 "WARN
9ae0: 49 4e 47 3a 20 6e 6f 74 20 72 65 6d 6f 76 69 6e ING: not removin
9af0: 67 20 22 20 72 75 6e 2d 64 69 72 20 22 20 61 73 g " run-dir " as
9b00: 20 69 74 20 65 69 74 68 65 72 20 64 6f 65 73 6e it either doesn
9b10: 27 74 20 65 78 69 73 74 20 6f 72 20 69 73 20 6e 't exist or is n
9b20: 6f 74 20 61 20 73 79 6d 6c 69 6e 6b 22 29 0a 09 ot a symlink")..
9b30: 09 09 09 20 20 20 20 20 28 64 65 62 75 67 3a 70 ... (debug:p
9b40: 72 69 6e 74 20 30 20 22 4e 4f 54 45 3a 20 74 68 rint 0 "NOTE: th
9b50: 65 20 72 75 6e 20 64 69 72 20 66 6f 72 20 74 68 e run dir for th
9b60: 69 73 20 74 65 73 74 20 69 73 20 75 6e 64 65 66 is test is undef
9b70: 69 6e 65 64 2e 20 54 65 73 74 20 6d 61 79 20 68 ined. Test may h
9b80: 61 76 65 20 61 6c 72 65 61 64 79 20 62 65 65 6e ave already been
9b90: 20 64 65 6c 65 74 65 64 2e 22 29 29 0a 09 09 09 deleted."))....
9ba0: 09 20 29 29 29 0a 09 09 09 28 28 73 65 74 2d 73 . )))....((set-s
9bb0: 74 61 74 65 2d 73 74 61 74 75 73 29 0a 09 09 09 tate-status)....
9bc0: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e (debug:print-in
9bd0: 66 6f 20 32 20 22 6e 65 77 20 73 74 61 74 65 20 fo 2 "new state
9be0: 22 20 28 63 61 72 20 73 74 61 74 65 2d 73 74 61 " (car state-sta
9bf0: 74 75 73 29 20 22 2c 20 6e 65 77 20 73 74 61 74 tus) ", new stat
9c00: 75 73 20 22 20 28 63 61 64 72 20 73 74 61 74 65 us " (cadr state
9c10: 2d 73 74 61 74 75 73 29 29 0a 09 09 09 20 28 6f -status)).... (o
9c20: 70 65 6e 2d 72 75 6e 2d 63 6c 6f 73 65 20 64 62 pen-run-close db
9c30: 3a 74 65 73 74 2d 73 65 74 2d 73 74 61 74 65 2d :test-set-state-
9c40: 73 74 61 74 75 73 2d 62 79 2d 69 64 20 64 62 20 status-by-id db
9c50: 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 69 64 20 (db:test-get-id
9c60: 74 65 73 74 29 20 28 63 61 72 20 73 74 61 74 65 test) (car state
9c70: 2d 73 74 61 74 75 73 29 28 63 61 64 72 20 73 74 -status)(cadr st
9c80: 61 74 65 2d 73 74 61 74 75 73 29 20 23 66 29 29 ate-status) #f))
9c90: 29 29 29 0a 09 09 20 20 28 73 6f 72 74 20 74 65 )))... (sort te
9ca0: 73 74 73 20 28 6c 61 6d 62 64 61 20 28 61 20 62 sts (lambda (a b
9cb0: 29 28 6c 65 74 20 28 28 64 69 72 61 20 28 64 62 )(let ((dira (db
9cc0: 3a 74 65 73 74 2d 67 65 74 2d 72 75 6e 64 69 72 :test-get-rundir
9cd0: 20 61 29 29 0a 09 09 09 09 09 09 20 28 64 69 72 a))....... (dir
9ce0: 62 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 72 b (db:test-get-r
9cf0: 75 6e 64 69 72 20 62 29 29 29 0a 09 09 09 09 09 undir b)))......
9d00: 20 20 20 20 20 28 69 66 20 28 61 6e 64 20 28 73 (if (and (s
9d10: 74 72 69 6e 67 3f 20 64 69 72 61 29 28 73 74 72 tring? dira)(str
9d20: 69 6e 67 3f 20 64 69 72 62 29 29 0a 09 09 09 09 ing? dirb)).....
9d30: 09 09 20 28 3e 20 28 73 74 72 69 6e 67 2d 6c 65 .. (> (string-le
9d40: 6e 67 74 68 20 64 69 72 61 29 28 73 74 72 69 6e ngth dira)(strin
9d50: 67 2d 6c 65 6e 67 74 68 20 64 69 72 62 29 29 0a g-length dirb)).
9d60: 09 09 09 09 09 09 20 23 66 29 29 29 29 29 29 29 ...... #f)))))))
9d70: 0a 09 20 20 20 3b 3b 20 72 65 6d 6f 76 65 20 74 .. ;; remove t
9d80: 68 65 20 72 75 6e 20 69 66 20 7a 65 72 6f 20 74 he run if zero t
9d90: 65 73 74 73 20 72 65 6d 61 69 6e 0a 09 20 20 20 ests remain..
9da0: 28 69 66 20 28 65 71 3f 20 61 63 74 69 6f 6e 20 (if (eq? action
9db0: 27 72 65 6d 6f 76 65 2d 72 75 6e 73 29 0a 09 20 'remove-runs)..
9dc0: 20 20 20 20 20 20 28 6c 65 74 20 28 28 72 65 6d (let ((rem
9dd0: 74 65 73 74 73 20 28 6f 70 65 6e 2d 72 75 6e 2d tests (open-run-
9de0: 63 6c 6f 73 65 20 64 62 3a 67 65 74 2d 74 65 73 close db:get-tes
9df0: 74 73 2d 66 6f 72 2d 72 75 6e 20 64 62 20 28 64 ts-for-run db (d
9e00: 62 3a 67 65 74 2d 76 61 6c 75 65 2d 62 79 2d 68 b:get-value-by-h
9e10: 65 61 64 65 72 20 72 75 6e 20 68 65 61 64 65 72 eader run header
9e20: 20 22 69 64 22 29 20 23 66 20 27 28 22 44 45 4c "id") #f '("DEL
9e30: 45 54 45 44 22 29 20 27 28 22 6e 2f 61 22 29 20 ETED") '("n/a")
9e40: 6e 6f 74 2d 69 6e 3a 20 23 74 29 29 29 0a 09 09 not-in: #t)))...
9e50: 20 28 69 66 20 28 6e 75 6c 6c 3f 20 72 65 6d 74 (if (null? remt
9e60: 65 73 74 73 29 20 3b 3b 20 6e 6f 20 6d 6f 72 65 ests) ;; no more
9e70: 20 74 65 73 74 73 20 72 65 6d 61 69 6e 69 6e 67 tests remaining
9e80: 0a 09 09 20 20 20 20 20 28 6c 65 74 2a 20 28 28 ... (let* ((
9e90: 64 70 61 72 74 73 20 20 28 73 74 72 69 6e 67 2d dparts (string-
9ea0: 73 70 6c 69 74 20 6c 61 73 74 74 70 61 74 68 20 split lasttpath
9eb0: 22 2f 22 29 29 0a 09 09 09 20 20 20 20 28 72 75 "/")).... (ru
9ec0: 6e 70 61 74 68 20 28 63 6f 6e 63 20 22 2f 22 20 npath (conc "/"
9ed0: 28 73 74 72 69 6e 67 2d 69 6e 74 65 72 73 70 65 (string-interspe
9ee0: 72 73 65 20 0a 09 09 09 09 09 09 28 74 61 6b 65 rse .......(take
9ef0: 20 64 70 61 72 74 73 20 28 2d 20 28 6c 65 6e 67 dparts (- (leng
9f00: 74 68 20 64 70 61 72 74 73 29 20 31 29 29 0a 09 th dparts) 1))..
9f10: 09 09 09 09 09 22 2f 22 29 29 29 29 0a 09 09 20 ....."/"))))...
9f20: 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 (debug:pri
9f30: 6e 74 20 31 20 22 52 65 6d 6f 76 69 6e 67 20 72 nt 1 "Removing r
9f40: 75 6e 3a 20 22 20 72 75 6e 6b 65 79 20 22 20 22 un: " runkey " "
9f50: 20 28 64 62 3a 67 65 74 2d 76 61 6c 75 65 2d 62 (db:get-value-b
9f60: 79 2d 68 65 61 64 65 72 20 72 75 6e 20 68 65 61 y-header run hea
9f70: 64 65 72 20 22 72 75 6e 6e 61 6d 65 22 29 20 22 der "runname") "
9f80: 20 61 6e 64 20 72 65 6c 61 74 65 64 20 72 65 63 and related rec
9f90: 6f 72 64 22 29 0a 09 09 20 20 20 20 20 20 20 28 ord")... (
9fa0: 6f 70 65 6e 2d 72 75 6e 2d 63 6c 6f 73 65 20 64 open-run-close d
9fb0: 62 3a 64 65 6c 65 74 65 2d 72 75 6e 20 64 62 20 b:delete-run db
9fc0: 72 75 6e 2d 69 64 29 0a 09 09 20 20 20 20 20 20 run-id)...
9fd0: 20 3b 3b 20 54 68 69 73 20 69 73 20 61 20 70 72 ;; This is a pr
9fe0: 65 74 74 79 20 67 6f 6f 64 20 70 6c 61 63 65 20 etty good place
9ff0: 74 6f 20 70 75 72 67 65 20 6f 6c 64 20 44 45 4c to purge old DEL
a000: 45 54 45 44 20 74 65 73 74 73 0a 09 09 20 20 20 ETED tests...
a010: 20 20 20 20 28 6f 70 65 6e 2d 72 75 6e 2d 63 6c (open-run-cl
a020: 6f 73 65 20 64 62 3a 64 65 6c 65 74 65 2d 74 65 ose db:delete-te
a030: 73 74 73 2d 66 6f 72 2d 72 75 6e 20 64 62 20 72 sts-for-run db r
a040: 75 6e 2d 69 64 29 0a 09 09 20 20 20 20 20 20 20 un-id)...
a050: 28 6f 70 65 6e 2d 72 75 6e 2d 63 6c 6f 73 65 20 (open-run-close
a060: 64 62 3a 64 65 6c 65 74 65 2d 6f 6c 64 2d 64 65 db:delete-old-de
a070: 6c 65 74 65 64 2d 74 65 73 74 2d 72 65 63 6f 72 leted-test-recor
a080: 64 73 20 64 62 29 0a 09 09 20 20 20 20 20 20 20 ds db)...
a090: 28 6f 70 65 6e 2d 72 75 6e 2d 63 6c 6f 73 65 20 (open-run-close
a0a0: 64 62 3a 73 65 74 2d 76 61 72 20 64 62 20 22 44 db:set-var db "D
a0b0: 45 4c 45 54 45 44 5f 54 45 53 54 53 22 20 28 63 ELETED_TESTS" (c
a0c0: 75 72 72 65 6e 74 2d 73 65 63 6f 6e 64 73 29 29 urrent-seconds))
a0d0: 0a 09 09 20 20 20 20 20 20 20 3b 3b 20 6e 65 65 ... ;; nee
a0e0: 64 20 74 6f 20 66 69 67 75 72 65 20 6f 75 74 20 d to figure out
a0f0: 74 68 65 20 70 61 74 68 20 74 6f 20 74 68 65 20 the path to the
a100: 72 75 6e 20 64 69 72 20 61 6e 64 20 72 65 6d 6f run dir and remo
a110: 76 65 20 69 74 20 69 66 20 65 6d 70 74 79 0a 09 ve it if empty..
a120: 09 20 20 20 20 20 20 20 3b 3b 20 20 20 20 28 69 . ;; (i
a130: 66 20 28 6e 75 6c 6c 3f 20 28 67 6c 6f 62 20 28 f (null? (glob (
a140: 63 6f 6e 63 20 72 75 6e 70 61 74 68 20 22 2f 2a conc runpath "/*
a150: 22 29 29 29 0a 09 09 20 20 20 20 20 20 20 3b 3b ")))... ;;
a160: 20 20 20 20 20 20 20 20 28 62 65 67 69 6e 0a 09 (begin..
a170: 09 20 20 20 20 20 20 20 3b 3b 20 09 20 28 64 65 . ;; . (de
a180: 62 75 67 3a 70 72 69 6e 74 20 31 20 22 52 65 6d bug:print 1 "Rem
a190: 6f 76 69 6e 67 20 72 75 6e 20 64 69 72 20 22 20 oving run dir "
a1a0: 72 75 6e 70 61 74 68 29 0a 09 09 20 20 20 20 20 runpath)...
a1b0: 20 20 3b 3b 20 09 20 28 73 79 73 74 65 6d 20 28 ;; . (system (
a1c0: 63 6f 6e 63 20 22 72 6d 64 69 72 20 2d 70 20 22 conc "rmdir -p "
a1d0: 20 72 75 6e 70 61 74 68 29 29 29 29 0a 09 09 20 runpath))))...
a1e0: 20 20 20 20 20 20 29 29 29 29 29 0a 09 20 29 29 ))))).. ))
a1f0: 0a 20 20 20 20 20 72 75 6e 73 29 29 0a 20 20 23 . runs)). #
a200: 74 29 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d t)..;;==========
a210: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
a220: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
a230: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
a240: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 ============.;;
a250: 52 6f 75 74 69 6e 65 73 20 66 6f 72 20 6d 61 6e Routines for man
a260: 69 70 75 6c 61 74 69 6e 67 20 72 75 6e 73 0a 3b ipulating runs.;
a270: 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;===============
a280: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
a290: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
a2a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
a2b0: 3d 3d 3d 3d 3d 3d 3d 0a 0a 3b 3b 20 53 69 6e 63 =======..;; Sinc
a2c0: 65 20 6d 61 6e 79 20 63 61 6c 6c 73 20 74 6f 20 e many calls to
a2d0: 61 20 72 75 6e 20 72 65 71 75 69 72 65 20 70 72 a run require pr
a2e0: 65 74 74 79 20 6d 75 63 68 20 74 68 65 20 73 61 etty much the sa
a2f0: 6d 65 20 73 65 74 75 70 20 0a 3b 3b 20 74 68 69 me setup .;; thi
a300: 73 20 77 72 61 70 70 65 72 20 69 73 20 75 73 65 s wrapper is use
a310: 64 20 74 6f 20 72 65 64 75 63 65 20 74 68 65 20 d to reduce the
a320: 72 65 70 6c 69 63 61 74 69 6f 6e 20 6f 66 20 63 replication of c
a330: 6f 64 65 0a 28 64 65 66 69 6e 65 20 28 67 65 6e ode.(define (gen
a340: 65 72 61 6c 2d 72 75 6e 2d 63 61 6c 6c 20 73 77 eral-run-call sw
a350: 69 74 63 68 6e 61 6d 65 20 61 63 74 69 6f 6e 2d itchname action-
a360: 64 65 73 63 20 70 72 6f 63 29 0a 20 20 28 6c 65 desc proc). (le
a370: 74 20 28 28 72 75 6e 6e 61 6d 65 20 28 61 72 67 t ((runname (arg
a380: 73 3a 67 65 74 2d 61 72 67 20 22 3a 72 75 6e 6e s:get-arg ":runn
a390: 61 6d 65 22 29 29 0a 09 28 74 61 72 67 65 74 20 ame"))..(target
a3a0: 20 28 69 66 20 28 61 72 67 73 3a 67 65 74 2d 61 (if (args:get-a
a3b0: 72 67 20 22 2d 74 61 72 67 65 74 22 29 0a 09 09 rg "-target")...
a3c0: 20 20 20 20 20 28 61 72 67 73 3a 67 65 74 2d 61 (args:get-a
a3d0: 72 67 20 22 2d 74 61 72 67 65 74 22 29 0a 09 09 rg "-target")...
a3e0: 20 20 20 20 20 28 61 72 67 73 3a 67 65 74 2d 61 (args:get-a
a3f0: 72 67 20 22 2d 72 65 71 74 61 72 67 22 29 29 29 rg "-reqtarg")))
a400: 0a 09 28 74 68 31 20 20 20 20 20 23 66 29 29 0a ..(th1 #f)).
a410: 20 20 20 20 28 63 6f 6e 64 0a 20 20 20 20 20 28 (cond. (
a420: 28 6e 6f 74 20 74 61 72 67 65 74 29 0a 20 20 20 (not target).
a430: 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 (debug:print
a440: 30 20 22 45 52 52 4f 52 3a 20 4d 69 73 73 69 6e 0 "ERROR: Missin
a450: 67 20 72 65 71 75 69 72 65 64 20 70 61 72 61 6d g required param
a460: 65 74 65 72 20 66 6f 72 20 22 20 73 77 69 74 63 eter for " switc
a470: 68 6e 61 6d 65 20 22 2c 20 79 6f 75 20 6d 75 73 hname ", you mus
a480: 74 20 73 70 65 63 69 66 79 20 74 68 65 20 74 61 t specify the ta
a490: 72 67 65 74 20 77 69 74 68 20 2d 74 61 72 67 65 rget with -targe
a4a0: 74 22 29 0a 20 20 20 20 20 20 28 65 78 69 74 20 t"). (exit
a4b0: 33 29 29 0a 20 20 20 20 20 28 28 6e 6f 74 20 72 3)). ((not r
a4c0: 75 6e 6e 61 6d 65 29 0a 20 20 20 20 20 20 28 64 unname). (d
a4d0: 65 62 75 67 3a 70 72 69 6e 74 20 30 20 22 45 52 ebug:print 0 "ER
a4e0: 52 4f 52 3a 20 4d 69 73 73 69 6e 67 20 72 65 71 ROR: Missing req
a4f0: 75 69 72 65 64 20 70 61 72 61 6d 65 74 65 72 20 uired parameter
a500: 66 6f 72 20 22 20 73 77 69 74 63 68 6e 61 6d 65 for " switchname
a510: 20 22 2c 20 79 6f 75 20 6d 75 73 74 20 73 70 65 ", you must spe
a520: 63 69 66 79 20 74 68 65 20 72 75 6e 20 6e 61 6d cify the run nam
a530: 65 20 77 69 74 68 20 3a 72 75 6e 6e 61 6d 65 20 e with :runname
a540: 72 75 6e 6e 61 6d 65 22 29 0a 20 20 20 20 20 20 runname").
a550: 28 65 78 69 74 20 33 29 29 0a 20 20 20 20 20 28 (exit 3)). (
a560: 65 6c 73 65 0a 20 20 20 20 20 20 28 6c 65 74 20 else. (let
a570: 28 28 64 62 20 20 20 23 66 29 0a 09 20 20 20 20 ((db #f)..
a580: 28 6b 65 79 73 20 23 66 29 29 0a 09 28 69 66 20 (keys #f))..(if
a590: 28 6e 6f 74 20 28 73 65 74 75 70 2d 66 6f 72 2d (not (setup-for-
a5a0: 72 75 6e 29 29 0a 09 20 20 20 20 28 62 65 67 69 run)).. (begi
a5b0: 6e 20 0a 09 20 20 20 20 20 20 28 64 65 62 75 67 n .. (debug
a5c0: 3a 70 72 69 6e 74 20 30 20 22 46 61 69 6c 65 64 :print 0 "Failed
a5d0: 20 74 6f 20 73 65 74 75 70 2c 20 65 78 69 74 69 to setup, exiti
a5e0: 6e 67 22 29 0a 09 20 20 20 20 20 20 28 65 78 69 ng").. (exi
a5f0: 74 20 31 29 29 29 0a 09 28 69 66 20 28 61 72 67 t 1)))..(if (arg
a600: 73 3a 67 65 74 2d 61 72 67 20 22 2d 73 65 72 76 s:get-arg "-serv
a610: 65 72 22 29 0a 09 20 20 20 20 28 6f 70 65 6e 2d er").. (open-
a620: 72 75 6e 2d 63 6c 6f 73 65 20 73 65 72 76 65 72 run-close server
a630: 3a 73 74 61 72 74 20 64 62 20 28 61 72 67 73 3a :start db (args:
a640: 67 65 74 2d 61 72 67 20 22 2d 73 65 72 76 65 72 get-arg "-server
a650: 22 29 29 29 0a 20 09 20 20 20 20 3b 3b 20 28 69 "))). . ;; (i
a660: 66 20 28 6e 6f 74 20 28 6f 72 20 28 61 72 67 73 f (not (or (args
a670: 3a 67 65 74 2d 61 72 67 20 22 2d 72 75 6e 61 6c :get-arg "-runal
a680: 6c 22 29 20 20 20 20 20 3b 3b 20 72 75 6e 61 6c l") ;; runal
a690: 6c 20 61 6e 64 20 72 75 6e 74 65 73 74 73 20 61 l and runtests a
a6a0: 72 65 20 61 6c 6c 6f 77 65 64 20 74 6f 20 62 65 re allowed to be
a6b0: 20 73 65 72 76 65 72 73 0a 20 09 20 20 20 20 3b servers. . ;
a6c0: 3b 20 20 20 20 20 09 20 28 61 72 67 73 3a 67 65 ; . (args:ge
a6d0: 74 2d 61 72 67 20 22 2d 72 75 6e 74 65 73 74 73 t-arg "-runtests
a6e0: 22 29 29 29 0a 09 20 20 20 20 3b 3b 20 20 20 20 "))).. ;;
a6f0: 20 28 63 6c 69 65 6e 74 3a 73 65 74 75 70 29 20 (client:setup)
a700: 3b 3b 20 54 68 69 73 20 69 73 20 61 20 64 75 70 ;; This is a dup
a710: 6c 69 63 61 74 65 20 73 74 61 72 74 75 70 21 21 licate startup!!
a720: 21 3f 3f 3f 20 42 55 47 3f 0a 09 20 20 20 20 3b !??? BUG?.. ;
a730: 3b 20 20 20 20 20 29 29 0a 09 28 73 65 74 21 20 ; ))..(set!
a740: 6b 65 79 73 20 28 6f 70 65 6e 2d 72 75 6e 2d 63 keys (open-run-c
a750: 6c 6f 73 65 20 64 62 3a 67 65 74 2d 6b 65 79 73 lose db:get-keys
a760: 20 64 62 29 29 0a 09 3b 3b 20 68 61 76 65 20 65 db))..;; have e
a770: 6e 6f 75 67 68 20 74 6f 20 70 72 6f 63 65 73 73 nough to process
a780: 20 2d 74 61 72 67 65 74 20 6f 72 20 2d 72 65 71 -target or -req
a790: 74 61 72 67 20 68 65 72 65 0a 09 28 69 66 20 28 targ here..(if (
a7a0: 61 72 67 73 3a 67 65 74 2d 61 72 67 20 22 2d 72 args:get-arg "-r
a7b0: 65 71 74 61 72 67 22 29 0a 09 20 20 20 20 28 6c eqtarg").. (l
a7c0: 65 74 2a 20 28 28 72 75 6e 63 6f 6e 66 69 67 66 et* ((runconfigf
a7d0: 20 28 63 6f 6e 63 20 20 2a 74 6f 70 70 61 74 68 (conc *toppath
a7e0: 2a 20 22 2f 72 75 6e 63 6f 6e 66 69 67 73 2e 63 * "/runconfigs.c
a7f0: 6f 6e 66 69 67 22 29 29 20 3b 3b 20 44 4f 20 4e onfig")) ;; DO N
a800: 4f 54 20 45 56 41 4c 55 41 54 45 20 41 4c 4c 20 OT EVALUATE ALL
a810: 0a 09 09 20 20 20 28 72 75 6e 63 6f 6e 66 69 67 ... (runconfig
a820: 20 20 28 72 65 61 64 2d 63 6f 6e 66 69 67 20 72 (read-config r
a830: 75 6e 63 6f 6e 66 69 67 66 20 23 66 20 23 74 20 unconfigf #f #t
a840: 65 6e 76 69 72 6f 6e 2d 70 61 74 74 3a 20 23 66 environ-patt: #f
a850: 29 29 29 20 0a 09 20 20 20 20 20 20 28 69 66 20 ))) .. (if
a860: 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f (hash-table-ref/
a870: 64 65 66 61 75 6c 74 20 72 75 6e 63 6f 6e 66 69 default runconfi
a880: 67 20 28 61 72 67 73 3a 67 65 74 2d 61 72 67 20 g (args:get-arg
a890: 22 2d 72 65 71 74 61 72 67 22 29 20 23 66 29 0a "-reqtarg") #f).
a8a0: 09 09 20 20 28 6b 65 79 73 3a 74 61 72 67 65 74 .. (keys:target
a8b0: 2d 73 65 74 2d 61 72 67 73 20 6b 65 79 73 20 28 -set-args keys (
a8c0: 61 72 67 73 3a 67 65 74 2d 61 72 67 20 22 2d 72 args:get-arg "-r
a8d0: 65 71 74 61 72 67 22 29 20 61 72 67 73 3a 61 72 eqtarg") args:ar
a8e0: 67 2d 68 61 73 68 29 0a 09 09 20 20 28 62 65 67 g-hash)... (beg
a8f0: 69 6e 0a 09 09 20 20 20 20 28 64 65 62 75 67 3a in... (debug:
a900: 70 72 69 6e 74 20 30 20 22 45 52 52 4f 52 3a 20 print 0 "ERROR:
a910: 5b 22 20 28 61 72 67 73 3a 67 65 74 2d 61 72 67 [" (args:get-arg
a920: 20 22 2d 72 65 71 74 61 72 67 22 29 20 22 5d 20 "-reqtarg") "]
a930: 6e 6f 74 20 66 6f 75 6e 64 20 69 6e 20 22 20 72 not found in " r
a940: 75 6e 63 6f 6e 66 69 67 66 29 0a 09 09 20 20 20 unconfigf)...
a950: 20 28 69 66 20 64 62 20 28 73 71 6c 69 74 65 33 (if db (sqlite3
a960: 3a 66 69 6e 61 6c 69 7a 65 21 20 64 62 29 29 0a :finalize! db)).
a970: 09 09 20 20 20 20 28 65 78 69 74 20 31 29 29 29 .. (exit 1)))
a980: 29 0a 09 20 20 20 20 28 69 66 20 28 61 72 67 73 ).. (if (args
a990: 3a 67 65 74 2d 61 72 67 20 22 2d 74 61 72 67 65 :get-arg "-targe
a9a0: 74 22 29 0a 09 09 28 6b 65 79 73 3a 74 61 72 67 t")...(keys:targ
a9b0: 65 74 2d 73 65 74 2d 61 72 67 73 20 6b 65 79 73 et-set-args keys
a9c0: 20 28 61 72 67 73 3a 67 65 74 2d 61 72 67 20 22 (args:get-arg "
a9d0: 2d 74 61 72 67 65 74 22 20 61 72 67 73 3a 61 72 -target" args:ar
a9e0: 67 2d 68 61 73 68 29 20 61 72 67 73 3a 61 72 67 g-hash) args:arg
a9f0: 2d 68 61 73 68 29 29 29 0a 09 28 69 66 20 28 6e -hash)))..(if (n
aa00: 6f 74 20 28 63 61 72 20 2a 63 6f 6e 66 69 67 69 ot (car *configi
aa10: 6e 66 6f 2a 29 29 0a 09 20 20 20 20 28 62 65 67 nfo*)).. (beg
aa20: 69 6e 0a 09 20 20 20 20 20 20 28 64 65 62 75 67 in.. (debug
aa30: 3a 70 72 69 6e 74 20 30 20 22 45 52 52 4f 52 3a :print 0 "ERROR:
aa40: 20 41 74 74 65 6d 70 74 65 64 20 74 6f 20 22 20 Attempted to "
aa50: 61 63 74 69 6f 6e 2d 64 65 73 63 20 22 20 62 75 action-desc " bu
aa60: 74 20 72 75 6e 20 61 72 65 61 20 63 6f 6e 66 69 t run area confi
aa70: 67 20 66 69 6c 65 20 6e 6f 74 20 66 6f 75 6e 64 g file not found
aa80: 22 29 0a 09 20 20 20 20 20 20 28 65 78 69 74 20 ").. (exit
aa90: 31 29 29 0a 09 20 20 20 20 3b 3b 20 45 78 74 72 1)).. ;; Extr
aaa0: 61 63 74 20 6f 75 74 20 73 74 75 66 66 20 6e 65 act out stuff ne
aab0: 65 64 65 64 20 69 6e 20 6d 6f 73 74 20 6f 72 20 eded in most or
aac0: 6d 61 6e 79 20 63 61 6c 6c 73 0a 09 20 20 20 20 many calls..
aad0: 3b 3b 20 68 65 72 65 20 74 68 65 6e 20 63 61 6c ;; here then cal
aae0: 6c 20 70 72 6f 63 0a 09 20 20 20 20 28 6c 65 74 l proc.. (let
aaf0: 2a 20 28 28 6b 65 79 6e 61 6d 65 73 20 20 20 28 * ((keynames (
ab00: 6d 61 70 20 6b 65 79 3a 67 65 74 2d 66 69 65 6c map key:get-fiel
ab10: 64 6e 61 6d 65 20 6b 65 79 73 29 29 0a 09 09 20 dname keys))...
ab20: 20 20 28 6b 65 79 76 61 6c 6c 73 74 20 20 28 6b (keyvallst (k
ab30: 65 79 73 2d 3e 76 61 6c 6c 69 73 74 20 6b 65 79 eys->vallist key
ab40: 73 20 23 74 29 29 29 0a 09 20 20 20 20 20 20 28 s #t))).. (
ab50: 70 72 6f 63 20 74 61 72 67 65 74 20 72 75 6e 6e proc target runn
ab60: 61 6d 65 20 6b 65 79 73 20 6b 65 79 6e 61 6d 65 ame keys keyname
ab70: 73 20 6b 65 79 76 61 6c 6c 73 74 29 29 29 0a 09 s keyvallst)))..
ab80: 28 69 66 20 74 68 31 20 28 74 68 72 65 61 64 2d (if th1 (thread-
ab90: 6a 6f 69 6e 21 20 74 68 31 29 29 0a 09 28 69 66 join! th1))..(if
aba0: 20 64 62 20 28 73 71 6c 69 74 65 33 3a 66 69 6e db (sqlite3:fin
abb0: 61 6c 69 7a 65 21 20 64 62 29 29 0a 09 28 73 65 alize! db))..(se
abc0: 74 21 20 2a 64 69 64 73 6f 6d 65 74 68 69 6e 67 t! *didsomething
abd0: 2a 20 23 74 29 29 29 29 29 29 0a 0a 3b 3b 3d 3d * #t))))))..;;==
abe0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
abf0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
ac00: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
ac10: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
ac20: 3d 3d 3d 3d 0a 3b 3b 20 4c 6f 63 6b 2f 75 6e 6c ====.;; Lock/unl
ac30: 6f 63 6b 20 72 75 6e 73 0a 3b 3b 3d 3d 3d 3d 3d ock runs.;;=====
ac40: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
ac50: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
ac60: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
ac70: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
ac80: 3d 0a 0a 28 64 65 66 69 6e 65 20 28 72 75 6e 73 =..(define (runs
ac90: 3a 68 61 6e 64 6c 65 2d 6c 6f 63 6b 69 6e 67 20 :handle-locking
aca0: 74 61 72 67 65 74 20 6b 65 79 73 20 72 75 6e 6e target keys runn
acb0: 61 6d 65 20 6c 6f 63 6b 20 75 6e 6c 6f 63 6b 20 ame lock unlock
acc0: 75 73 65 72 29 0a 20 20 28 6c 65 74 2a 20 28 28 user). (let* ((
acd0: 64 62 20 20 20 20 20 20 20 23 66 29 0a 09 20 28 db #f).. (
ace0: 72 75 6e 64 61 74 20 20 20 28 6f 70 65 6e 2d 72 rundat (open-r
acf0: 75 6e 2d 63 6c 6f 73 65 20 72 75 6e 73 3a 67 65 un-close runs:ge
ad00: 74 2d 72 75 6e 73 2d 62 79 2d 70 61 74 74 20 64 t-runs-by-patt d
ad10: 62 20 6b 65 79 73 20 72 75 6e 6e 61 6d 65 29 29 b keys runname))
ad20: 0a 09 20 28 68 65 61 64 65 72 20 20 20 28 76 65 .. (header (ve
ad30: 63 74 6f 72 2d 72 65 66 20 72 75 6e 64 61 74 20 ctor-ref rundat
ad40: 30 29 29 0a 09 20 28 72 75 6e 73 20 20 20 20 20 0)).. (runs
ad50: 28 76 65 63 74 6f 72 2d 72 65 66 20 72 75 6e 64 (vector-ref rund
ad60: 61 74 20 31 29 29 29 0a 20 20 20 20 28 66 6f 72 at 1))). (for
ad70: 2d 65 61 63 68 20 28 6c 61 6d 62 64 61 20 28 72 -each (lambda (r
ad80: 75 6e 29 0a 09 09 28 6c 65 74 20 28 28 72 75 6e un)...(let ((run
ad90: 2d 69 64 20 28 64 62 3a 67 65 74 2d 76 61 6c 75 -id (db:get-valu
ada0: 65 2d 62 79 2d 68 65 61 64 65 72 20 72 75 6e 20 e-by-header run
adb0: 68 65 61 64 65 72 20 22 69 64 22 29 29 29 0a 09 header "id")))..
adc0: 09 20 20 28 69 66 20 28 6f 72 20 6c 6f 63 6b 0a . (if (or lock.
add0: 09 09 09 20 20 28 61 6e 64 20 75 6e 6c 6f 63 6b ... (and unlock
ade0: 0a 09 09 09 20 20 20 20 20 20 20 28 62 65 67 69 .... (begi
adf0: 6e 0a 09 09 09 09 20 28 70 72 69 6e 74 20 22 44 n..... (print "D
ae00: 6f 20 79 6f 75 20 72 65 61 6c 6c 79 20 77 69 73 o you really wis
ae10: 68 20 74 6f 20 75 6e 6c 6f 63 6b 20 72 75 6e 20 h to unlock run
ae20: 22 20 72 75 6e 2d 69 64 20 22 3f 5c 6e 20 20 20 " run-id "?\n
ae30: 79 2f 6e 3a 20 22 29 0a 09 09 09 09 20 28 65 71 y/n: ")..... (eq
ae40: 75 61 6c 3f 20 22 79 22 20 28 72 65 61 64 2d 6c ual? "y" (read-l
ae50: 69 6e 65 29 29 29 29 29 0a 09 09 20 20 20 20 20 ine)))))...
ae60: 20 28 6f 70 65 6e 2d 72 75 6e 2d 63 6c 6f 73 65 (open-run-close
ae70: 20 64 62 3a 6c 6f 63 6b 2f 75 6e 6c 6f 63 6b 2d db:lock/unlock-
ae80: 72 75 6e 20 64 62 20 72 75 6e 2d 69 64 20 6c 6f run db run-id lo
ae90: 63 6b 20 75 6e 6c 6f 63 6b 20 75 73 65 72 29 0a ck unlock user).
aea0: 09 09 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 .. (debug:p
aeb0: 72 69 6e 74 2d 69 6e 66 6f 20 30 20 22 53 6b 69 rint-info 0 "Ski
aec0: 70 70 69 6e 67 20 6c 6f 63 6b 2f 75 6e 6c 6f 63 pping lock/unloc
aed0: 6b 20 6f 6e 20 22 20 72 75 6e 2d 69 64 29 29 29 k on " run-id)))
aee0: 29 0a 09 20 20 20 20 20 20 72 75 6e 73 29 29 29 ).. runs)))
aef0: 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d .;;=============
af00: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
af10: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
af20: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
af30: 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 52 6f 6c =========.;; Rol
af40: 6c 75 70 20 72 75 6e 73 0a 3b 3b 3d 3d 3d 3d 3d lup runs.;;=====
af50: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
af60: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
af70: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
af80: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
af90: 3d 0a 0a 3b 3b 20 55 70 64 61 74 65 20 74 68 65 =..;; Update the
afa0: 20 74 65 73 74 5f 6d 65 74 61 20 74 61 62 6c 65 test_meta table
afb0: 20 66 6f 72 20 74 68 69 73 20 74 65 73 74 0a 28 for this test.(
afc0: 64 65 66 69 6e 65 20 28 72 75 6e 73 3a 75 70 64 define (runs:upd
afd0: 61 74 65 2d 74 65 73 74 5f 6d 65 74 61 20 64 62 ate-test_meta db
afe0: 20 74 65 73 74 2d 6e 61 6d 65 20 74 65 73 74 2d test-name test-
aff0: 63 6f 6e 66 29 0a 20 20 28 6c 65 74 20 28 28 63 conf). (let ((c
b000: 75 72 72 72 65 63 6f 72 64 20 28 6f 70 65 6e 2d urrrecord (open-
b010: 72 75 6e 2d 63 6c 6f 73 65 20 64 62 3a 74 65 73 run-close db:tes
b020: 74 6d 65 74 61 2d 67 65 74 2d 72 65 63 6f 72 64 tmeta-get-record
b030: 20 64 62 20 74 65 73 74 2d 6e 61 6d 65 29 29 29 db test-name)))
b040: 0a 20 20 20 20 28 69 66 20 28 6e 6f 74 20 63 75 . (if (not cu
b050: 72 72 72 65 63 6f 72 64 29 0a 09 28 62 65 67 69 rrrecord)..(begi
b060: 6e 0a 09 20 20 28 73 65 74 21 20 63 75 72 72 72 n.. (set! currr
b070: 65 63 6f 72 64 20 28 6d 61 6b 65 2d 76 65 63 74 ecord (make-vect
b080: 6f 72 20 31 30 20 23 66 29 29 0a 09 20 20 28 6f or 10 #f)).. (o
b090: 70 65 6e 2d 72 75 6e 2d 63 6c 6f 73 65 20 64 62 pen-run-close db
b0a0: 3a 74 65 73 74 6d 65 74 61 2d 61 64 64 2d 72 65 :testmeta-add-re
b0b0: 63 6f 72 64 20 64 62 20 74 65 73 74 2d 6e 61 6d cord db test-nam
b0c0: 65 29 29 29 0a 20 20 20 20 28 66 6f 72 2d 65 61 e))). (for-ea
b0d0: 63 68 20 0a 20 20 20 20 20 28 6c 61 6d 62 64 61 ch . (lambda
b0e0: 20 28 6b 65 79 29 0a 20 20 20 20 20 20 20 28 6c (key). (l
b0f0: 65 74 2a 20 28 28 69 64 78 20 28 63 61 64 72 20 et* ((idx (cadr
b100: 6b 65 79 29 29 0a 09 20 20 20 20 20 20 28 66 6c key)).. (fl
b110: 64 20 28 63 61 72 20 20 6b 65 79 29 29 0a 09 20 d (car key))..
b120: 20 20 20 20 20 28 76 61 6c 20 28 63 6f 6e 66 69 (val (confi
b130: 67 2d 6c 6f 6f 6b 75 70 20 74 65 73 74 2d 63 6f g-lookup test-co
b140: 6e 66 20 22 74 65 73 74 5f 6d 65 74 61 22 20 66 nf "test_meta" f
b150: 6c 64 29 29 29 0a 09 20 3b 3b 20 28 64 65 62 75 ld))).. ;; (debu
b160: 67 3a 70 72 69 6e 74 20 35 20 22 69 64 78 3a 20 g:print 5 "idx:
b170: 22 20 69 64 78 20 22 20 66 6c 64 3a 20 22 20 66 " idx " fld: " f
b180: 6c 64 20 22 20 76 61 6c 3a 20 22 20 76 61 6c 29 ld " val: " val)
b190: 0a 09 20 28 69 66 20 28 61 6e 64 20 76 61 6c 20 .. (if (and val
b1a0: 28 6e 6f 74 20 28 65 71 75 61 6c 3f 20 28 76 65 (not (equal? (ve
b1b0: 63 74 6f 72 2d 72 65 66 20 63 75 72 72 72 65 63 ctor-ref currrec
b1c0: 6f 72 64 20 69 64 78 29 20 76 61 6c 29 29 29 0a ord idx) val))).
b1d0: 09 20 20 20 20 20 28 62 65 67 69 6e 0a 09 20 20 . (begin..
b1e0: 20 20 20 20 20 28 70 72 69 6e 74 20 22 55 70 64 (print "Upd
b1f0: 61 74 69 6e 67 20 22 20 74 65 73 74 2d 6e 61 6d ating " test-nam
b200: 65 20 22 20 22 20 66 6c 64 20 22 20 74 6f 20 22 e " " fld " to "
b210: 20 76 61 6c 29 0a 09 20 20 20 20 20 20 20 28 6f val).. (o
b220: 70 65 6e 2d 72 75 6e 2d 63 6c 6f 73 65 20 64 62 pen-run-close db
b230: 3a 74 65 73 74 6d 65 74 61 2d 75 70 64 61 74 65 :testmeta-update
b240: 2d 66 69 65 6c 64 20 64 62 20 74 65 73 74 2d 6e -field db test-n
b250: 61 6d 65 20 66 6c 64 20 76 61 6c 29 29 29 29 29 ame fld val)))))
b260: 0a 20 20 20 20 20 27 28 28 22 61 75 74 68 6f 72 . '(("author
b270: 22 20 32 29 28 22 6f 77 6e 65 72 22 20 33 29 28 " 2)("owner" 3)(
b280: 22 64 65 73 63 72 69 70 74 69 6f 6e 22 20 34 29 "description" 4)
b290: 28 22 72 65 76 69 65 77 65 64 22 20 35 29 28 22 ("reviewed" 5)("
b2a0: 74 61 67 73 22 20 39 29 29 29 29 29 0a 0a 3b 3b tags" 9)))))..;;
b2b0: 20 55 70 64 61 74 65 20 74 65 73 74 5f 6d 65 74 Update test_met
b2c0: 61 20 66 6f 72 20 61 6c 6c 20 74 65 73 74 73 0a a for all tests.
b2d0: 28 64 65 66 69 6e 65 20 28 72 75 6e 73 3a 75 70 (define (runs:up
b2e0: 64 61 74 65 2d 61 6c 6c 2d 74 65 73 74 5f 6d 65 date-all-test_me
b2f0: 74 61 20 64 62 29 0a 20 20 28 6c 65 74 20 28 28 ta db). (let ((
b300: 74 65 73 74 2d 6e 61 6d 65 73 20 28 67 65 74 2d test-names (get-
b310: 61 6c 6c 2d 6c 65 67 61 6c 2d 74 65 73 74 73 29 all-legal-tests)
b320: 29 29 0a 20 20 20 20 28 66 6f 72 2d 65 61 63 68 )). (for-each
b330: 20 0a 20 20 20 20 20 28 6c 61 6d 62 64 61 20 28 . (lambda (
b340: 74 65 73 74 2d 6e 61 6d 65 29 0a 20 20 20 20 20 test-name).
b350: 20 20 28 6c 65 74 2a 20 28 28 74 65 73 74 2d 70 (let* ((test-p
b360: 61 74 68 20 20 20 20 28 63 6f 6e 63 20 2a 74 6f ath (conc *to
b370: 70 70 61 74 68 2a 20 22 2f 74 65 73 74 73 2f 22 ppath* "/tests/"
b380: 20 74 65 73 74 2d 6e 61 6d 65 29 29 0a 09 20 20 test-name))..
b390: 20 20 20 20 28 74 65 73 74 2d 63 6f 6e 66 69 67 (test-config
b3a0: 66 20 28 63 6f 6e 63 20 74 65 73 74 2d 70 61 74 f (conc test-pat
b3b0: 68 20 22 2f 74 65 73 74 63 6f 6e 66 69 67 22 29 h "/testconfig")
b3c0: 29 0a 09 20 20 20 20 20 20 28 74 65 73 74 65 78 ).. (testex
b3d0: 69 73 74 73 20 20 20 28 61 6e 64 20 28 66 69 6c ists (and (fil
b3e0: 65 2d 65 78 69 73 74 73 3f 20 74 65 73 74 2d 63 e-exists? test-c
b3f0: 6f 6e 66 69 67 66 29 28 66 69 6c 65 2d 72 65 61 onfigf)(file-rea
b400: 64 2d 61 63 63 65 73 73 3f 20 74 65 73 74 2d 63 d-access? test-c
b410: 6f 6e 66 69 67 66 29 29 29 0a 09 20 20 20 20 20 onfigf)))..
b420: 20 3b 3b 20 72 65 61 64 20 63 6f 6e 66 69 67 73 ;; read configs
b430: 20 77 69 74 68 20 74 72 69 63 6b 73 20 74 75 72 with tricks tur
b440: 6e 65 64 20 6f 66 66 20 28 69 2e 65 2e 20 6e 6f ned off (i.e. no
b450: 20 73 79 73 74 65 6d 29 0a 09 20 20 20 20 20 20 system)..
b460: 28 74 65 73 74 2d 63 6f 6e 66 20 20 20 20 28 69 (test-conf (i
b470: 66 20 74 65 73 74 65 78 69 73 74 73 20 28 72 65 f testexists (re
b480: 61 64 2d 63 6f 6e 66 69 67 20 74 65 73 74 2d 63 ad-config test-c
b490: 6f 6e 66 69 67 66 20 23 66 20 23 66 29 28 6d 61 onfigf #f #f)(ma
b4a0: 6b 65 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 29 ke-hash-table)))
b4b0: 29 0a 09 20 3b 3b 20 75 73 65 20 74 68 65 20 6f ).. ;; use the o
b4c0: 70 65 6e 2d 72 75 6e 2d 63 6c 6f 73 65 20 69 6e pen-run-close in
b4d0: 73 74 65 61 64 20 6f 66 20 70 61 73 73 69 6e 67 stead of passing
b4e0: 20 69 6e 20 64 62 0a 09 20 28 72 75 6e 73 3a 75 in db.. (runs:u
b4f0: 70 64 61 74 65 2d 74 65 73 74 5f 6d 65 74 61 20 pdate-test_meta
b500: 23 66 20 74 65 73 74 2d 6e 61 6d 65 20 74 65 73 #f test-name tes
b510: 74 2d 63 6f 6e 66 29 29 29 0a 20 20 20 20 20 74 t-conf))). t
b520: 65 73 74 2d 6e 61 6d 65 73 29 29 29 0a 0a 3b 3b est-names)))..;;
b530: 20 54 68 69 73 20 63 6f 75 6c 64 20 70 72 6f 62 This could prob
b540: 61 62 6c 79 20 62 65 20 72 65 66 61 63 74 6f 72 ably be refactor
b550: 65 64 20 69 6e 74 6f 20 6f 6e 65 20 63 6f 6d 70 ed into one comp
b560: 6c 65 78 20 71 75 65 72 79 20 2e 2e 2e 0a 28 64 lex query ....(d
b570: 65 66 69 6e 65 20 28 72 75 6e 73 3a 72 6f 6c 6c efine (runs:roll
b580: 75 70 2d 72 75 6e 20 6b 65 79 73 20 6b 65 79 76 up-run keys keyv
b590: 61 6c 6c 73 74 20 72 75 6e 6e 61 6d 65 20 75 73 allst runname us
b5a0: 65 72 29 20 3b 3b 20 77 61 73 20 74 61 72 67 65 er) ;; was targe
b5b0: 74 2c 20 6e 6f 77 20 6b 65 79 76 61 6c 6c 73 74 t, now keyvallst
b5c0: 0a 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 . (debug:print
b5d0: 34 20 22 72 75 6e 73 3a 72 6f 6c 6c 75 70 2d 72 4 "runs:rollup-r
b5e0: 75 6e 2c 20 6b 65 79 73 3a 20 22 20 6b 65 79 73 un, keys: " keys
b5f0: 20 22 20 6b 65 79 76 61 6c 6c 73 74 3a 20 22 20 " keyvallst: "
b600: 6b 65 79 76 61 6c 6c 73 74 20 22 20 3a 72 75 6e keyvallst " :run
b610: 6e 61 6d 65 20 22 20 72 75 6e 6e 61 6d 65 20 22 name " runname "
b620: 20 75 73 65 72 3a 20 22 20 75 73 65 72 29 0a 20 user: " user).
b630: 20 28 6c 65 74 2a 20 28 28 64 62 20 20 20 20 20 (let* ((db
b640: 20 20 20 20 20 20 20 20 20 23 66 29 20 3b 3b 20 #f) ;;
b650: 28 6b 65 79 76 61 6c 6c 6c 73 74 20 20 20 20 20 (keyvalllst
b660: 20 28 6b 65 79 73 3a 74 61 72 67 65 74 2d 3e 6b (keys:target->k
b670: 65 79 76 61 6c 20 6b 65 79 73 20 74 61 72 67 65 eyval keys targe
b680: 74 29 29 0a 09 20 28 6e 65 77 2d 72 75 6e 2d 69 t)).. (new-run-i
b690: 64 20 20 20 20 20 20 28 6f 70 65 6e 2d 72 75 6e d (open-run
b6a0: 2d 63 6c 6f 73 65 20 72 75 6e 73 3a 72 65 67 69 -close runs:regi
b6b0: 73 74 65 72 2d 72 75 6e 20 64 62 20 6b 65 79 73 ster-run db keys
b6c0: 20 6b 65 79 76 61 6c 6c 73 74 20 72 75 6e 6e 61 keyvallst runna
b6d0: 6d 65 20 22 6e 65 77 22 20 22 6e 2f 61 22 20 75 me "new" "n/a" u
b6e0: 73 65 72 29 29 0a 09 20 28 70 72 65 76 2d 74 65 ser)).. (prev-te
b6f0: 73 74 73 20 20 20 20 20 20 28 6f 70 65 6e 2d 72 sts (open-r
b700: 75 6e 2d 63 6c 6f 73 65 20 74 65 73 74 3a 67 65 un-close test:ge
b710: 74 2d 6d 61 74 63 68 69 6e 67 2d 70 72 65 76 69 t-matching-previ
b720: 6f 75 73 2d 74 65 73 74 2d 72 75 6e 2d 72 65 63 ous-test-run-rec
b730: 6f 72 64 73 20 64 62 20 6e 65 77 2d 72 75 6e 2d ords db new-run-
b740: 69 64 20 22 25 22 20 22 25 22 29 29 0a 09 20 28 id "%" "%")).. (
b750: 63 75 72 72 2d 74 65 73 74 73 20 20 20 20 20 20 curr-tests
b760: 28 6f 70 65 6e 2d 72 75 6e 2d 63 6c 6f 73 65 20 (open-run-close
b770: 64 62 3a 67 65 74 2d 74 65 73 74 73 2d 66 6f 72 db:get-tests-for
b780: 2d 72 75 6e 20 64 62 20 6e 65 77 2d 72 75 6e 2d -run db new-run-
b790: 69 64 20 22 25 2f 25 22 20 27 28 29 20 27 28 29 id "%/%" '() '()
b7a0: 29 29 0a 09 20 28 63 75 72 72 2d 74 65 73 74 73 )).. (curr-tests
b7b0: 2d 68 61 73 68 20 28 6d 61 6b 65 2d 68 61 73 68 -hash (make-hash
b7c0: 2d 74 61 62 6c 65 29 29 29 0a 20 20 20 20 28 6f -table))). (o
b7d0: 70 65 6e 2d 72 75 6e 2d 63 6c 6f 73 65 20 64 62 pen-run-close db
b7e0: 3a 75 70 64 61 74 65 2d 72 75 6e 2d 65 76 65 6e :update-run-even
b7f0: 74 5f 74 69 6d 65 20 64 62 20 6e 65 77 2d 72 75 t_time db new-ru
b800: 6e 2d 69 64 29 0a 20 20 20 20 3b 3b 20 69 6e 64 n-id). ;; ind
b810: 65 78 20 74 68 65 20 61 6c 72 65 61 64 79 20 73 ex the already s
b820: 61 76 65 64 20 74 65 73 74 73 20 62 79 20 74 65 aved tests by te
b830: 73 74 6e 61 6d 65 20 61 6e 64 20 69 74 65 6d 64 stname and itemd
b840: 61 74 20 69 6e 20 63 75 72 72 2d 74 65 73 74 73 at in curr-tests
b850: 2d 68 61 73 68 0a 20 20 20 20 28 66 6f 72 2d 65 -hash. (for-e
b860: 61 63 68 0a 20 20 20 20 20 28 6c 61 6d 62 64 61 ach. (lambda
b870: 20 28 74 65 73 74 64 61 74 29 0a 20 20 20 20 20 (testdat).
b880: 20 20 28 6c 65 74 2a 20 28 28 74 65 73 74 6e 61 (let* ((testna
b890: 6d 65 20 20 28 64 62 3a 74 65 73 74 2d 67 65 74 me (db:test-get
b8a0: 2d 74 65 73 74 6e 61 6d 65 20 74 65 73 74 64 61 -testname testda
b8b0: 74 29 29 0a 09 20 20 20 20 20 20 28 69 74 65 6d t)).. (item
b8c0: 2d 70 61 74 68 20 28 64 62 3a 74 65 73 74 2d 67 -path (db:test-g
b8d0: 65 74 2d 69 74 65 6d 2d 70 61 74 68 20 74 65 73 et-item-path tes
b8e0: 74 64 61 74 29 29 0a 09 20 20 20 20 20 20 28 66 tdat)).. (f
b8f0: 75 6c 6c 2d 6e 61 6d 65 20 28 63 6f 6e 63 20 74 ull-name (conc t
b900: 65 73 74 6e 61 6d 65 20 22 2f 22 20 69 74 65 6d estname "/" item
b910: 2d 70 61 74 68 29 29 29 0a 09 20 28 68 61 73 68 -path))).. (hash
b920: 2d 74 61 62 6c 65 2d 73 65 74 21 20 63 75 72 72 -table-set! curr
b930: 2d 74 65 73 74 73 2d 68 61 73 68 20 66 75 6c 6c -tests-hash full
b940: 2d 6e 61 6d 65 20 74 65 73 74 64 61 74 29 29 29 -name testdat)))
b950: 0a 20 20 20 20 20 63 75 72 72 2d 74 65 73 74 73 . curr-tests
b960: 29 0a 20 20 20 20 3b 3b 20 4e 4f 50 45 3a 20 4e ). ;; NOPE: N
b970: 6f 6e 2d 6f 70 74 69 6d 61 6c 20 61 70 70 72 6f on-optimal appro
b980: 61 63 68 2e 20 54 72 79 20 74 68 69 73 20 69 6e ach. Try this in
b990: 73 74 65 61 64 2e 0a 20 20 20 20 3b 3b 20 20 20 stead.. ;;
b9a0: 31 2e 20 74 65 73 74 73 20 61 72 65 20 72 65 63 1. tests are rec
b9b0: 65 69 76 65 64 20 69 6e 20 61 20 6c 69 73 74 2c eived in a list,
b9c0: 20 6d 6f 73 74 20 72 65 63 65 6e 74 20 66 69 72 most recent fir
b9d0: 73 74 0a 20 20 20 20 3b 3b 20 20 20 32 2e 20 72 st. ;; 2. r
b9e0: 65 70 6c 61 63 65 20 74 68 65 20 72 6f 6c 6c 75 eplace the rollu
b9f0: 70 20 74 65 73 74 20 77 69 74 68 20 74 68 65 20 p test with the
ba00: 6e 65 77 20 2a 61 6c 77 61 79 73 2a 0a 20 20 20 new *always*.
ba10: 20 28 66 6f 72 2d 65 61 63 68 20 0a 20 20 20 20 (for-each .
ba20: 20 28 6c 61 6d 62 64 61 20 28 74 65 73 74 64 61 (lambda (testda
ba30: 74 29 0a 20 20 20 20 20 20 20 28 6c 65 74 2a 20 t). (let*
ba40: 28 28 74 65 73 74 6e 61 6d 65 20 20 28 64 62 3a ((testname (db:
ba50: 74 65 73 74 2d 67 65 74 2d 74 65 73 74 6e 61 6d test-get-testnam
ba60: 65 20 74 65 73 74 64 61 74 29 29 0a 09 20 20 20 e testdat))..
ba70: 20 20 20 28 69 74 65 6d 2d 70 61 74 68 20 28 64 (item-path (d
ba80: 62 3a 74 65 73 74 2d 67 65 74 2d 69 74 65 6d 2d b:test-get-item-
ba90: 70 61 74 68 20 74 65 73 74 64 61 74 29 29 0a 09 path testdat))..
baa0: 20 20 20 20 20 20 28 66 75 6c 6c 2d 6e 61 6d 65 (full-name
bab0: 20 28 63 6f 6e 63 20 74 65 73 74 6e 61 6d 65 20 (conc testname
bac0: 22 2f 22 20 69 74 65 6d 2d 70 61 74 68 29 29 0a "/" item-path)).
bad0: 09 20 20 20 20 20 20 28 70 72 65 76 2d 74 65 73 . (prev-tes
bae0: 74 2d 64 61 74 20 28 68 61 73 68 2d 74 61 62 6c t-dat (hash-tabl
baf0: 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 63 75 e-ref/default cu
bb00: 72 72 2d 74 65 73 74 73 2d 68 61 73 68 20 66 75 rr-tests-hash fu
bb10: 6c 6c 2d 6e 61 6d 65 20 23 66 29 29 0a 09 20 20 ll-name #f))..
bb20: 20 20 20 20 28 74 65 73 74 2d 73 74 65 70 73 20 (test-steps
bb30: 20 20 20 20 20 28 6f 70 65 6e 2d 72 75 6e 2d 63 (open-run-c
bb40: 6c 6f 73 65 20 64 62 3a 67 65 74 2d 73 74 65 70 lose db:get-step
bb50: 73 2d 66 6f 72 2d 74 65 73 74 20 64 62 20 28 64 s-for-test db (d
bb60: 62 3a 74 65 73 74 2d 67 65 74 2d 69 64 20 74 65 b:test-get-id te
bb70: 73 74 64 61 74 29 29 29 0a 09 20 20 20 20 20 20 stdat)))..
bb80: 28 6e 65 77 2d 74 65 73 74 2d 72 65 63 6f 72 64 (new-test-record
bb90: 20 23 66 29 29 0a 09 20 3b 3b 20 72 65 70 6c 61 #f)).. ;; repla
bba0: 63 65 20 74 68 65 73 65 20 77 69 74 68 20 69 6e ce these with in
bbb0: 73 65 72 74 20 2e 2e 2e 20 73 65 6c 65 63 74 0a sert ... select.
bbc0: 09 20 28 61 70 70 6c 79 20 73 71 6c 69 74 65 33 . (apply sqlite3
bbd0: 3a 65 78 65 63 75 74 65 20 0a 09 09 64 62 20 0a :execute ...db .
bbe0: 09 09 28 63 6f 6e 63 20 22 49 4e 53 45 52 54 20 ..(conc "INSERT
bbf0: 4f 52 20 52 45 50 4c 41 43 45 20 49 4e 54 4f 20 OR REPLACE INTO
bc00: 74 65 73 74 73 20 28 72 75 6e 5f 69 64 2c 74 65 tests (run_id,te
bc10: 73 74 6e 61 6d 65 2c 73 74 61 74 65 2c 73 74 61 stname,state,sta
bc20: 74 75 73 2c 65 76 65 6e 74 5f 74 69 6d 65 2c 68 tus,event_time,h
bc30: 6f 73 74 2c 63 70 75 6c 6f 61 64 2c 64 69 73 6b ost,cpuload,disk
bc40: 66 72 65 65 2c 75 6e 61 6d 65 2c 72 75 6e 64 69 free,uname,rundi
bc50: 72 2c 69 74 65 6d 5f 70 61 74 68 2c 72 75 6e 5f r,item_path,run_
bc60: 64 75 72 61 74 69 6f 6e 2c 66 69 6e 61 6c 5f 6c duration,final_l
bc70: 6f 67 66 2c 63 6f 6d 6d 65 6e 74 29 20 22 0a 09 ogf,comment) "..
bc80: 09 20 20 20 20 20 20 22 56 41 4c 55 45 53 20 28 . "VALUES (
bc90: 3f 2c 3f 2c 3f 2c 3f 2c 3f 2c 3f 2c 3f 2c 3f 2c ?,?,?,?,?,?,?,?,
bca0: 3f 2c 3f 2c 3f 2c 3f 2c 3f 2c 3f 29 3b 22 29 0a ?,?,?,?,?,?);").
bcb0: 09 09 6e 65 77 2d 72 75 6e 2d 69 64 20 28 63 64 ..new-run-id (cd
bcc0: 64 72 20 28 76 65 63 74 6f 72 2d 3e 6c 69 73 74 dr (vector->list
bcd0: 20 74 65 73 74 64 61 74 29 29 29 0a 09 20 28 73 testdat))).. (s
bce0: 65 74 21 20 6e 65 77 2d 74 65 73 74 64 61 74 20 et! new-testdat
bcf0: 28 63 61 72 20 28 6f 70 65 6e 2d 72 75 6e 2d 63 (car (open-run-c
bd00: 6c 6f 73 65 20 64 62 3a 67 65 74 2d 74 65 73 74 lose db:get-test
bd10: 73 2d 66 6f 72 2d 72 75 6e 20 64 62 20 6e 65 77 s-for-run db new
bd20: 2d 72 75 6e 2d 69 64 20 28 63 6f 6e 63 20 74 65 -run-id (conc te
bd30: 73 74 6e 61 6d 65 20 22 2f 22 20 69 74 65 6d 2d stname "/" item-
bd40: 70 61 74 68 29 20 27 28 29 20 27 28 29 29 29 29 path) '() '())))
bd50: 0a 09 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 73 .. (hash-table-s
bd60: 65 74 21 20 63 75 72 72 2d 74 65 73 74 73 2d 68 et! curr-tests-h
bd70: 61 73 68 20 66 75 6c 6c 2d 6e 61 6d 65 20 6e 65 ash full-name ne
bd80: 77 2d 74 65 73 74 64 61 74 29 20 3b 3b 20 74 68 w-testdat) ;; th
bd90: 69 73 20 63 6f 75 6c 64 20 62 65 20 63 6f 6e 66 is could be conf
bda0: 75 73 69 6e 67 2c 20 77 68 69 63 68 20 72 65 63 using, which rec
bdb0: 6f 72 64 20 73 68 6f 75 6c 64 20 67 6f 20 69 6e ord should go in
bdc0: 74 6f 20 74 68 65 20 6c 6f 6f 6b 75 70 20 74 61 to the lookup ta
bdd0: 62 6c 65 3f 0a 09 20 3b 3b 20 4e 6f 77 20 64 75 ble?.. ;; Now du
bde0: 70 6c 69 63 61 74 65 20 74 68 65 20 74 65 73 74 plicate the test
bdf0: 20 73 74 65 70 73 0a 09 20 28 64 65 62 75 67 3a steps.. (debug:
be00: 70 72 69 6e 74 20 34 20 22 43 6f 70 79 69 6e 67 print 4 "Copying
be10: 20 72 65 63 6f 72 64 73 20 69 6e 20 74 65 73 74 records in test
be20: 5f 73 74 65 70 73 20 66 72 6f 6d 20 74 65 73 74 _steps from test
be30: 5f 69 64 3d 22 20 28 64 62 3a 74 65 73 74 2d 67 _id=" (db:test-g
be40: 65 74 2d 69 64 20 74 65 73 74 64 61 74 29 20 22 et-id testdat) "
be50: 20 74 6f 20 22 20 28 64 62 3a 74 65 73 74 2d 67 to " (db:test-g
be60: 65 74 2d 69 64 20 6e 65 77 2d 74 65 73 74 64 61 et-id new-testda
be70: 74 29 29 0a 09 20 28 6f 70 65 6e 2d 72 75 6e 2d t)).. (open-run-
be80: 63 6c 6f 73 65 20 0a 09 20 20 28 6c 61 6d 62 64 close .. (lambd
be90: 61 20 28 29 0a 09 20 20 20 20 28 73 71 6c 69 74 a ().. (sqlit
bea0: 65 33 3a 65 78 65 63 75 74 65 20 0a 09 20 20 20 e3:execute ..
beb0: 20 20 64 62 20 0a 09 20 20 20 20 20 28 63 6f 6e db .. (con
bec0: 63 20 22 49 4e 53 45 52 54 20 4f 52 20 52 45 50 c "INSERT OR REP
bed0: 4c 41 43 45 20 49 4e 54 4f 20 74 65 73 74 5f 73 LACE INTO test_s
bee0: 74 65 70 73 20 28 74 65 73 74 5f 69 64 2c 73 74 teps (test_id,st
bef0: 65 70 6e 61 6d 65 2c 73 74 61 74 65 2c 73 74 61 epname,state,sta
bf00: 74 75 73 2c 65 76 65 6e 74 5f 74 69 6d 65 2c 63 tus,event_time,c
bf10: 6f 6d 6d 65 6e 74 29 20 22 0a 09 09 20 20 20 22 omment) "... "
bf20: 53 45 4c 45 43 54 20 22 20 28 64 62 3a 74 65 73 SELECT " (db:tes
bf30: 74 2d 67 65 74 2d 69 64 20 6e 65 77 2d 74 65 73 t-get-id new-tes
bf40: 74 64 61 74 29 20 22 2c 73 74 65 70 6e 61 6d 65 tdat) ",stepname
bf50: 2c 73 74 61 74 65 2c 73 74 61 74 75 73 2c 65 76 ,state,status,ev
bf60: 65 6e 74 5f 74 69 6d 65 2c 63 6f 6d 6d 65 6e 74 ent_time,comment
bf70: 20 46 52 4f 4d 20 74 65 73 74 5f 73 74 65 70 73 FROM test_steps
bf80: 20 57 48 45 52 45 20 74 65 73 74 5f 69 64 3d 3f WHERE test_id=?
bf90: 3b 22 29 0a 09 20 20 20 20 20 28 64 62 3a 74 65 ;").. (db:te
bfa0: 73 74 2d 67 65 74 2d 69 64 20 74 65 73 74 64 61 st-get-id testda
bfb0: 74 29 29 0a 09 20 20 20 20 3b 3b 20 4e 6f 77 20 t)).. ;; Now
bfc0: 64 75 70 6c 69 63 61 74 65 20 74 68 65 20 74 65 duplicate the te
bfd0: 73 74 20 64 61 74 61 0a 09 20 20 20 20 28 64 65 st data.. (de
bfe0: 62 75 67 3a 70 72 69 6e 74 20 34 20 22 43 6f 70 bug:print 4 "Cop
bff0: 79 69 6e 67 20 72 65 63 6f 72 64 73 20 69 6e 20 ying records in
c000: 74 65 73 74 5f 64 61 74 61 20 66 72 6f 6d 20 74 test_data from t
c010: 65 73 74 5f 69 64 3d 22 20 28 64 62 3a 74 65 73 est_id=" (db:tes
c020: 74 2d 67 65 74 2d 69 64 20 74 65 73 74 64 61 74 t-get-id testdat
c030: 29 20 22 20 74 6f 20 22 20 28 64 62 3a 74 65 73 ) " to " (db:tes
c040: 74 2d 67 65 74 2d 69 64 20 6e 65 77 2d 74 65 73 t-get-id new-tes
c050: 74 64 61 74 29 29 0a 09 20 20 20 20 28 73 71 6c tdat)).. (sql
c060: 69 74 65 33 3a 65 78 65 63 75 74 65 20 0a 09 20 ite3:execute ..
c070: 20 20 20 20 64 62 20 0a 09 20 20 20 20 20 28 63 db .. (c
c080: 6f 6e 63 20 22 49 4e 53 45 52 54 20 4f 52 20 52 onc "INSERT OR R
c090: 45 50 4c 41 43 45 20 49 4e 54 4f 20 74 65 73 74 EPLACE INTO test
c0a0: 5f 64 61 74 61 20 28 74 65 73 74 5f 69 64 2c 63 _data (test_id,c
c0b0: 61 74 65 67 6f 72 79 2c 76 61 72 69 61 62 6c 65 ategory,variable
c0c0: 2c 76 61 6c 75 65 2c 65 78 70 65 63 74 65 64 2c ,value,expected,
c0d0: 74 6f 6c 2c 75 6e 69 74 73 2c 63 6f 6d 6d 65 6e tol,units,commen
c0e0: 74 29 20 22 0a 09 09 20 20 20 22 53 45 4c 45 43 t) "... "SELEC
c0f0: 54 20 22 20 28 64 62 3a 74 65 73 74 2d 67 65 74 T " (db:test-get
c100: 2d 69 64 20 6e 65 77 2d 74 65 73 74 64 61 74 29 -id new-testdat)
c110: 20 22 2c 63 61 74 65 67 6f 72 79 2c 76 61 72 69 ",category,vari
c120: 61 62 6c 65 2c 76 61 6c 75 65 2c 65 78 70 65 63 able,value,expec
c130: 74 65 64 2c 74 6f 6c 2c 75 6e 69 74 73 2c 63 6f ted,tol,units,co
c140: 6d 6d 65 6e 74 20 46 52 4f 4d 20 74 65 73 74 5f mment FROM test_
c150: 64 61 74 61 20 57 48 45 52 45 20 74 65 73 74 5f data WHERE test_
c160: 69 64 3d 3f 3b 22 29 0a 09 20 20 20 20 20 28 64 id=?;").. (d
c170: 62 3a 74 65 73 74 2d 67 65 74 2d 69 64 20 74 65 b:test-get-id te
c180: 73 74 64 61 74 29 29 29 29 0a 09 20 29 29 0a 20 stdat)))).. )).
c190: 20 20 20 20 70 72 65 76 2d 74 65 73 74 73 29 29 prev-tests))
c1a0: 29 0a 09 20 0a 20 20 20 20 20 0a ).. . .