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 3b 3b 3d waiton). ;;=
2550: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2560: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2570: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2580: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2590: 3d 3d 3d 3d 3d 0a 20 20 20 20 3b 3b 20 72 65 66 =====. ;; ref
25a0: 61 63 74 6f 72 69 6e 67 20 74 68 69 73 20 62 6c actoring this bl
25b0: 6f 63 6b 20 69 6e 74 6f 20 74 65 73 74 73 3a 67 ock into tests:g
25c0: 65 74 2d 66 75 6c 6c 2d 64 61 74 61 0a 20 20 20 et-full-data.
25d0: 20 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;;=============
25e0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
25f0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2600: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2610: 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 20 20 20 20 28 74 =========. (t
2620: 65 73 74 73 3a 67 65 74 2d 66 75 6c 6c 2d 64 61 ests:get-full-da
2630: 74 61 20 74 65 73 74 2d 6e 61 6d 65 73 20 74 65 ta test-names te
2640: 73 74 2d 72 65 63 6f 72 64 73 20 72 65 71 75 69 st-records requi
2650: 72 65 64 2d 74 65 73 74 73 29 0a 0a 20 20 20 20 red-tests)..
2660: 28 69 66 20 28 6e 6f 74 20 28 6e 75 6c 6c 3f 20 (if (not (null?
2670: 72 65 71 75 69 72 65 64 2d 74 65 73 74 73 29 29 required-tests))
2680: 0a 09 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 ..(debug:print-i
2690: 6e 66 6f 20 31 20 22 41 64 64 69 6e 67 20 22 20 nfo 1 "Adding "
26a0: 72 65 71 75 69 72 65 64 2d 74 65 73 74 73 20 22 required-tests "
26b0: 20 74 6f 20 74 68 65 20 72 75 6e 20 71 75 65 75 to the run queu
26c0: 65 22 29 29 0a 20 20 20 20 3b 3b 20 4e 4f 54 45 e")). ;; NOTE
26d0: 3a 20 74 68 65 73 65 20 61 72 65 20 61 6c 6c 20 : these are all
26e0: 70 61 72 65 6e 74 20 74 65 73 74 73 2c 20 69 74 parent tests, it
26f0: 65 6d 73 20 61 72 65 20 6e 6f 74 20 65 78 70 61 ems are not expa
2700: 6e 64 65 64 20 79 65 74 2e 0a 20 20 20 20 28 64 nded yet.. (d
2710: 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 ebug:print-info
2720: 34 20 22 74 65 73 74 2d 72 65 63 6f 72 64 73 3d 4 "test-records=
2730: 22 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 3e 61 " (hash-table->a
2740: 6c 69 73 74 20 74 65 73 74 2d 72 65 63 6f 72 64 list test-record
2750: 73 29 29 0a 20 20 20 20 28 72 75 6e 73 3a 72 75 s)). (runs:ru
2760: 6e 2d 74 65 73 74 73 2d 71 75 65 75 65 20 72 75 n-tests-queue ru
2770: 6e 2d 69 64 20 72 75 6e 6e 61 6d 65 20 74 65 73 n-id runname tes
2780: 74 2d 72 65 63 6f 72 64 73 20 6b 65 79 76 61 6c t-records keyval
2790: 6c 73 74 20 66 6c 61 67 73 20 74 65 73 74 2d 70 lst flags test-p
27a0: 61 74 74 73 29 0a 20 20 20 20 28 64 65 62 75 67 atts). (debug
27b0: 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 34 20 22 41 :print-info 4 "A
27c0: 6c 6c 20 64 6f 6e 65 20 62 79 20 68 65 72 65 22 ll done by here"
27d0: 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 72 75 )))..(define (ru
27e0: 6e 73 3a 63 61 6c 63 2d 66 61 69 6c 73 20 70 72 ns:calc-fails pr
27f0: 65 72 65 71 73 2d 6e 6f 74 2d 6d 65 74 29 0a 20 ereqs-not-met).
2800: 20 28 66 69 6c 74 65 72 20 28 6c 61 6d 62 64 61 (filter (lambda
2810: 20 28 74 65 73 74 29 0a 09 20 20 20 20 28 61 6e (test).. (an
2820: 64 20 28 76 65 63 74 6f 72 3f 20 74 65 73 74 29 d (vector? test)
2830: 20 3b 3b 20 6e 6f 74 20 28 73 74 72 69 6e 67 3f ;; not (string?
2840: 20 74 65 73 74 29 29 0a 09 09 20 28 65 71 75 61 test))... (equa
2850: 6c 3f 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d l? (db:test-get-
2860: 73 74 61 74 65 20 74 65 73 74 29 20 22 43 4f 4d state test) "COM
2870: 50 4c 45 54 45 44 22 29 0a 09 09 20 28 6e 6f 74 PLETED")... (not
2880: 20 28 6d 65 6d 62 65 72 20 28 64 62 3a 74 65 73 (member (db:tes
2890: 74 2d 67 65 74 2d 73 74 61 74 75 73 20 74 65 73 t-get-status tes
28a0: 74 29 0a 09 09 09 20 20 20 20 20 20 27 28 22 50 t).... '("P
28b0: 41 53 53 22 20 22 57 41 52 4e 22 20 22 43 48 45 ASS" "WARN" "CHE
28c0: 43 4b 22 20 22 57 41 49 56 45 44 22 20 22 53 4b CK" "WAIVED" "SK
28d0: 49 50 22 29 29 29 29 29 0a 09 20 20 70 72 65 72 IP"))))).. prer
28e0: 65 71 73 2d 6e 6f 74 2d 6d 65 74 29 29 0a 0a 28 eqs-not-met))..(
28f0: 64 65 66 69 6e 65 20 28 72 75 6e 73 3a 63 61 6c define (runs:cal
2900: 63 2d 6e 6f 74 2d 63 6f 6d 70 6c 65 74 65 64 20 c-not-completed
2910: 70 72 65 72 65 71 73 2d 6e 6f 74 2d 6d 65 74 29 prereqs-not-met)
2920: 0a 20 20 28 66 69 6c 74 65 72 0a 20 20 20 28 6c . (filter. (l
2930: 61 6d 62 64 61 20 28 74 29 0a 20 20 20 20 20 28 ambda (t). (
2940: 6f 72 20 28 6e 6f 74 20 28 76 65 63 74 6f 72 3f or (not (vector?
2950: 20 74 29 29 0a 09 20 28 6e 6f 74 20 28 65 71 75 t)).. (not (equ
2960: 61 6c 3f 20 22 43 4f 4d 50 4c 45 54 45 44 22 20 al? "COMPLETED"
2970: 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 73 74 61 (db:test-get-sta
2980: 74 65 20 74 29 29 29 29 29 0a 20 20 20 70 72 65 te t))))). pre
2990: 72 65 71 73 2d 6e 6f 74 2d 6d 65 74 29 29 0a 0a reqs-not-met))..
29a0: 28 64 65 66 69 6e 65 20 28 72 75 6e 73 3a 70 72 (define (runs:pr
29b0: 65 74 74 79 2d 73 74 72 69 6e 67 20 6c 73 74 29 etty-string lst)
29c0: 0a 20 20 28 6d 61 70 20 28 6c 61 6d 62 64 61 20 . (map (lambda
29d0: 28 74 29 0a 09 20 28 69 66 20 28 6e 6f 74 20 28 (t).. (if (not (
29e0: 76 65 63 74 6f 72 3f 20 74 29 29 0a 09 20 20 20 vector? t))..
29f0: 20 20 28 63 6f 6e 63 20 74 29 0a 09 20 20 20 20 (conc t)..
2a00: 20 28 63 6f 6e 63 20 28 64 62 3a 74 65 73 74 2d (conc (db:test-
2a10: 67 65 74 2d 74 65 73 74 6e 61 6d 65 20 74 29 20 get-testname t)
2a20: 22 3a 22 20 28 64 62 3a 74 65 73 74 2d 67 65 74 ":" (db:test-get
2a30: 2d 73 74 61 74 65 20 74 29 20 22 2f 22 20 28 64 -state t) "/" (d
2a40: 62 3a 74 65 73 74 2d 67 65 74 2d 73 74 61 74 75 b:test-get-statu
2a50: 73 20 74 29 29 29 29 0a 20 20 20 20 20 20 20 6c s t)))). l
2a60: 73 74 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 72 st))..(define (r
2a70: 75 6e 73 3a 6d 61 6b 65 2d 66 75 6c 6c 2d 74 65 uns:make-full-te
2a80: 73 74 2d 6e 61 6d 65 20 74 65 73 74 6e 61 6d 65 st-name testname
2a90: 20 69 74 65 6d 70 61 74 68 29 0a 20 20 28 69 66 itempath). (if
2aa0: 20 28 65 71 75 61 6c 3f 20 69 74 65 6d 70 61 74 (equal? itempat
2ab0: 68 20 22 22 29 20 74 65 73 74 6e 61 6d 65 20 28 h "") testname (
2ac0: 63 6f 6e 63 20 74 65 73 74 6e 61 6d 65 20 22 2f conc testname "/
2ad0: 22 20 69 74 65 6d 70 61 74 68 29 29 29 0a 0a 3b " itempath)))..;
2ae0: 3b 20 74 65 73 74 2d 72 65 63 6f 72 64 73 20 69 ; test-records i
2af0: 73 20 61 20 68 61 73 68 20 74 61 62 6c 65 20 74 s a hash table t
2b00: 65 73 74 6e 61 6d 65 3a 69 74 65 6d 5f 70 61 74 estname:item_pat
2b10: 68 20 3d 3e 20 76 65 63 74 6f 72 20 3c 20 74 65 h => vector < te
2b20: 73 74 6e 61 6d 65 20 74 65 73 74 63 6f 6e 66 69 stname testconfi
2b30: 67 20 77 61 69 74 6f 6e 73 20 70 72 69 6f 72 69 g waitons priori
2b40: 74 79 20 69 74 65 6d 73 2d 69 6e 66 6f 20 2e 2e ty items-info ..
2b50: 2e 20 3e 0a 28 64 65 66 69 6e 65 20 28 72 75 6e . >.(define (run
2b60: 73 3a 72 75 6e 2d 74 65 73 74 73 2d 71 75 65 75 s:run-tests-queu
2b70: 65 20 72 75 6e 2d 69 64 20 72 75 6e 6e 61 6d 65 e run-id runname
2b80: 20 74 65 73 74 2d 72 65 63 6f 72 64 73 20 6b 65 test-records ke
2b90: 79 76 61 6c 6c 73 74 20 66 6c 61 67 73 20 74 65 yvallst flags te
2ba0: 73 74 2d 70 61 74 74 73 29 0a 20 20 20 20 3b 3b st-patts). ;;
2bb0: 20 41 74 20 74 68 69 73 20 70 6f 69 6e 74 20 74 At this point t
2bc0: 68 65 20 6c 69 73 74 20 6f 66 20 70 61 72 65 6e he list of paren
2bd0: 74 20 74 65 73 74 73 20 69 73 20 65 78 70 61 6e t tests is expan
2be0: 64 65 64 20 0a 20 20 20 20 3b 3b 20 4e 42 2f 2f ded . ;; NB//
2bf0: 20 53 68 6f 75 6c 64 20 65 78 70 61 6e 64 20 69 Should expand i
2c00: 74 65 6d 73 20 68 65 72 65 20 61 6e 64 20 74 68 tems here and th
2c10: 65 6e 20 69 6e 73 65 72 74 20 69 6e 74 6f 20 74 en insert into t
2c20: 68 65 20 72 75 6e 20 71 75 65 75 65 2e 0a 20 20 he run queue..
2c30: 28 64 65 62 75 67 3a 70 72 69 6e 74 20 35 20 22 (debug:print 5 "
2c40: 74 65 73 74 2d 72 65 63 6f 72 64 73 3a 20 22 20 test-records: "
2c50: 74 65 73 74 2d 72 65 63 6f 72 64 73 20 22 2c 20 test-records ",
2c60: 6b 65 79 76 61 6c 6c 73 74 3a 20 22 20 6b 65 79 keyvallst: " key
2c70: 76 61 6c 6c 73 74 20 22 20 66 6c 61 67 73 3a 20 vallst " flags:
2c80: 22 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 3e 61 " (hash-table->a
2c90: 6c 69 73 74 20 66 6c 61 67 73 29 29 0a 20 20 28 list flags)). (
2ca0: 6c 65 74 20 28 28 73 6f 72 74 65 64 2d 74 65 73 let ((sorted-tes
2cb0: 74 2d 6e 61 6d 65 73 20 28 74 65 73 74 73 3a 73 t-names (tests:s
2cc0: 6f 72 74 2d 62 79 2d 70 72 69 6f 72 69 74 79 2d ort-by-priority-
2cd0: 61 6e 64 2d 77 61 69 74 6f 6e 20 74 65 73 74 2d and-waiton test-
2ce0: 72 65 63 6f 72 64 73 29 29 0a 09 28 74 65 73 74 records))..(test
2cf0: 2d 72 65 67 69 73 74 65 72 79 20 20 20 20 28 6d -registery (m
2d00: 61 6b 65 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 ake-hash-table))
2d10: 0a 09 28 72 65 67 69 73 74 65 72 79 2d 6d 75 74 ..(registery-mut
2d20: 65 78 20 20 20 28 6d 61 6b 65 2d 6d 75 74 65 78 ex (make-mutex
2d30: 29 29 0a 09 28 6e 75 6d 2d 72 65 74 72 69 65 73 ))..(num-retries
2d40: 20 20 20 20 20 20 20 20 30 29 0a 09 28 6d 61 78 0)..(max
2d50: 2d 72 65 74 72 69 65 73 20 20 20 20 20 20 20 28 -retries (
2d60: 63 6f 6e 66 69 67 2d 6c 6f 6f 6b 75 70 20 2a 63 config-lookup *c
2d70: 6f 6e 66 69 67 64 61 74 2a 20 22 73 65 74 75 70 onfigdat* "setup
2d80: 22 20 22 6d 61 78 72 65 74 72 69 65 73 22 29 29 " "maxretries"))
2d90: 29 0a 20 20 20 20 28 73 65 74 21 20 6d 61 78 2d ). (set! max-
2da0: 72 65 74 72 69 65 73 20 28 69 66 20 28 61 6e 64 retries (if (and
2db0: 20 6d 61 78 2d 72 65 74 72 69 65 73 20 28 73 74 max-retries (st
2dc0: 72 69 6e 67 2d 3e 6e 75 6d 62 65 72 20 6d 61 78 ring->number max
2dd0: 2d 72 65 74 72 69 65 73 29 29 28 73 74 72 69 6e -retries))(strin
2de0: 67 2d 3e 6e 75 6d 62 65 72 20 6d 61 78 2d 72 65 g->number max-re
2df0: 74 72 69 65 73 29 20 31 30 30 29 29 0a 20 20 20 tries) 100)).
2e00: 20 28 69 66 20 28 6e 6f 74 20 28 6e 75 6c 6c 3f (if (not (null?
2e10: 20 73 6f 72 74 65 64 2d 74 65 73 74 2d 6e 61 6d sorted-test-nam
2e20: 65 73 29 29 0a 09 28 6c 65 74 20 6c 6f 6f 70 20 es))..(let loop
2e30: 28 28 68 65 64 20 20 20 20 20 20 20 20 20 28 63 ((hed (c
2e40: 61 72 20 73 6f 72 74 65 64 2d 74 65 73 74 2d 6e ar sorted-test-n
2e50: 61 6d 65 73 29 29 0a 09 09 20 20 20 28 74 61 6c ames))... (tal
2e60: 20 20 20 20 20 20 20 20 20 28 63 64 72 20 73 6f (cdr so
2e70: 72 74 65 64 2d 74 65 73 74 2d 6e 61 6d 65 73 29 rted-test-names)
2e80: 29 0a 09 09 20 20 20 28 72 65 67 69 73 74 65 72 )... (register
2e90: 65 64 20 20 27 28 29 29 0a 09 09 20 20 20 28 72 ed '())... (r
2ea0: 65 72 75 6e 73 20 20 20 20 20 20 27 28 29 29 29 eruns '()))
2eb0: 0a 09 20 20 28 69 66 20 28 6e 6f 74 20 28 6e 75 .. (if (not (nu
2ec0: 6c 6c 3f 20 72 65 72 75 6e 73 29 29 28 64 65 62 ll? reruns))(deb
2ed0: 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 34 20 ug:print-info 4
2ee0: 22 72 65 72 75 6e 73 3d 22 20 72 65 72 75 6e 73 "reruns=" reruns
2ef0: 29 29 0a 09 20 20 3b 3b 20 28 70 72 69 6e 74 20 )).. ;; (print
2f00: 22 54 6f 70 20 6f 66 20 6c 6f 6f 70 2c 20 68 65 "Top of loop, he
2f10: 64 3d 22 20 68 65 64 20 22 2c 20 74 61 6c 3d 22 d=" hed ", tal="
2f20: 20 74 61 6c 20 22 20 2c 72 65 72 75 6e 73 3d 22 tal " ,reruns="
2f30: 20 72 65 72 75 6e 73 29 0a 09 20 20 28 6c 65 74 reruns).. (let
2f40: 2a 20 28 28 74 65 73 74 2d 72 65 63 6f 72 64 20 * ((test-record
2f50: 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 20 (hash-table-ref
2f60: 74 65 73 74 2d 72 65 63 6f 72 64 73 20 68 65 64 test-records hed
2f70: 29 29 0a 09 09 20 28 74 65 73 74 2d 6e 61 6d 65 ))... (test-name
2f80: 20 20 20 28 74 65 73 74 73 3a 74 65 73 74 71 75 (tests:testqu
2f90: 65 75 65 2d 67 65 74 2d 74 65 73 74 6e 61 6d 65 eue-get-testname
2fa0: 20 74 65 73 74 2d 72 65 63 6f 72 64 29 29 0a 09 test-record))..
2fb0: 09 20 28 74 63 6f 6e 66 69 67 20 20 20 20 20 28 . (tconfig (
2fc0: 74 65 73 74 73 3a 74 65 73 74 71 75 65 75 65 2d tests:testqueue-
2fd0: 67 65 74 2d 74 65 73 74 63 6f 6e 66 69 67 20 74 get-testconfig t
2fe0: 65 73 74 2d 72 65 63 6f 72 64 29 29 0a 09 09 20 est-record))...
2ff0: 28 74 65 73 74 6d 6f 64 65 20 20 20 20 28 6c 65 (testmode (le
3000: 74 20 28 28 6d 20 28 63 6f 6e 66 69 67 2d 6c 6f t ((m (config-lo
3010: 6f 6b 75 70 20 74 63 6f 6e 66 69 67 20 22 72 65 okup tconfig "re
3020: 71 75 69 72 65 6d 65 6e 74 73 22 20 22 6d 6f 64 quirements" "mod
3030: 65 22 29 29 29 0a 09 09 09 09 28 69 66 20 6d 20 e"))).....(if m
3040: 28 73 74 72 69 6e 67 2d 3e 73 79 6d 62 6f 6c 20 (string->symbol
3050: 6d 29 20 27 6e 6f 72 6d 61 6c 29 29 29 0a 09 09 m) 'normal)))...
3060: 20 28 77 61 69 74 6f 6e 73 20 20 20 20 20 28 74 (waitons (t
3070: 65 73 74 73 3a 74 65 73 74 71 75 65 75 65 2d 67 ests:testqueue-g
3080: 65 74 2d 77 61 69 74 6f 6e 73 20 20 20 20 74 65 et-waitons te
3090: 73 74 2d 72 65 63 6f 72 64 29 29 0a 09 09 20 28 st-record))... (
30a0: 70 72 69 6f 72 69 74 79 20 20 20 20 28 74 65 73 priority (tes
30b0: 74 73 3a 74 65 73 74 71 75 65 75 65 2d 67 65 74 ts:testqueue-get
30c0: 2d 70 72 69 6f 72 69 74 79 20 20 20 74 65 73 74 -priority test
30d0: 2d 72 65 63 6f 72 64 29 29 0a 09 09 20 28 69 74 -record))... (it
30e0: 65 6d 64 61 74 20 20 20 20 20 28 74 65 73 74 73 emdat (tests
30f0: 3a 74 65 73 74 71 75 65 75 65 2d 67 65 74 2d 69 :testqueue-get-i
3100: 74 65 6d 64 61 74 20 20 20 20 74 65 73 74 2d 72 temdat test-r
3110: 65 63 6f 72 64 29 29 20 3b 3b 20 69 74 65 6d 64 ecord)) ;; itemd
3120: 61 74 20 63 61 6e 20 62 65 20 61 20 73 74 72 69 at can be a stri
3130: 6e 67 2c 20 6c 69 73 74 20 6f 72 20 23 66 0a 09 ng, list or #f..
3140: 09 20 28 69 74 65 6d 73 20 20 20 20 20 20 20 28 . (items (
3150: 74 65 73 74 73 3a 74 65 73 74 71 75 65 75 65 2d tests:testqueue-
3160: 67 65 74 2d 69 74 65 6d 73 20 20 20 20 20 20 74 get-items t
3170: 65 73 74 2d 72 65 63 6f 72 64 29 29 0a 09 09 20 est-record))...
3180: 28 69 74 65 6d 2d 70 61 74 68 20 20 20 28 69 74 (item-path (it
3190: 65 6d 2d 6c 69 73 74 2d 3e 70 61 74 68 20 69 74 em-list->path it
31a0: 65 6d 64 61 74 29 29 0a 09 09 20 28 6e 65 77 74 emdat))... (newt
31b0: 61 6c 20 20 20 20 20 20 28 61 70 70 65 6e 64 20 al (append
31c0: 74 61 6c 20 28 6c 69 73 74 20 68 65 64 29 29 29 tal (list hed)))
31d0: 29 0a 09 20 20 20 20 0a 09 20 20 20 20 28 64 65 ).. .. (de
31e0: 62 75 67 3a 70 72 69 6e 74 20 36 0a 09 09 09 20 bug:print 6....
31f0: 22 74 65 73 74 2d 6e 61 6d 65 3a 20 22 20 74 65 "test-name: " te
3200: 73 74 2d 6e 61 6d 65 0a 09 09 09 20 22 5c 6e 20 st-name.... "\n
3210: 20 68 65 64 3a 20 20 20 20 20 20 20 20 20 22 20 hed: "
3220: 68 65 64 0a 09 09 09 20 22 5c 6e 20 20 69 74 65 hed.... "\n ite
3230: 6d 64 61 74 3a 20 20 20 20 20 22 20 69 74 65 6d mdat: " item
3240: 64 61 74 0a 09 09 09 20 22 5c 6e 20 20 69 74 65 dat.... "\n ite
3250: 6d 73 3a 20 20 20 20 20 20 20 22 20 69 74 65 6d ms: " item
3260: 73 0a 09 09 09 20 22 5c 6e 20 20 69 74 65 6d 2d s.... "\n item-
3270: 70 61 74 68 3a 20 20 20 22 20 69 74 65 6d 2d 70 path: " item-p
3280: 61 74 68 0a 09 09 09 20 22 5c 6e 20 20 77 61 69 ath.... "\n wai
3290: 74 6f 6e 73 3a 20 20 20 20 20 22 20 77 61 69 74 tons: " wait
32a0: 6f 6e 73 0a 09 09 09 20 22 5c 6e 20 20 6e 75 6d ons.... "\n num
32b0: 2d 72 65 74 72 69 65 73 3a 20 22 20 6e 75 6d 2d -retries: " num-
32c0: 72 65 74 72 69 65 73 0a 09 09 09 20 22 5c 6e 20 retries.... "\n
32d0: 20 74 61 6c 3a 20 20 20 20 20 20 20 20 20 22 20 tal: "
32e0: 74 61 6c 0a 09 09 09 20 22 5c 6e 20 20 72 65 72 tal.... "\n rer
32f0: 75 6e 73 3a 20 20 20 20 20 20 22 20 72 65 72 75 uns: " reru
3300: 6e 73 29 0a 0a 09 20 20 20 20 3b 3b 20 63 68 65 ns)... ;; che
3310: 63 6b 20 66 6f 72 20 68 65 64 20 69 6e 20 77 61 ck for hed in wa
3320: 69 74 6f 6e 73 20 3d 3e 20 74 68 69 73 20 77 6f itons => this wo
3330: 75 6c 64 20 62 65 20 63 69 72 63 75 6c 61 72 2c uld be circular,
3340: 20 72 65 6d 6f 76 65 20 69 74 20 61 6e 64 20 69 remove it and i
3350: 73 73 75 65 20 61 6e 0a 09 20 20 20 20 3b 3b 20 ssue an.. ;;
3360: 65 72 72 6f 72 0a 09 20 20 20 20 28 69 66 20 28 error.. (if (
3370: 6d 65 6d 62 65 72 20 74 65 73 74 2d 6e 61 6d 65 member test-name
3380: 20 77 61 69 74 6f 6e 73 29 0a 09 09 28 62 65 67 waitons)...(beg
3390: 69 6e 0a 09 09 20 20 28 64 65 62 75 67 3a 70 72 in... (debug:pr
33a0: 69 6e 74 20 30 20 22 45 52 52 4f 52 3a 20 74 65 int 0 "ERROR: te
33b0: 73 74 20 22 20 74 65 73 74 2d 6e 61 6d 65 20 22 st " test-name "
33c0: 20 68 61 73 20 6c 69 73 74 65 64 20 69 74 73 65 has listed itse
33d0: 6c 66 20 61 73 20 61 20 77 61 69 74 6f 6e 2c 20 lf as a waiton,
33e0: 70 6c 65 61 73 65 20 63 6f 72 72 65 63 74 20 74 please correct t
33f0: 68 69 73 21 22 29 0a 09 09 20 20 28 73 65 74 21 his!")... (set!
3400: 20 77 61 69 74 6f 6e 20 28 66 69 6c 74 65 72 20 waiton (filter
3410: 28 6c 61 6d 62 64 61 20 28 78 29 28 6e 6f 74 20 (lambda (x)(not
3420: 28 65 71 75 61 6c 3f 20 78 20 68 65 64 29 29 29 (equal? x hed)))
3430: 20 77 61 69 74 6f 6e 73 29 29 29 29 0a 0a 09 20 waitons))))...
3440: 20 20 20 28 63 6f 6e 64 20 3b 3b 20 4f 55 54 45 (cond ;; OUTE
3450: 52 20 43 4f 4e 44 0a 09 20 20 20 20 20 28 28 6e R COND.. ((n
3460: 6f 74 20 69 74 65 6d 73 29 20 3b 3b 20 77 68 65 ot items) ;; whe
3470: 6e 20 66 61 6c 73 65 20 74 68 65 20 74 65 73 74 n false the test
3480: 20 69 73 20 6f 6b 20 74 6f 20 62 65 20 68 61 6e is ok to be han
3490: 64 65 64 20 6f 66 66 20 74 6f 20 6c 61 75 6e 63 ded off to launc
34a0: 68 20 28 62 75 74 20 6e 6f 74 20 62 65 66 6f 72 h (but not befor
34b0: 65 29 0a 09 20 20 20 20 20 20 28 6c 65 74 2a 20 e).. (let*
34c0: 28 28 72 75 6e 2d 6c 69 6d 69 74 73 2d 69 6e 66 ((run-limits-inf
34d0: 6f 20 20 20 20 20 20 20 20 20 28 72 75 6e 73 3a o (runs:
34e0: 63 61 6e 2d 72 75 6e 2d 6d 6f 72 65 2d 74 65 73 can-run-more-tes
34f0: 74 73 20 74 65 73 74 2d 72 65 63 6f 72 64 29 29 ts test-record))
3500: 20 3b 3b 20 6c 6f 6f 6b 20 61 74 20 74 68 65 20 ;; look at the
3510: 74 65 73 74 20 6a 6f 62 67 72 6f 75 70 20 61 6e test jobgroup an
3520: 64 20 74 6f 74 20 6a 6f 62 73 20 72 75 6e 6e 69 d tot jobs runni
3530: 6e 67 0a 09 09 20 20 20 20 20 28 68 61 76 65 2d ng... (have-
3540: 72 65 73 6f 75 72 63 65 73 20 20 20 20 20 20 20 resources
3550: 20 20 20 28 63 61 72 20 72 75 6e 2d 6c 69 6d 69 (car run-limi
3560: 74 73 2d 69 6e 66 6f 29 29 0a 09 09 20 20 20 20 ts-info))...
3570: 20 28 6e 75 6d 2d 72 75 6e 6e 69 6e 67 20 20 20 (num-running
3580: 20 20 20 20 20 20 20 20 20 20 28 6c 69 73 74 2d (list-
3590: 72 65 66 20 72 75 6e 2d 6c 69 6d 69 74 73 2d 69 ref run-limits-i
35a0: 6e 66 6f 20 31 29 29 0a 09 09 20 20 20 20 20 28 nfo 1))... (
35b0: 6e 75 6d 2d 72 75 6e 6e 69 6e 67 2d 69 6e 2d 6a num-running-in-j
35c0: 6f 62 67 72 6f 75 70 20 28 6c 69 73 74 2d 72 65 obgroup (list-re
35d0: 66 20 72 75 6e 2d 6c 69 6d 69 74 73 2d 69 6e 66 f run-limits-inf
35e0: 6f 20 32 29 29 0a 09 09 20 20 20 20 20 28 6d 61 o 2))... (ma
35f0: 78 2d 63 6f 6e 63 75 72 72 65 6e 74 2d 6a 6f 62 x-concurrent-job
3600: 73 20 20 20 20 20 28 6c 69 73 74 2d 72 65 66 20 s (list-ref
3610: 72 75 6e 2d 6c 69 6d 69 74 73 2d 69 6e 66 6f 20 run-limits-info
3620: 33 29 29 0a 09 09 20 20 20 20 20 28 6a 6f 62 2d 3))... (job-
3630: 67 72 6f 75 70 2d 6c 69 6d 69 74 20 20 20 20 20 group-limit
3640: 20 20 20 20 28 6c 69 73 74 2d 72 65 66 20 72 75 (list-ref ru
3650: 6e 2d 6c 69 6d 69 74 73 2d 69 6e 66 6f 20 34 29 n-limits-info 4)
3660: 29 0a 09 09 20 20 20 20 20 28 70 72 65 72 65 71 )... (prereq
3670: 73 2d 6e 6f 74 2d 6d 65 74 20 20 20 20 20 20 20 s-not-met
3680: 20 20 28 63 64 62 3a 72 65 6d 6f 74 65 2d 72 75 (cdb:remote-ru
3690: 6e 20 64 62 3a 67 65 74 2d 70 72 65 72 65 71 73 n db:get-prereqs
36a0: 2d 6e 6f 74 2d 6d 65 74 20 23 66 20 72 75 6e 2d -not-met #f run-
36b0: 69 64 20 77 61 69 74 6f 6e 73 20 69 74 65 6d 2d id waitons item-
36c0: 70 61 74 68 20 6d 6f 64 65 3a 20 74 65 73 74 6d path mode: testm
36d0: 6f 64 65 29 29 0a 09 09 20 20 20 20 20 28 66 61 ode))... (fa
36e0: 69 6c 73 20 20 20 20 20 20 20 20 20 20 20 20 20 ils
36f0: 20 20 20 20 20 20 28 72 75 6e 73 3a 63 61 6c 63 (runs:calc
3700: 2d 66 61 69 6c 73 20 70 72 65 72 65 71 73 2d 6e -fails prereqs-n
3710: 6f 74 2d 6d 65 74 29 29 0a 09 09 20 20 20 20 20 ot-met))...
3720: 28 6e 6f 6e 2d 63 6f 6d 70 6c 65 74 65 64 20 20 (non-completed
3730: 20 20 20 20 20 20 20 20 20 28 72 75 6e 73 3a 63 (runs:c
3740: 61 6c 63 2d 6e 6f 74 2d 63 6f 6d 70 6c 65 74 65 alc-not-complete
3750: 64 20 70 72 65 72 65 71 73 2d 6e 6f 74 2d 6d 65 d prereqs-not-me
3760: 74 29 29 29 0a 09 09 28 64 65 62 75 67 3a 70 72 t)))...(debug:pr
3770: 69 6e 74 2d 69 6e 66 6f 20 38 20 22 68 61 76 65 int-info 8 "have
3780: 2d 72 65 73 6f 75 72 63 65 73 3a 20 22 20 68 61 -resources: " ha
3790: 76 65 2d 72 65 73 6f 75 72 63 65 73 20 22 20 70 ve-resources " p
37a0: 72 65 72 65 71 73 2d 6e 6f 74 2d 6d 65 74 3a 20 rereqs-not-met:
37b0: 22 20 0a 09 09 09 20 20 20 20 20 28 73 74 72 69 " .... (stri
37c0: 6e 67 2d 69 6e 74 65 72 73 70 65 72 73 65 20 0a ng-intersperse .
37d0: 09 09 09 20 20 20 20 20 20 28 6d 61 70 20 28 6c ... (map (l
37e0: 61 6d 62 64 61 20 28 74 29 0a 09 09 09 09 20 20 ambda (t).....
37f0: 20 20 20 28 69 66 20 28 76 65 63 74 6f 72 3f 20 (if (vector?
3800: 74 29 0a 09 09 09 09 09 20 28 63 6f 6e 63 20 28 t)...... (conc (
3810: 64 62 3a 74 65 73 74 2d 67 65 74 2d 73 74 61 74 db:test-get-stat
3820: 65 20 74 29 20 22 2f 22 20 28 64 62 3a 74 65 73 e t) "/" (db:tes
3830: 74 2d 67 65 74 2d 73 74 61 74 75 73 20 74 29 29 t-get-status t))
3840: 0a 09 09 09 09 09 20 28 63 6f 6e 63 20 22 20 57 ...... (conc " W
3850: 41 52 4e 49 4e 47 3a 20 74 20 69 73 20 6e 6f 74 ARNING: t is not
3860: 20 61 20 76 65 63 74 6f 72 3d 22 20 74 20 29 29 a vector=" t ))
3870: 29 0a 09 09 09 09 20 20 20 70 72 65 72 65 71 73 )..... prereqs
3880: 2d 6e 6f 74 2d 6d 65 74 29 20 22 2c 20 22 29 20 -not-met) ", ")
3890: 22 20 66 61 69 6c 73 3a 20 22 20 66 61 69 6c 73 " fails: " fails
38a0: 29 0a 09 09 28 64 65 62 75 67 3a 70 72 69 6e 74 )...(debug:print
38b0: 2d 69 6e 66 6f 20 34 20 22 68 65 64 3d 22 20 68 -info 4 "hed=" h
38c0: 65 64 20 22 5c 6e 20 20 74 65 73 74 2d 72 65 63 ed "\n test-rec
38d0: 6f 72 64 3d 22 20 74 65 73 74 2d 72 65 63 6f 72 ord=" test-recor
38e0: 64 20 22 5c 6e 20 20 74 65 73 74 2d 6e 61 6d 65 d "\n test-name
38f0: 3a 20 22 20 74 65 73 74 2d 6e 61 6d 65 20 22 5c : " test-name "\
3900: 6e 20 20 69 74 65 6d 2d 70 61 74 68 3a 20 22 20 n item-path: "
3910: 69 74 65 6d 2d 70 61 74 68 20 22 5c 6e 20 20 74 item-path "\n t
3920: 65 73 74 2d 70 61 74 74 73 3a 20 22 20 74 65 73 est-patts: " tes
3930: 74 2d 70 61 74 74 73 29 0a 0a 09 09 3b 3b 20 44 t-patts)....;; D
3940: 6f 6e 27 74 20 6b 6e 6f 77 20 61 74 20 74 68 69 on't know at thi
3950: 73 20 74 69 6d 65 20 69 66 20 74 68 65 20 74 65 s time if the te
3960: 73 74 20 68 61 76 65 20 62 65 65 6e 20 6c 61 75 st have been lau
3970: 6e 63 68 65 64 20 61 74 20 73 6f 6d 65 20 74 69 nched at some ti
3980: 6d 65 20 69 6e 20 74 68 65 20 70 61 73 74 0a 09 me in the past..
3990: 09 3b 3b 20 69 2e 65 2e 20 69 73 20 74 68 69 73 .;; i.e. is this
39a0: 20 61 20 72 65 2d 6c 61 75 6e 63 68 3f 0a 09 09 a re-launch?...
39b0: 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 (debug:print-inf
39c0: 6f 20 34 20 22 72 75 6e 2d 6c 69 6d 69 74 73 2d o 4 "run-limits-
39d0: 69 6e 66 6f 20 3d 20 22 20 72 75 6e 2d 6c 69 6d info = " run-lim
39e0: 69 74 73 2d 69 6e 66 6f 29 0a 09 09 28 63 6f 6e its-info)...(con
39f0: 64 20 3b 3b 20 49 4e 4e 45 52 20 43 4f 4e 44 20 d ;; INNER COND
3a00: 23 31 20 66 6f 72 20 61 20 6c 61 75 6e 63 68 61 #1 for a launcha
3a10: 62 6c 65 20 74 65 73 74 0a 09 09 20 3b 3b 20 43 ble test... ;; C
3a20: 68 65 63 6b 20 69 74 65 6d 20 70 61 74 68 20 61 heck item path a
3a30: 67 61 69 6e 73 74 20 69 74 65 6d 2d 70 61 74 74 gainst item-patt
3a40: 73 0a 09 09 20 28 28 6e 6f 74 20 28 74 65 73 74 s... ((not (test
3a50: 73 3a 6d 61 74 63 68 20 74 65 73 74 2d 70 61 74 s:match test-pat
3a60: 74 73 20 28 74 65 73 74 73 3a 74 65 73 74 71 75 ts (tests:testqu
3a70: 65 75 65 2d 67 65 74 2d 74 65 73 74 6e 61 6d 65 eue-get-testname
3a80: 20 74 65 73 74 2d 72 65 63 6f 72 64 29 20 69 74 test-record) it
3a90: 65 6d 2d 70 61 74 68 29 29 20 3b 3b 20 54 68 69 em-path)) ;; Thi
3aa0: 73 20 74 65 73 74 2f 69 74 65 6d 70 61 74 68 20 s test/itempath
3ab0: 69 73 20 6e 6f 74 20 74 6f 20 62 65 20 72 75 6e is not to be run
3ac0: 0a 09 09 20 20 3b 3b 20 65 6c 73 65 20 74 68 65 ... ;; else the
3ad0: 20 72 75 6e 20 69 73 20 73 74 75 63 6b 2c 20 74 run is stuck, t
3ae0: 65 6d 70 6f 72 61 72 69 6c 79 20 6f 72 20 70 65 emporarily or pe
3af0: 72 6d 61 6e 65 6e 74 6c 79 0a 09 09 20 20 3b 3b rmanently... ;;
3b00: 20 62 75 74 20 73 68 6f 75 6c 64 20 63 68 65 63 but should chec
3b10: 6b 20 69 66 20 69 74 20 69 73 20 64 75 65 20 74 k if it is due t
3b20: 6f 20 6c 61 63 6b 20 6f 66 20 72 65 73 6f 75 72 o lack of resour
3b30: 63 65 73 20 76 73 2e 20 70 72 65 72 65 71 75 69 ces vs. prerequi
3b40: 73 69 74 65 73 0a 09 09 20 20 28 64 65 62 75 67 sites... (debug
3b50: 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 31 20 22 53 :print-info 1 "S
3b60: 6b 69 70 70 69 6e 67 20 22 20 28 74 65 73 74 73 kipping " (tests
3b70: 3a 74 65 73 74 71 75 65 75 65 2d 67 65 74 2d 74 :testqueue-get-t
3b80: 65 73 74 6e 61 6d 65 20 74 65 73 74 2d 72 65 63 estname test-rec
3b90: 6f 72 64 29 20 22 20 22 20 69 74 65 6d 2d 70 61 ord) " " item-pa
3ba0: 74 68 20 22 20 61 73 20 69 74 20 64 6f 65 73 6e th " as it doesn
3bb0: 27 74 20 6d 61 74 63 68 20 22 20 74 65 73 74 2d 't match " test-
3bc0: 70 61 74 74 73 29 0a 09 09 20 20 3b 3b 20 28 74 patts)... ;; (t
3bd0: 68 72 65 61 64 2d 73 6c 65 65 70 21 20 2a 67 6c hread-sleep! *gl
3be0: 6f 62 61 6c 2d 64 65 6c 74 61 2a 29 0a 09 09 20 obal-delta*)...
3bf0: 20 28 69 66 20 28 6e 6f 74 20 28 6e 75 6c 6c 3f (if (not (null?
3c00: 20 74 61 6c 29 29 0a 09 09 20 20 20 20 20 20 28 tal))... (
3c10: 6c 6f 6f 70 20 28 63 61 72 20 74 61 6c 29 28 63 loop (car tal)(c
3c20: 64 72 20 74 61 6c 29 20 72 65 67 69 73 74 65 72 dr tal) register
3c30: 65 64 20 72 65 72 75 6e 73 29 29 29 0a 09 09 20 ed reruns)))...
3c40: 3b 3b 20 52 65 67 69 73 74 65 72 79 20 68 61 73 ;; Registery has
3c50: 20 62 65 65 6e 20 73 74 61 72 74 65 64 20 66 6f been started fo
3c60: 72 20 74 68 69 73 20 74 65 73 74 20 62 75 74 20 r this test but
3c70: 68 61 73 20 6e 6f 74 20 79 65 74 20 63 6f 6d 70 has not yet comp
3c80: 6c 65 74 65 64 0a 09 09 20 3b 3b 20 74 68 69 73 leted... ;; this
3c90: 20 73 68 6f 75 6c 64 20 62 65 20 72 61 72 65 2c should be rare,
3ca0: 20 74 68 65 20 63 61 73 65 20 77 68 65 72 65 20 the case where
3cb0: 74 68 65 72 65 20 61 72 65 20 6f 6e 6c 79 20 61 there are only a
3cc0: 20 63 6f 75 70 6c 65 20 6f 66 20 74 65 73 74 73 couple of tests
3cd0: 20 61 6e 64 20 74 68 65 20 64 62 20 69 73 20 73 and the db is s
3ce0: 6c 6f 77 0a 09 09 20 3b 3b 20 64 65 6c 61 79 20 low... ;; delay
3cf0: 61 20 73 68 6f 72 74 20 77 68 69 6c 65 20 61 6e a short while an
3d00: 64 20 63 6f 6e 74 69 6e 75 65 0a 09 09 20 3b 3b d continue... ;;
3d10: 20 28 28 65 71 3f 20 28 68 61 73 68 2d 74 61 62 ((eq? (hash-tab
3d20: 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 74 le-ref/default t
3d30: 65 73 74 2d 72 65 67 69 73 74 65 72 79 20 28 72 est-registery (r
3d40: 75 6e 73 3a 6d 61 6b 65 2d 66 75 6c 6c 2d 74 65 uns:make-full-te
3d50: 73 74 2d 6e 61 6d 65 20 74 65 73 74 2d 6e 61 6d st-name test-nam
3d60: 65 20 69 74 65 6d 2d 70 61 74 68 29 20 23 66 29 e item-path) #f)
3d70: 20 27 73 74 61 72 74 29 0a 09 09 20 3b 3b 20 20 'start)... ;;
3d80: 28 74 68 72 65 61 64 2d 73 6c 65 65 70 21 20 30 (thread-sleep! 0
3d90: 2e 30 31 29 0a 09 09 20 3b 3b 20 20 28 6c 6f 6f .01)... ;; (loo
3da0: 70 20 28 63 61 72 20 6e 65 77 74 61 6c 29 28 63 p (car newtal)(c
3db0: 64 72 20 6e 65 77 74 61 6c 29 20 72 65 72 75 6e dr newtal) rerun
3dc0: 73 29 29 0a 09 09 20 3b 3b 20 63 6f 75 6e 74 20 s))... ;; count
3dd0: 6e 75 6d 62 65 72 20 6f 66 20 27 64 6f 6e 65 2c number of 'done,
3de0: 20 69 66 20 6d 6f 72 65 20 74 68 61 6e 20 31 30 if more than 10
3df0: 30 20 74 68 65 6e 20 73 6b 69 70 20 6f 6e 20 74 0 then skip on t
3e00: 68 72 6f 75 67 68 2e 0a 0a 09 09 20 3b 3b 20 28 hrough..... ;; (
3e10: 28 3c 20 28 6c 65 6e 67 74 68 20 28 66 69 6c 74 (< (length (filt
3e20: 65 72 20 28 6c 61 6d 62 64 61 20 28 78 29 28 65 er (lambda (x)(e
3e30: 71 3f 20 78 20 27 64 6f 6e 65 29 29 28 68 61 73 q? x 'done))(has
3e40: 68 2d 74 61 62 6c 65 2d 76 61 6c 75 65 73 20 74 h-table-values t
3e50: 65 73 74 2d 72 65 67 69 73 74 65 72 79 29 29 29 est-registery)))
3e60: 20 31 30 30 29 20 3b 3b 20 77 68 79 20 67 65 74 100) ;; why get
3e70: 20 6d 6f 72 65 20 74 68 61 6e 20 32 30 30 20 61 more than 200 a
3e80: 68 65 61 64 3f 0a 09 09 20 3b 3b 20 20 0a 09 09 head?... ;; ...
3e90: 20 3b 3b 20 0a 09 09 20 3b 3b 20 20 29 0a 09 09 ;; ... ;; )...
3ea0: 20 28 28 6e 6f 74 20 28 68 61 73 68 2d 74 61 62 ((not (hash-tab
3eb0: 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 74 le-ref/default t
3ec0: 65 73 74 2d 72 65 67 69 73 74 65 72 79 20 28 72 est-registery (r
3ed0: 75 6e 73 3a 6d 61 6b 65 2d 66 75 6c 6c 2d 74 65 uns:make-full-te
3ee0: 73 74 2d 6e 61 6d 65 20 74 65 73 74 2d 6e 61 6d st-name test-nam
3ef0: 65 20 69 74 65 6d 2d 70 61 74 68 29 20 23 66 29 e item-path) #f)
3f00: 29 20 3b 3b 20 74 6f 6f 20 6d 61 6e 79 20 63 68 ) ;; too many ch
3f10: 61 6e 67 65 73 20 72 65 71 75 69 72 65 64 2e 20 anges required.
3f20: 49 6d 70 6c 65 6d 65 6e 74 20 6c 61 74 65 72 2e Implement later.
3f30: 0a 09 09 20 20 28 64 65 62 75 67 3a 70 72 69 6e ... (debug:prin
3f40: 74 2d 69 6e 66 6f 20 34 20 22 50 72 65 2d 72 65 t-info 4 "Pre-re
3f50: 67 69 73 74 65 72 69 6e 67 20 74 65 73 74 20 22 gistering test "
3f60: 20 74 65 73 74 2d 6e 61 6d 65 20 22 2f 22 20 69 test-name "/" i
3f70: 74 65 6d 2d 70 61 74 68 20 22 20 74 6f 20 63 72 tem-path " to cr
3f80: 65 61 74 65 20 70 6c 61 63 65 68 6f 6c 64 65 72 eate placeholder
3f90: 22 20 29 0a 09 09 20 20 3b 3b 20 4e 45 45 44 20 " )... ;; NEED
3fa0: 54 4f 20 54 48 52 45 41 44 49 46 59 20 54 48 49 TO THREADIFY THI
3fb0: 53 0a 09 09 20 20 28 6c 65 74 20 28 28 74 68 20 S... (let ((th
3fc0: 28 6d 61 6b 65 2d 74 68 72 65 61 64 20 28 6c 61 (make-thread (la
3fd0: 6d 62 64 61 20 28 29 0a 09 09 20 20 20 20 20 20 mbda ()...
3fe0: 20 20 09 09 20 20 20 28 6d 75 74 65 78 2d 6c 6f .. (mutex-lo
3ff0: 63 6b 21 20 72 65 67 69 73 74 65 72 79 2d 6d 75 ck! registery-mu
4000: 74 65 78 29 0a 09 09 20 20 20 20 20 20 20 20 09 tex)... .
4010: 09 20 20 20 28 68 61 73 68 2d 74 61 62 6c 65 2d . (hash-table-
4020: 73 65 74 21 20 74 65 73 74 2d 72 65 67 69 73 74 set! test-regist
4030: 65 72 79 20 28 72 75 6e 73 3a 6d 61 6b 65 2d 66 ery (runs:make-f
4040: 75 6c 6c 2d 74 65 73 74 2d 6e 61 6d 65 20 74 65 ull-test-name te
4050: 73 74 2d 6e 61 6d 65 20 69 74 65 6d 2d 70 61 74 st-name item-pat
4060: 68 29 20 27 73 74 61 72 74 29 0a 09 09 20 20 20 h) 'start)...
4070: 20 20 20 20 20 09 09 20 20 20 28 6d 75 74 65 78 .. (mutex
4080: 2d 75 6e 6c 6f 63 6b 21 20 72 65 67 69 73 74 65 -unlock! registe
4090: 72 79 2d 6d 75 74 65 78 29 0a 09 09 09 09 09 20 ry-mutex)......
40a0: 20 20 3b 3b 20 49 66 20 68 61 76 65 6e 27 74 20 ;; If haven't
40b0: 64 6f 6e 65 20 69 74 20 62 65 66 6f 72 65 20 72 done it before r
40c0: 65 67 69 73 74 65 72 20 61 20 74 6f 70 20 6c 65 egister a top le
40d0: 76 65 6c 20 74 65 73 74 20 69 66 20 74 68 69 73 vel test if this
40e0: 20 69 73 20 61 6e 20 69 74 65 6d 69 7a 65 64 20 is an itemized
40f0: 74 65 73 74 0a 09 09 09 09 09 20 20 20 28 69 66 test...... (if
4100: 20 28 6e 6f 74 20 28 65 71 3f 20 28 68 61 73 68 (not (eq? (hash
4110: 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 -table-ref/defau
4120: 6c 74 20 74 65 73 74 2d 72 65 67 69 73 74 65 72 lt test-register
4130: 79 20 28 72 75 6e 73 3a 6d 61 6b 65 2d 66 75 6c y (runs:make-ful
4140: 6c 2d 74 65 73 74 2d 6e 61 6d 65 20 74 65 73 74 l-test-name test
4150: 2d 6e 61 6d 65 20 22 22 29 20 23 66 29 20 27 64 -name "") #f) 'd
4160: 6f 6e 65 29 29 0a 09 09 09 09 09 20 20 20 20 20 one))......
4170: 20 20 28 63 64 62 3a 74 65 73 74 73 2d 72 65 67 (cdb:tests-reg
4180: 69 73 74 65 72 2d 74 65 73 74 20 2a 72 75 6e 72 ister-test *runr
4190: 65 6d 6f 74 65 2a 20 72 75 6e 2d 69 64 20 74 65 emote* run-id te
41a0: 73 74 2d 6e 61 6d 65 20 22 22 29 29 0a 09 09 09 st-name ""))....
41b0: 09 09 20 20 20 28 63 64 62 3a 74 65 73 74 73 2d .. (cdb:tests-
41c0: 72 65 67 69 73 74 65 72 2d 74 65 73 74 20 2a 72 register-test *r
41d0: 75 6e 72 65 6d 6f 74 65 2a 20 72 75 6e 2d 69 64 unremote* run-id
41e0: 20 74 65 73 74 2d 6e 61 6d 65 20 69 74 65 6d 2d test-name item-
41f0: 70 61 74 68 29 0a 09 09 20 20 20 20 20 20 20 20 path)...
4200: 09 09 20 20 20 28 6d 75 74 65 78 2d 6c 6f 63 6b .. (mutex-lock
4210: 21 20 72 65 67 69 73 74 65 72 79 2d 6d 75 74 65 ! registery-mute
4220: 78 29 0a 09 09 09 09 09 20 20 20 28 68 61 73 68 x)...... (hash
4230: 2d 74 61 62 6c 65 2d 73 65 74 21 20 74 65 73 74 -table-set! test
4240: 2d 72 65 67 69 73 74 65 72 79 20 28 72 75 6e 73 -registery (runs
4250: 3a 6d 61 6b 65 2d 66 75 6c 6c 2d 74 65 73 74 2d :make-full-test-
4260: 6e 61 6d 65 20 74 65 73 74 2d 6e 61 6d 65 20 69 name test-name i
4270: 74 65 6d 2d 70 61 74 68 29 20 27 64 6f 6e 65 29 tem-path) 'done)
4280: 0a 09 09 20 20 20 20 20 20 20 20 09 09 20 20 20 ... ..
4290: 28 6d 75 74 65 78 2d 75 6e 6c 6f 63 6b 21 20 72 (mutex-unlock! r
42a0: 65 67 69 73 74 65 72 79 2d 6d 75 74 65 78 29 29 egistery-mutex))
42b0: 0a 09 09 20 20 20 20 20 20 20 20 09 09 20 28 63 ... .. (c
42c0: 6f 6e 63 20 74 65 73 74 2d 6e 61 6d 65 20 22 2f onc test-name "/
42d0: 22 20 69 74 65 6d 2d 70 61 74 68 29 29 29 29 0a " item-path)))).
42e0: 09 09 20 20 20 20 28 74 68 72 65 61 64 2d 73 74 .. (thread-st
42f0: 61 72 74 21 20 74 68 29 29 0a 09 09 20 20 28 74 art! th))... (t
4300: 68 72 65 61 64 2d 73 6c 65 65 70 21 20 2a 67 6c hread-sleep! *gl
4310: 6f 62 61 6c 2d 64 65 6c 74 61 2a 29 0a 09 09 20 obal-delta*)...
4320: 20 28 72 75 6e 73 3a 73 68 72 69 6e 6b 2d 63 61 (runs:shrink-ca
4330: 6e 2d 72 75 6e 2d 6d 6f 72 65 2d 74 65 73 74 73 n-run-more-tests
4340: 2d 64 65 6c 61 79 29 20 20 20 3b 3b 20 44 45 4c -delay) ;; DEL
4350: 41 59 20 54 57 45 41 4b 45 52 20 28 73 74 69 6c AY TWEAKER (stil
4360: 6c 20 6e 65 65 64 65 64 3f 29 0a 09 09 20 20 28 l needed?)... (
4370: 69 66 20 28 3e 20 28 6c 65 6e 67 74 68 20 28 66 if (> (length (f
4380: 69 6c 74 65 72 20 28 6c 61 6d 62 64 61 20 28 78 ilter (lambda (x
4390: 29 28 65 71 3f 20 78 20 27 64 6f 6e 65 29 29 28 )(eq? x 'done))(
43a0: 68 61 73 68 2d 74 61 62 6c 65 2d 76 61 6c 75 65 hash-table-value
43b0: 73 20 74 65 73 74 2d 72 65 67 69 73 74 65 72 79 s test-registery
43c0: 29 29 29 20 31 30 30 29 20 3b 3b 20 73 74 61 72 ))) 100) ;; star
43d0: 74 20 74 68 69 6e 67 73 20 72 75 6e 6e 69 6e 67 t things running
43e0: 20 69 66 20 68 61 76 65 20 61 74 20 6c 65 61 73 if have at leas
43f0: 74 20 31 30 30 20 71 75 65 75 65 64 20 75 70 0a t 100 queued up.
4400: 09 09 20 20 20 20 20 20 28 6c 6f 6f 70 20 28 63 .. (loop (c
4410: 61 72 20 72 65 67 69 73 74 65 72 65 64 29 28 61 ar registered)(a
4420: 70 70 65 6e 64 20 28 63 64 72 20 72 65 67 69 73 ppend (cdr regis
4430: 74 65 72 65 64 29 28 6c 69 73 74 20 68 65 64 29 tered)(list hed)
4440: 20 74 61 6c 29 20 27 28 29 20 72 65 72 75 6e 73 tal) '() reruns
4450: 29 0a 09 09 20 20 20 20 20 20 28 6c 6f 6f 70 20 )... (loop
4460: 28 63 61 72 20 6e 65 77 74 61 6c 29 28 63 64 72 (car newtal)(cdr
4470: 20 6e 65 77 74 61 6c 29 20 28 61 70 70 65 6e 64 newtal) (append
4480: 20 72 65 67 69 73 74 65 72 65 64 20 28 6c 69 73 registered (lis
4490: 74 20 68 65 64 29 29 20 72 65 72 75 6e 73 29 29 t hed)) reruns))
44a0: 29 0a 09 09 20 3b 3b 20 41 74 20 74 68 69 73 20 )... ;; At this
44b0: 70 6f 69 6e 74 20 2a 61 6c 6c 2a 20 74 65 73 74 point *all* test
44c0: 20 72 65 67 69 73 74 72 61 74 69 6f 6e 73 20 6d registrations m
44d0: 75 73 74 20 62 65 20 63 6f 6d 70 6c 65 74 65 64 ust be completed
44e0: 2e 0a 09 09 20 28 28 6e 6f 74 20 28 6e 75 6c 6c .... ((not (null
44f0: 3f 20 28 66 69 6c 74 65 72 20 28 6c 61 6d 62 64 ? (filter (lambd
4500: 61 20 28 78 29 28 65 71 3f 20 27 73 74 61 72 74 a (x)(eq? 'start
4510: 20 78 29 29 28 68 61 73 68 2d 74 61 62 6c 65 2d x))(hash-table-
4520: 76 61 6c 75 65 73 20 74 65 73 74 2d 72 65 67 69 values test-regi
4530: 73 74 65 72 79 29 29 29 29 0a 09 09 20 20 28 64 stery))))... (d
4540: 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 ebug:print-info
4550: 30 20 22 57 61 69 74 69 6e 67 20 6f 6e 20 74 65 0 "Waiting on te
4560: 73 74 20 72 65 67 69 73 74 72 61 74 69 6f 6e 73 st registrations
4570: 3a 20 22 20 28 73 74 72 69 6e 67 2d 69 6e 74 65 : " (string-inte
4580: 72 73 70 65 72 73 65 20 0a 09 09 09 09 09 09 09 rsperse ........
4590: 09 09 20 28 66 69 6c 74 65 72 20 28 6c 61 6d 62 .. (filter (lamb
45a0: 64 61 20 28 78 29 0a 09 09 09 09 09 09 09 09 09 da (x)..........
45b0: 09 20 20 20 28 65 71 3f 20 28 68 61 73 68 2d 74 . (eq? (hash-t
45c0: 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 able-ref/default
45d0: 20 74 65 73 74 2d 72 65 67 69 73 74 65 72 79 20 test-registery
45e0: 78 20 23 66 29 20 27 73 74 61 72 74 29 29 0a 09 x #f) 'start))..
45f0: 09 09 09 09 09 09 09 09 09 20 28 68 61 73 68 2d ......... (hash-
4600: 74 61 62 6c 65 2d 6b 65 79 73 20 74 65 73 74 2d table-keys test-
4610: 72 65 67 69 73 74 65 72 79 29 29 0a 09 09 09 09 registery)).....
4620: 09 09 09 09 09 20 22 2c 20 22 29 29 0a 09 09 20 ..... ", "))...
4630: 20 28 74 68 72 65 61 64 2d 73 6c 65 65 70 21 20 (thread-sleep!
4640: 30 2e 31 29 0a 09 09 20 20 28 6c 6f 6f 70 20 68 0.1)... (loop h
4650: 65 64 20 74 61 6c 20 72 65 67 69 73 74 65 72 65 ed tal registere
4660: 64 20 72 65 72 75 6e 73 29 29 0a 09 09 20 28 28 d reruns))... ((
4670: 6e 6f 74 20 68 61 76 65 2d 72 65 73 6f 75 72 63 not have-resourc
4680: 65 73 29 20 3b 3b 20 73 69 6d 70 6c 79 20 74 72 es) ;; simply tr
4690: 79 20 61 67 61 69 6e 20 61 66 74 65 72 20 77 61 y again after wa
46a0: 69 74 69 6e 67 20 61 20 73 65 63 6f 6e 64 0a 09 iting a second..
46b0: 09 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d . (debug:print-
46c0: 69 6e 66 6f 20 31 20 22 6e 6f 20 72 65 73 6f 75 info 1 "no resou
46d0: 72 63 65 73 20 74 6f 20 72 75 6e 20 6e 65 77 20 rces to run new
46e0: 74 65 73 74 73 2c 20 77 61 69 74 69 6e 67 20 2e tests, waiting .
46f0: 2e 2e 22 29 0a 09 09 20 20 3b 3b 20 48 61 76 65 ..")... ;; Have
4700: 20 67 6f 6e 65 20 62 61 63 6b 20 61 6e 64 20 66 gone back and f
4710: 6f 72 74 68 20 6f 6e 20 74 68 69 73 20 62 75 74 orth on this but
4720: 20 64 62 20 73 74 61 72 76 61 74 69 6f 6e 20 69 db starvation i
4730: 73 20 61 6e 20 69 73 73 75 65 2e 0a 09 09 20 20 s an issue....
4740: 3b 3b 20 77 61 69 74 20 6f 6e 65 20 73 65 63 6f ;; wait one seco
4750: 6e 64 20 62 65 66 6f 72 65 20 6c 6f 6f 6b 69 6e nd before lookin
4760: 67 20 61 67 61 69 6e 20 74 6f 20 72 75 6e 20 6a g again to run j
4770: 6f 62 73 2e 0a 09 09 20 20 28 74 68 72 65 61 64 obs.... (thread
4780: 2d 73 6c 65 65 70 21 20 31 29 20 3b 3b 20 28 2b -sleep! 1) ;; (+
4790: 20 32 20 2a 67 6c 6f 62 61 6c 2d 64 65 6c 74 61 2 *global-delta
47a0: 2a 29 29 0a 09 09 20 20 3b 3b 20 63 6f 75 6c 64 *))... ;; could
47b0: 20 68 61 76 65 20 64 6f 6e 65 20 68 65 64 20 74 have done hed t
47c0: 61 6c 20 68 65 72 65 20 62 75 74 20 64 6f 69 6e al here but doin
47d0: 67 20 63 61 72 2f 63 64 72 20 6f 66 20 6e 65 77 g car/cdr of new
47e0: 74 61 6c 20 74 6f 20 72 6f 74 61 74 65 20 74 65 tal to rotate te
47f0: 73 74 73 0a 09 09 20 20 28 6c 6f 6f 70 20 28 63 sts... (loop (c
4800: 61 72 20 6e 65 77 74 61 6c 29 28 63 64 72 20 6e ar newtal)(cdr n
4810: 65 77 74 61 6c 29 20 72 65 67 69 73 74 65 72 65 ewtal) registere
4820: 64 20 72 65 72 75 6e 73 29 29 0a 09 09 20 28 28 d reruns))... ((
4830: 61 6e 64 20 68 61 76 65 2d 72 65 73 6f 75 72 63 and have-resourc
4840: 65 73 0a 09 09 20 20 20 20 20 20 20 28 6f 72 20 es... (or
4850: 28 6e 75 6c 6c 3f 20 70 72 65 72 65 71 73 2d 6e (null? prereqs-n
4860: 6f 74 2d 6d 65 74 29 0a 09 09 09 20 20 20 28 61 ot-met).... (a
4870: 6e 64 20 28 65 71 3f 20 74 65 73 74 6d 6f 64 65 nd (eq? testmode
4880: 20 27 74 6f 70 6c 65 76 65 6c 29 0a 09 09 09 09 'toplevel).....
4890: 28 6e 75 6c 6c 3f 20 6e 6f 6e 2d 63 6f 6d 70 6c (null? non-compl
48a0: 65 74 65 64 29 29 29 29 0a 09 09 20 20 28 72 75 eted))))... (ru
48b0: 6e 3a 74 65 73 74 20 72 75 6e 2d 69 64 20 72 75 n:test run-id ru
48c0: 6e 6e 61 6d 65 20 6b 65 79 76 61 6c 6c 73 74 20 nname keyvallst
48d0: 74 65 73 74 2d 72 65 63 6f 72 64 20 66 6c 61 67 test-record flag
48e0: 73 20 23 66 29 0a 09 09 20 20 28 68 61 73 68 2d s #f)... (hash-
48f0: 74 61 62 6c 65 2d 73 65 74 21 20 74 65 73 74 2d table-set! test-
4900: 72 65 67 69 73 74 65 72 79 20 28 72 75 6e 73 3a registery (runs:
4910: 6d 61 6b 65 2d 66 75 6c 6c 2d 74 65 73 74 2d 6e make-full-test-n
4920: 61 6d 65 20 74 65 73 74 2d 6e 61 6d 65 20 69 74 ame test-name it
4930: 65 6d 2d 70 61 74 68 29 20 27 72 75 6e 6e 69 6e em-path) 'runnin
4940: 67 29 0a 09 09 20 20 28 72 75 6e 73 3a 73 68 72 g)... (runs:shr
4950: 69 6e 6b 2d 63 61 6e 2d 72 75 6e 2d 6d 6f 72 65 ink-can-run-more
4960: 2d 74 65 73 74 73 2d 64 65 6c 61 79 29 20 20 3b -tests-delay) ;
4970: 3b 20 44 45 4c 41 59 20 54 57 45 41 4b 45 52 20 ; DELAY TWEAKER
4980: 28 73 74 69 6c 6c 20 6e 65 65 64 65 64 3f 29 0a (still needed?).
4990: 09 09 20 20 3b 3b 20 28 74 68 72 65 61 64 2d 73 .. ;; (thread-s
49a0: 6c 65 65 70 21 20 2a 67 6c 6f 62 61 6c 2d 64 65 leep! *global-de
49b0: 6c 74 61 2a 29 0a 09 09 20 20 28 69 66 20 28 6e lta*)... (if (n
49c0: 6f 74 20 28 6e 75 6c 6c 3f 20 74 61 6c 29 29 0a ot (null? tal)).
49d0: 09 09 20 20 20 20 20 20 28 6c 6f 6f 70 20 28 63 .. (loop (c
49e0: 61 72 20 74 61 6c 29 28 63 64 72 20 74 61 6c 29 ar tal)(cdr tal)
49f0: 20 72 65 67 69 73 74 65 72 65 64 20 72 65 72 75 registered reru
4a00: 6e 73 29 29 29 0a 09 09 20 28 65 6c 73 65 20 3b ns)))... (else ;
4a10: 3b 20 6d 75 73 74 20 62 65 20 77 65 20 68 61 76 ; must be we hav
4a20: 65 20 75 6e 6d 65 74 20 70 72 65 72 65 71 75 69 e unmet prerequi
4a30: 73 69 74 65 73 0a 09 09 20 20 20 20 28 64 65 62 sites... (deb
4a40: 75 67 3a 70 72 69 6e 74 20 34 20 22 46 41 49 4c ug:print 4 "FAIL
4a50: 53 3a 20 22 20 66 61 69 6c 73 29 0a 09 09 20 20 S: " fails)...
4a60: 20 20 3b 3b 20 49 66 20 6f 6e 65 20 6f 72 20 6d ;; If one or m
4a70: 6f 72 65 20 6f 66 20 74 68 65 20 70 72 65 72 65 ore of the prere
4a80: 71 73 2d 6e 6f 74 2d 6d 65 74 20 61 72 65 20 46 qs-not-met are F
4a90: 41 49 4c 20 74 68 65 6e 20 77 65 20 63 61 6e 20 AIL then we can
4aa0: 69 73 73 75 65 0a 09 09 20 20 20 20 3b 3b 20 61 issue... ;; a
4ab0: 20 6d 65 73 73 61 67 65 20 61 6e 64 20 64 72 6f message and dro
4ac0: 70 20 68 65 64 20 66 72 6f 6d 20 74 68 65 20 69 p hed from the i
4ad0: 74 65 6d 73 20 74 6f 20 62 65 20 70 72 6f 63 65 tems to be proce
4ae0: 73 73 65 64 2e 0a 09 09 20 20 20 20 28 69 66 20 ssed.... (if
4af0: 28 6e 75 6c 6c 3f 20 66 61 69 6c 73 29 0a 09 09 (null? fails)...
4b00: 09 28 62 65 67 69 6e 0a 09 09 09 20 20 3b 3b 20 .(begin.... ;;
4b10: 63 6f 75 6c 64 6e 27 74 20 72 75 6e 2c 20 74 61 couldn't run, ta
4b20: 6b 65 20 61 20 62 72 65 61 74 68 65 72 0a 09 09 ke a breather...
4b30: 09 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d . (debug:print-
4b40: 69 6e 66 6f 20 34 20 22 53 68 6f 75 6c 64 6e 27 info 4 "Shouldn'
4b50: 74 20 72 65 61 6c 6c 79 20 67 65 74 20 68 65 72 t really get her
4b60: 65 2c 20 72 61 63 65 20 63 6f 6e 64 69 74 69 6f e, race conditio
4b70: 6e 3f 20 55 6e 61 62 6c 65 20 74 6f 20 6c 61 75 n? Unable to lau
4b80: 6e 63 68 20 6d 6f 72 65 20 74 65 73 74 73 20 61 nch more tests a
4b90: 74 20 74 68 69 73 20 6d 6f 6d 65 6e 74 2c 20 6b t this moment, k
4ba0: 69 6c 6c 69 6e 67 20 74 69 6d 65 20 2e 2e 2e 22 illing time ..."
4bb0: 29 0a 09 09 09 20 20 3b 3b 20 28 74 68 72 65 61 ).... ;; (threa
4bc0: 64 2d 73 6c 65 65 70 21 20 28 2b 20 30 2e 30 31 d-sleep! (+ 0.01
4bd0: 20 2a 67 6c 6f 62 61 6c 2d 64 65 6c 74 61 2a 29 *global-delta*)
4be0: 29 20 3b 3b 20 6c 6f 6e 67 20 73 6c 65 65 70 20 ) ;; long sleep
4bf0: 68 65 72 65 20 2d 20 6e 6f 20 72 65 73 6f 75 72 here - no resour
4c00: 63 65 73 2c 20 6d 61 79 20 61 73 20 77 65 6c 6c ces, may as well
4c10: 20 62 65 20 70 61 74 69 65 6e 74 0a 09 09 09 20 be patient....
4c20: 20 3b 3b 20 77 65 20 6d 61 64 65 20 6e 65 77 20 ;; we made new
4c30: 74 61 6c 20 62 79 20 73 74 69 63 6b 69 6e 67 20 tal by sticking
4c40: 68 65 64 20 61 74 20 74 68 65 20 62 61 63 6b 20 hed at the back
4c50: 6f 66 20 74 68 65 20 6c 69 73 74 0a 09 09 09 20 of the list....
4c60: 20 28 6c 6f 6f 70 20 28 63 61 72 20 6e 65 77 74 (loop (car newt
4c70: 61 6c 29 28 63 64 72 20 6e 65 77 74 61 6c 29 20 al)(cdr newtal)
4c80: 72 65 67 69 73 74 65 72 65 64 20 72 65 72 75 6e registered rerun
4c90: 73 29 29 0a 09 09 09 3b 3b 20 74 68 65 20 77 61 s))....;; the wa
4ca0: 69 74 6f 6e 20 69 73 20 46 41 49 4c 20 73 6f 20 iton is FAIL so
4cb0: 6e 6f 20 70 6f 69 6e 74 20 69 6e 20 74 72 79 69 no point in tryi
4cc0: 6e 67 20 74 6f 20 72 75 6e 20 68 65 64 20 65 76 ng to run hed ev
4cd0: 65 72 20 61 67 61 69 6e 0a 09 09 09 28 69 66 20 er again....(if
4ce0: 28 6e 6f 74 20 28 6e 75 6c 6c 3f 20 74 61 6c 29 (not (null? tal)
4cf0: 29 0a 09 09 09 20 20 20 20 28 69 66 20 28 76 65 ).... (if (ve
4d00: 63 74 6f 72 3f 20 68 65 64 29 0a 09 09 09 09 28 ctor? hed).....(
4d10: 62 65 67 69 6e 20 0a 09 09 09 09 20 20 28 64 65 begin ..... (de
4d20: 62 75 67 3a 70 72 69 6e 74 20 31 20 22 57 41 52 bug:print 1 "WAR
4d30: 4e 3a 20 44 72 6f 70 70 69 6e 67 20 74 65 73 74 N: Dropping test
4d40: 20 22 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d " (db:test-get-
4d50: 74 65 73 74 6e 61 6d 65 20 68 65 64 29 20 22 2f testname hed) "/
4d60: 22 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 69 " (db:test-get-i
4d70: 74 65 6d 2d 70 61 74 68 20 68 65 64 29 0a 09 09 tem-path hed)...
4d80: 09 09 09 20 20 20 20 20 20 20 22 20 66 72 6f 6d ... " from
4d90: 20 74 68 65 20 6c 61 75 6e 63 68 20 6c 69 73 74 the launch list
4da0: 20 61 73 20 69 74 20 68 61 73 20 70 72 65 72 65 as it has prere
4db0: 71 75 69 73 74 65 73 20 74 68 61 74 20 61 72 65 quistes that are
4dc0: 20 46 41 49 4c 22 29 0a 09 09 09 09 20 20 28 72 FAIL")..... (r
4dd0: 75 6e 73 3a 73 68 72 69 6e 6b 2d 63 61 6e 2d 72 uns:shrink-can-r
4de0: 75 6e 2d 6d 6f 72 65 2d 74 65 73 74 73 2d 64 65 un-more-tests-de
4df0: 6c 61 79 29 20 3b 3b 20 44 45 4c 41 59 20 54 57 lay) ;; DELAY TW
4e00: 45 41 4b 45 52 20 28 73 74 69 6c 6c 20 6e 65 65 EAKER (still nee
4e10: 64 65 64 3f 29 0a 09 09 09 09 20 20 3b 3b 20 28 ded?)..... ;; (
4e20: 74 68 72 65 61 64 2d 73 6c 65 65 70 21 20 2a 67 thread-sleep! *g
4e30: 6c 6f 62 61 6c 2d 64 65 6c 74 61 2a 29 0a 09 09 lobal-delta*)...
4e40: 09 09 20 20 28 68 61 73 68 2d 74 61 62 6c 65 2d .. (hash-table-
4e50: 73 65 74 21 20 74 65 73 74 2d 72 65 67 69 73 74 set! test-regist
4e60: 65 72 79 20 28 72 75 6e 73 3a 6d 61 6b 65 2d 66 ery (runs:make-f
4e70: 75 6c 6c 2d 74 65 73 74 2d 6e 61 6d 65 20 74 65 ull-test-name te
4e80: 73 74 2d 6e 61 6d 65 20 69 74 65 6d 2d 70 61 74 st-name item-pat
4e90: 68 29 20 27 72 65 6d 6f 76 65 64 29 0a 09 09 09 h) 'removed)....
4ea0: 09 20 20 28 6c 6f 6f 70 20 28 63 61 72 20 74 61 . (loop (car ta
4eb0: 6c 29 28 63 64 72 20 74 61 6c 29 20 72 65 67 69 l)(cdr tal) regi
4ec0: 73 74 65 72 65 64 20 28 63 6f 6e 73 20 68 65 64 stered (cons hed
4ed0: 20 72 65 72 75 6e 73 29 29 29 0a 09 09 09 09 28 reruns))).....(
4ee0: 62 65 67 69 6e 0a 09 09 09 09 20 20 28 64 65 62 begin..... (deb
4ef0: 75 67 3a 70 72 69 6e 74 20 31 20 22 57 41 52 4e ug:print 1 "WARN
4f00: 3a 20 54 65 73 74 20 6e 6f 74 20 70 72 6f 63 65 : Test not proce
4f10: 73 73 65 64 20 63 6f 72 72 65 63 74 6c 79 2e 20 ssed correctly.
4f20: 43 6f 75 6c 64 20 62 65 20 61 20 72 61 63 65 20 Could be a race
4f30: 63 6f 6e 64 69 74 69 6f 6e 20 69 6e 20 79 6f 75 condition in you
4f40: 72 20 74 65 73 74 20 69 6d 70 6c 65 6d 65 6e 74 r test implement
4f50: 61 74 69 6f 6e 3f 20 22 20 68 65 64 29 20 3b 3b ation? " hed) ;;
4f60: 20 20 22 20 61 73 20 69 74 20 68 61 73 20 70 72 " as it has pr
4f70: 65 72 65 71 75 69 73 74 65 73 20 74 68 61 74 20 erequistes that
4f80: 61 72 65 20 46 41 49 4c 2e 20 28 4e 4f 54 45 3a are FAIL. (NOTE:
4f90: 20 68 65 64 20 69 73 20 6e 6f 74 20 61 20 76 65 hed is not a ve
4fa0: 63 74 6f 72 29 22 29 0a 09 09 09 09 20 20 28 72 ctor)")..... (r
4fb0: 75 6e 73 3a 73 68 72 69 6e 6b 2d 63 61 6e 2d 72 uns:shrink-can-r
4fc0: 75 6e 2d 6d 6f 72 65 2d 74 65 73 74 73 2d 64 65 un-more-tests-de
4fd0: 6c 61 79 29 20 3b 3b 20 44 45 4c 41 59 20 54 57 lay) ;; DELAY TW
4fe0: 45 41 4b 45 52 20 28 73 74 69 6c 6c 20 6e 65 65 EAKER (still nee
4ff0: 64 65 64 3f 29 0a 09 09 09 09 20 20 3b 3b 20 28 ded?)..... ;; (
5000: 74 68 72 65 61 64 2d 73 6c 65 65 70 21 20 28 2b thread-sleep! (+
5010: 20 30 2e 30 31 20 2a 67 6c 6f 62 61 6c 2d 64 65 0.01 *global-de
5020: 6c 74 61 2a 29 29 0a 09 09 09 09 20 20 28 6c 6f lta*))..... (lo
5030: 6f 70 20 68 65 64 20 74 61 6c 20 72 65 67 69 73 op hed tal regis
5040: 74 65 72 65 64 20 72 65 72 75 6e 73 29 29 29 29 tered reruns))))
5050: 29 29 29 29 29 20 3b 3b 20 45 4e 44 20 4f 46 20 ))))) ;; END OF
5060: 49 4e 4e 45 52 20 43 4f 4e 44 0a 09 20 20 20 20 INNER COND..
5070: 20 0a 09 20 20 20 20 20 3b 3b 20 63 61 73 65 20 .. ;; case
5080: 77 68 65 72 65 20 61 6e 20 69 74 65 6d 73 20 63 where an items c
5090: 61 6d 65 20 69 6e 20 61 73 20 61 20 6c 69 73 74 ame in as a list
50a0: 20 62 65 65 6e 20 70 72 6f 63 65 73 73 65 64 0a been processed.
50b0: 09 20 20 20 20 20 28 28 61 6e 64 20 28 6c 69 73 . ((and (lis
50c0: 74 3f 20 69 74 65 6d 73 29 20 20 20 20 20 3b 3b t? items) ;;
50d0: 20 74 68 75 73 20 77 65 20 6b 6e 6f 77 20 6f 75 thus we know ou
50e0: 72 20 69 74 65 6d 73 20 61 72 65 20 61 6c 72 65 r items are alre
50f0: 61 64 79 20 63 61 6c 63 75 6c 61 74 65 64 0a 09 ady calculated..
5100: 09 20 20 20 28 6e 6f 74 20 20 20 69 74 65 6d 64 . (not itemd
5110: 61 74 29 29 20 3b 3b 20 61 6e 64 20 6e 6f 74 20 at)) ;; and not
5120: 79 65 74 20 65 78 70 61 6e 64 65 64 20 69 6e 74 yet expanded int
5130: 6f 20 74 68 65 20 6c 69 73 74 20 6f 66 20 74 68 o the list of th
5140: 69 6e 67 73 20 74 6f 20 62 65 20 64 6f 6e 65 0a ings to be done.
5150: 09 20 20 20 20 20 20 28 69 66 20 28 61 6e 64 20 . (if (and
5160: 28 64 65 62 75 67 3a 64 65 62 75 67 2d 6d 6f 64 (debug:debug-mod
5170: 65 20 31 29 20 3b 3b 20 28 3e 3d 20 2a 76 65 72 e 1) ;; (>= *ver
5180: 62 6f 73 69 74 79 2a 20 31 29 0a 09 09 20 20 20 bosity* 1)...
5190: 20 20 20 20 28 3e 20 28 6c 65 6e 67 74 68 20 69 (> (length i
51a0: 74 65 6d 73 29 20 30 29 0a 09 09 20 20 20 20 20 tems) 0)...
51b0: 20 20 28 3e 20 28 6c 65 6e 67 74 68 20 28 63 61 (> (length (ca
51c0: 72 20 69 74 65 6d 73 29 29 20 30 29 29 0a 09 09 r items)) 0))...
51d0: 20 20 28 70 70 20 69 74 65 6d 73 29 29 0a 09 20 (pp items))..
51e0: 20 20 20 20 20 28 66 6f 72 2d 65 61 63 68 0a 09 (for-each..
51f0: 20 20 20 20 20 20 20 28 6c 61 6d 62 64 61 20 28 (lambda (
5200: 6d 79 2d 69 74 65 6d 64 61 74 29 0a 09 09 20 28 my-itemdat)... (
5210: 6c 65 74 2a 20 28 28 6e 65 77 2d 74 65 73 74 2d let* ((new-test-
5220: 72 65 63 6f 72 64 20 28 6c 65 74 20 28 28 6e 65 record (let ((ne
5230: 77 72 65 63 20 28 6d 61 6b 65 2d 74 65 73 74 73 wrec (make-tests
5240: 3a 74 65 73 74 71 75 65 75 65 29 29 29 0a 09 09 :testqueue)))...
5250: 09 09 09 20 20 20 28 76 65 63 74 6f 72 2d 63 6f ... (vector-co
5260: 70 79 21 20 74 65 73 74 2d 72 65 63 6f 72 64 20 py! test-record
5270: 6e 65 77 72 65 63 29 0a 09 09 09 09 09 20 20 20 newrec)......
5280: 6e 65 77 72 65 63 29 29 0a 09 09 09 28 6d 79 2d newrec))....(my-
5290: 69 74 65 6d 2d 70 61 74 68 20 28 69 74 65 6d 2d item-path (item-
52a0: 6c 69 73 74 2d 3e 70 61 74 68 20 6d 79 2d 69 74 list->path my-it
52b0: 65 6d 64 61 74 29 29 29 0a 09 09 20 20 20 28 69 emdat)))... (i
52c0: 66 20 28 74 65 73 74 73 3a 6d 61 74 63 68 20 74 f (tests:match t
52d0: 65 73 74 2d 70 61 74 74 73 20 68 65 64 20 6d 79 est-patts hed my
52e0: 2d 69 74 65 6d 2d 70 61 74 68 29 20 3b 3b 20 28 -item-path) ;; (
52f0: 70 61 74 74 2d 6c 69 73 74 2d 6d 61 74 63 68 20 patt-list-match
5300: 6d 79 2d 69 74 65 6d 2d 70 61 74 68 20 69 74 65 my-item-path ite
5310: 6d 2d 70 61 74 74 73 29 20 20 20 20 20 20 20 20 m-patts)
5320: 20 20 20 3b 3b 20 79 65 73 2c 20 77 65 20 77 61 ;; yes, we wa
5330: 6e 74 20 74 6f 20 70 72 6f 63 65 73 73 20 74 68 nt to process th
5340: 69 73 20 69 74 65 6d 2c 20 4e 4f 54 45 3a 20 53 is item, NOTE: S
5350: 68 6f 75 6c 64 20 6e 6f 74 20 6e 65 65 64 20 74 hould not need t
5360: 68 69 73 20 63 68 65 63 6b 20 68 65 72 65 21 0a his check here!.
5370: 09 09 20 20 20 20 20 20 20 28 6c 65 74 20 28 28 .. (let ((
5380: 6e 65 77 74 65 73 74 6e 61 6d 65 20 28 72 75 6e newtestname (run
5390: 73 3a 6d 61 6b 65 2d 66 75 6c 6c 2d 74 65 73 74 s:make-full-test
53a0: 2d 6e 61 6d 65 20 68 65 64 20 6d 79 2d 69 74 65 -name hed my-ite
53b0: 6d 2d 70 61 74 68 29 29 29 20 20 20 20 3b 3b 20 m-path))) ;;
53c0: 74 65 73 74 20 6e 61 6d 65 73 20 61 72 65 20 75 test names are u
53d0: 6e 69 71 75 65 20 6f 6e 20 74 65 73 74 6e 61 6d nique on testnam
53e0: 65 2f 69 74 65 6d 2d 70 61 74 68 0a 09 09 09 20 e/item-path....
53f0: 28 74 65 73 74 73 3a 74 65 73 74 71 75 65 75 65 (tests:testqueue
5400: 2d 73 65 74 2d 69 74 65 6d 73 21 20 20 20 20 20 -set-items!
5410: 6e 65 77 2d 74 65 73 74 2d 72 65 63 6f 72 64 20 new-test-record
5420: 23 66 29 0a 09 09 09 20 28 74 65 73 74 73 3a 74 #f).... (tests:t
5430: 65 73 74 71 75 65 75 65 2d 73 65 74 2d 69 74 65 estqueue-set-ite
5440: 6d 64 61 74 21 20 20 20 6e 65 77 2d 74 65 73 74 mdat! new-test
5450: 2d 72 65 63 6f 72 64 20 6d 79 2d 69 74 65 6d 64 -record my-itemd
5460: 61 74 29 0a 09 09 09 20 28 74 65 73 74 73 3a 74 at).... (tests:t
5470: 65 73 74 71 75 65 75 65 2d 73 65 74 2d 69 74 65 estqueue-set-ite
5480: 6d 5f 70 61 74 68 21 20 6e 65 77 2d 74 65 73 74 m_path! new-test
5490: 2d 72 65 63 6f 72 64 20 6d 79 2d 69 74 65 6d 2d -record my-item-
54a0: 70 61 74 68 29 0a 09 09 09 20 28 68 61 73 68 2d path).... (hash-
54b0: 74 61 62 6c 65 2d 73 65 74 21 20 74 65 73 74 2d table-set! test-
54c0: 72 65 63 6f 72 64 73 20 6e 65 77 74 65 73 74 6e records newtestn
54d0: 61 6d 65 20 6e 65 77 2d 74 65 73 74 2d 72 65 63 ame new-test-rec
54e0: 6f 72 64 29 0a 09 09 09 20 28 73 65 74 21 20 74 ord).... (set! t
54f0: 61 6c 20 28 63 6f 6e 73 20 6e 65 77 74 65 73 74 al (cons newtest
5500: 6e 61 6d 65 20 74 61 6c 29 29 29 29 29 29 20 3b name tal)))))) ;
5510: 3b 20 73 69 6e 63 65 20 74 68 65 73 65 20 61 72 ; since these ar
5520: 65 20 69 74 65 6d 69 7a 65 64 20 63 72 65 61 74 e itemized creat
5530: 65 20 6e 65 77 20 74 65 73 74 20 6e 61 6d 65 73 e new test names
5540: 20 74 65 73 74 6e 61 6d 65 2f 69 74 65 6d 70 61 testname/itempa
5550: 74 68 0a 09 20 20 20 20 20 20 20 69 74 65 6d 73 th.. items
5560: 29 0a 09 20 20 20 20 20 20 28 69 66 20 28 6e 6f ).. (if (no
5570: 74 20 28 6e 75 6c 6c 3f 20 74 61 6c 29 29 0a 09 t (null? tal))..
5580: 09 20 20 28 62 65 67 69 6e 0a 09 09 20 20 20 20 . (begin...
5590: 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 (debug:print-inf
55a0: 6f 20 34 20 22 45 6e 64 20 6f 66 20 69 74 65 6d o 4 "End of item
55b0: 73 20 6c 69 73 74 2c 20 6c 6f 6f 70 69 6e 67 20 s list, looping
55c0: 77 69 74 68 20 6e 65 78 74 20 61 66 74 65 72 20 with next after
55d0: 73 68 6f 72 74 20 64 65 6c 61 79 22 29 0a 20 20 short delay").
55e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
55f0: 20 20 3b 3b 20 28 74 68 72 65 61 64 2d 73 6c 65 ;; (thread-sle
5600: 65 70 21 20 28 2b 20 30 2e 30 31 20 2a 67 6c 6f ep! (+ 0.01 *glo
5610: 62 61 6c 2d 64 65 6c 74 61 2a 29 29 0a 09 09 20 bal-delta*))...
5620: 20 20 20 28 6c 6f 6f 70 20 28 63 61 72 20 74 61 (loop (car ta
5630: 6c 29 28 63 64 72 20 74 61 6c 29 20 72 65 67 69 l)(cdr tal) regi
5640: 73 74 65 72 65 64 20 72 65 72 75 6e 73 29 29 29 stered reruns)))
5650: 29 0a 0a 09 20 20 20 20 20 3b 3b 20 69 66 20 69 )... ;; if i
5660: 74 65 6d 73 20 69 73 20 61 20 70 72 6f 63 20 74 tems is a proc t
5670: 68 65 6e 20 6e 65 65 64 20 74 6f 20 72 75 6e 20 hen need to run
5680: 69 74 65 6d 73 3a 67 65 74 2d 69 74 65 6d 73 2d items:get-items-
5690: 66 72 6f 6d 2d 63 6f 6e 66 69 67 2c 20 67 65 74 from-config, get
56a0: 20 74 68 65 20 6c 69 73 74 20 61 6e 64 20 6c 6f the list and lo
56b0: 6f 70 20 0a 09 20 20 20 20 20 3b 3b 20 20 20 20 op .. ;;
56c0: 2d 20 62 75 74 20 6f 6e 6c 79 20 64 6f 20 74 68 - but only do th
56d0: 61 74 20 69 66 20 72 65 73 6f 75 72 63 65 73 20 at if resources
56e0: 65 78 69 73 74 20 74 6f 20 6b 69 63 6b 20 6f 66 exist to kick of
56f0: 66 20 74 68 65 20 6a 6f 62 0a 09 20 20 20 20 20 f the job..
5700: 28 28 6f 72 20 28 70 72 6f 63 65 64 75 72 65 3f ((or (procedure?
5710: 20 69 74 65 6d 73 29 28 65 71 3f 20 69 74 65 6d items)(eq? item
5720: 73 20 27 68 61 76 65 2d 70 72 6f 63 65 64 75 72 s 'have-procedur
5730: 65 29 29 0a 09 20 20 20 20 20 20 28 6c 65 74 20 e)).. (let
5740: 28 28 63 61 6e 2d 72 75 6e 2d 6d 6f 72 65 20 20 ((can-run-more
5750: 20 20 28 72 75 6e 73 3a 63 61 6e 2d 72 75 6e 2d (runs:can-run-
5760: 6d 6f 72 65 2d 74 65 73 74 73 20 74 65 73 74 2d more-tests test-
5770: 72 65 63 6f 72 64 29 29 29 0a 09 09 28 69 66 20 record)))...(if
5780: 28 61 6e 64 20 28 6c 69 73 74 3f 20 63 61 6e 2d (and (list? can-
5790: 72 75 6e 2d 6d 6f 72 65 29 0a 09 09 09 20 28 63 run-more).... (c
57a0: 61 72 20 63 61 6e 2d 72 75 6e 2d 6d 6f 72 65 29 ar can-run-more)
57b0: 29 0a 09 09 20 20 20 20 28 6c 65 74 2a 20 28 28 )... (let* ((
57c0: 70 72 65 72 65 71 73 2d 6e 6f 74 2d 6d 65 74 20 prereqs-not-met
57d0: 28 6f 70 65 6e 2d 72 75 6e 2d 63 6c 6f 73 65 20 (open-run-close
57e0: 64 62 3a 67 65 74 2d 70 72 65 72 65 71 73 2d 6e db:get-prereqs-n
57f0: 6f 74 2d 6d 65 74 20 23 66 20 72 75 6e 2d 69 64 ot-met #f run-id
5800: 20 77 61 69 74 6f 6e 73 20 69 74 65 6d 2d 70 61 waitons item-pa
5810: 74 68 20 6d 6f 64 65 3a 20 74 65 73 74 6d 6f 64 th mode: testmod
5820: 65 29 29 0a 09 09 09 20 20 20 28 66 61 69 6c 73 e)).... (fails
5830: 20 20 20 20 20 20 20 20 20 20 20 28 72 75 6e 73 (runs
5840: 3a 63 61 6c 63 2d 66 61 69 6c 73 20 70 72 65 72 :calc-fails prer
5850: 65 71 73 2d 6e 6f 74 2d 6d 65 74 29 29 0a 09 09 eqs-not-met))...
5860: 09 20 20 20 28 6e 6f 6e 2d 63 6f 6d 70 6c 65 74 . (non-complet
5870: 65 64 20 20 20 28 72 75 6e 73 3a 63 61 6c 63 2d ed (runs:calc-
5880: 6e 6f 74 2d 63 6f 6d 70 6c 65 74 65 64 20 70 72 not-completed pr
5890: 65 72 65 71 73 2d 6e 6f 74 2d 6d 65 74 29 29 29 ereqs-not-met)))
58a0: 0a 09 09 20 20 20 20 20 20 28 64 65 62 75 67 3a ... (debug:
58b0: 70 72 69 6e 74 2d 69 6e 66 6f 20 38 20 22 63 61 print-info 8 "ca
58c0: 6e 2d 72 75 6e 2d 6d 6f 72 65 3a 20 22 20 63 61 n-run-more: " ca
58d0: 6e 2d 72 75 6e 2d 6d 6f 72 65 0a 09 09 09 09 20 n-run-more.....
58e0: 20 20 22 5c 6e 20 74 65 73 74 6e 61 6d 65 3a 20 "\n testname:
58f0: 20 20 20 20 20 20 20 22 20 68 65 64 0a 09 09 09 " hed....
5900: 09 20 20 20 22 5c 6e 20 70 72 65 72 65 71 73 2d . "\n prereqs-
5910: 6e 6f 74 2d 6d 65 74 3a 20 22 20 28 72 75 6e 73 not-met: " (runs
5920: 3a 70 72 65 74 74 79 2d 73 74 72 69 6e 67 20 70 :pretty-string p
5930: 72 65 72 65 71 73 2d 6e 6f 74 2d 6d 65 74 29 0a rereqs-not-met).
5940: 09 09 09 09 20 20 20 22 5c 6e 20 6e 6f 6e 2d 63 .... "\n non-c
5950: 6f 6d 70 6c 65 74 65 64 3a 20 20 20 22 20 28 72 ompleted: " (r
5960: 75 6e 73 3a 70 72 65 74 74 79 2d 73 74 72 69 6e uns:pretty-strin
5970: 67 20 6e 6f 6e 2d 63 6f 6d 70 6c 65 74 65 64 29 g non-completed)
5980: 20 0a 09 09 09 09 20 20 20 22 5c 6e 20 66 61 69 ..... "\n fai
5990: 6c 73 3a 20 20 20 20 20 20 20 20 20 20 20 22 20 ls: "
59a0: 28 72 75 6e 73 3a 70 72 65 74 74 79 2d 73 74 72 (runs:pretty-str
59b0: 69 6e 67 20 66 61 69 6c 73 29 0a 09 09 09 09 20 ing fails).....
59c0: 20 20 22 5c 6e 20 74 65 73 74 6d 6f 64 65 3a 20 "\n testmode:
59d0: 20 20 20 20 20 20 20 22 20 74 65 73 74 6d 6f 64 " testmod
59e0: 65 0a 09 09 09 09 20 20 20 22 5c 6e 20 6e 75 6d e..... "\n num
59f0: 2d 72 65 74 72 69 65 73 3a 20 20 20 20 20 22 20 -retries: "
5a00: 6e 75 6d 2d 72 65 74 72 69 65 73 0a 09 09 09 09 num-retries.....
5a10: 20 20 20 22 5c 6e 20 28 65 71 3f 20 74 65 73 74 "\n (eq? test
5a20: 6d 6f 64 65 20 27 74 6f 70 6c 65 76 65 6c 29 3a mode 'toplevel):
5a30: 20 22 20 28 65 71 3f 20 74 65 73 74 6d 6f 64 65 " (eq? testmode
5a40: 20 27 74 6f 70 6c 65 76 65 6c 29 0a 09 09 09 09 'toplevel).....
5a50: 20 20 20 22 5c 6e 20 28 6e 75 6c 6c 3f 20 6e 6f "\n (null? no
5a60: 6e 2d 63 6f 6d 70 6c 65 74 65 64 29 3a 20 20 20 n-completed):
5a70: 20 22 20 28 6e 75 6c 6c 3f 20 6e 6f 6e 2d 63 6f " (null? non-co
5a80: 6d 70 6c 65 74 65 64 29 0a 09 09 09 09 20 20 20 mpleted).....
5a90: 22 5c 6e 20 72 65 72 75 6e 73 3a 20 20 20 20 20 "\n reruns:
5aa0: 20 20 20 20 20 22 20 72 65 72 75 6e 73 0a 09 09 " reruns...
5ab0: 09 09 20 20 20 22 5c 6e 20 69 74 65 6d 73 3a 20 .. "\n items:
5ac0: 20 20 20 20 20 20 20 20 20 20 22 20 69 74 65 6d " item
5ad0: 73 0a 09 09 09 09 20 20 20 22 5c 6e 20 63 61 6e s..... "\n can
5ae0: 2d 72 75 6e 2d 6d 6f 72 65 3a 20 20 20 20 22 20 -run-more: "
5af0: 63 61 6e 2d 72 75 6e 2d 6d 6f 72 65 29 0a 09 09 can-run-more)...
5b00: 20 20 20 20 20 20 3b 3b 20 28 74 68 72 65 61 64 ;; (thread
5b10: 2d 73 6c 65 65 70 21 20 28 2b 20 30 2e 30 31 20 -sleep! (+ 0.01
5b20: 2a 67 6c 6f 62 61 6c 2d 64 65 6c 74 61 2a 29 29 *global-delta*))
5b30: 0a 09 09 20 20 20 20 20 20 28 63 6f 6e 64 20 3b ... (cond ;
5b40: 3b 20 49 4e 4e 45 52 20 43 4f 4e 44 20 23 32 0a ; INNER COND #2.
5b50: 09 09 20 20 20 20 20 20 20 28 28 6f 72 20 28 6e .. ((or (n
5b60: 75 6c 6c 3f 20 70 72 65 72 65 71 73 2d 6e 6f 74 ull? prereqs-not
5b70: 2d 6d 65 74 29 20 3b 3b 20 61 6c 6c 20 70 72 65 -met) ;; all pre
5b80: 72 65 71 73 20 6d 65 74 2c 20 66 69 72 65 20 6f reqs met, fire o
5b90: 66 66 20 74 68 65 20 74 65 73 74 0a 09 09 09 20 ff the test....
5ba0: 20 20 20 3b 3b 20 6f 72 2c 20 69 66 20 69 74 20 ;; or, if it
5bb0: 69 73 20 61 20 27 74 6f 70 6c 65 76 65 6c 20 74 is a 'toplevel t
5bc0: 65 73 74 20 61 6e 64 20 61 6c 6c 20 70 72 65 72 est and all prer
5bd0: 65 71 73 20 6e 6f 74 20 6d 65 74 20 61 72 65 20 eqs not met are
5be0: 43 4f 4d 50 4c 45 54 45 44 20 74 68 65 6e 20 6c COMPLETED then l
5bf0: 61 75 6e 63 68 0a 09 09 09 20 20 20 20 28 61 6e aunch.... (an
5c00: 64 20 28 65 71 3f 20 74 65 73 74 6d 6f 64 65 20 d (eq? testmode
5c10: 27 74 6f 70 6c 65 76 65 6c 29 0a 09 09 09 09 20 'toplevel).....
5c20: 28 6e 75 6c 6c 3f 20 6e 6f 6e 2d 63 6f 6d 70 6c (null? non-compl
5c30: 65 74 65 64 29 29 29 0a 09 09 09 28 6c 65 74 20 eted)))....(let
5c40: 28 28 74 65 73 74 2d 6e 61 6d 65 20 28 74 65 73 ((test-name (tes
5c50: 74 73 3a 74 65 73 74 71 75 65 75 65 2d 67 65 74 ts:testqueue-get
5c60: 2d 74 65 73 74 6e 61 6d 65 20 74 65 73 74 2d 72 -testname test-r
5c70: 65 63 6f 72 64 29 29 29 0a 09 09 09 20 20 28 73 ecord))).... (s
5c80: 65 74 65 6e 76 20 22 4d 54 5f 54 45 53 54 5f 4e etenv "MT_TEST_N
5c90: 41 4d 45 22 20 74 65 73 74 2d 6e 61 6d 65 29 20 AME" test-name)
5ca0: 3b 3b 20 0a 09 09 09 20 20 28 73 65 74 65 6e 76 ;; .... (setenv
5cb0: 20 22 4d 54 5f 52 55 4e 4e 41 4d 45 22 20 20 20 "MT_RUNNAME"
5cc0: 72 75 6e 6e 61 6d 65 29 0a 09 09 09 20 20 28 73 runname).... (s
5cd0: 65 74 2d 6d 65 67 61 74 65 73 74 2d 65 6e 76 2d et-megatest-env-
5ce0: 76 61 72 73 20 72 75 6e 2d 69 64 29 20 3b 3b 20 vars run-id) ;;
5cf0: 74 68 65 73 65 20 6d 61 79 20 62 65 20 6e 65 65 these may be nee
5d00: 64 65 64 20 62 79 20 74 68 65 20 6c 61 75 6e 63 ded by the launc
5d10: 68 69 6e 67 20 70 72 6f 63 65 73 73 0a 09 09 09 hing process....
5d20: 20 20 28 6c 65 74 20 28 28 69 74 65 6d 73 2d 6c (let ((items-l
5d30: 69 73 74 20 28 69 74 65 6d 73 3a 67 65 74 2d 69 ist (items:get-i
5d40: 74 65 6d 73 2d 66 72 6f 6d 2d 63 6f 6e 66 69 67 tems-from-config
5d50: 20 74 63 6f 6e 66 69 67 29 29 29 0a 09 09 09 20 tconfig)))....
5d60: 20 20 20 28 69 66 20 28 6c 69 73 74 3f 20 69 74 (if (list? it
5d70: 65 6d 73 2d 6c 69 73 74 29 0a 09 09 09 09 28 62 ems-list).....(b
5d80: 65 67 69 6e 0a 09 09 09 09 20 20 28 74 65 73 74 egin..... (test
5d90: 73 3a 74 65 73 74 71 75 65 75 65 2d 73 65 74 2d s:testqueue-set-
5da0: 69 74 65 6d 73 21 20 74 65 73 74 2d 72 65 63 6f items! test-reco
5db0: 72 64 20 69 74 65 6d 73 2d 6c 69 73 74 29 0a 09 rd items-list)..
5dc0: 09 09 09 20 20 3b 3b 20 28 74 68 72 65 61 64 2d ... ;; (thread-
5dd0: 73 6c 65 65 70 21 20 2a 67 6c 6f 62 61 6c 2d 64 sleep! *global-d
5de0: 65 6c 74 61 2a 29 0a 09 09 09 09 20 20 28 6c 6f elta*)..... (lo
5df0: 6f 70 20 68 65 64 20 74 61 6c 20 72 65 67 69 73 op hed tal regis
5e00: 74 65 72 65 64 20 72 65 72 75 6e 73 29 29 0a 09 tered reruns))..
5e10: 09 09 09 28 62 65 67 69 6e 0a 09 09 09 09 20 20 ...(begin.....
5e20: 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 22 (debug:print 0 "
5e30: 45 52 52 4f 52 3a 20 54 68 65 20 70 72 6f 63 20 ERROR: The proc
5e40: 66 72 6f 6d 20 72 65 61 64 69 6e 67 20 74 68 65 from reading the
5e50: 20 73 65 74 75 70 20 64 69 64 20 6e 6f 74 20 79 setup did not y
5e60: 69 65 6c 64 20 61 20 6c 69 73 74 20 2d 20 70 6c ield a list - pl
5e70: 65 61 73 65 20 72 65 70 6f 72 74 20 74 68 69 73 ease report this
5e80: 22 29 0a 09 09 09 09 20 20 28 65 78 69 74 20 31 ")..... (exit 1
5e90: 29 29 29 29 29 29 0a 09 09 20 20 20 20 20 20 20 ))))))...
5ea0: 28 28 6e 75 6c 6c 3f 20 66 61 69 6c 73 29 0a 09 ((null? fails)..
5eb0: 09 09 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 ..(debug:print-i
5ec0: 6e 66 6f 20 34 20 22 66 61 69 6c 73 20 69 73 20 nfo 4 "fails is
5ed0: 6e 75 6c 6c 2c 20 6d 6f 76 69 6e 67 20 6f 6e 20 null, moving on
5ee0: 69 6e 20 74 68 65 20 71 75 65 75 65 20 62 75 74 in the queue but
5ef0: 20 6b 65 65 70 69 6e 67 20 22 20 68 65 64 20 22 keeping " hed "
5f00: 20 66 6f 72 20 6e 6f 77 22 29 0a 09 09 09 3b 3b for now")....;;
5f10: 20 6f 6e 6c 79 20 69 6e 63 72 65 6d 65 6e 74 20 only increment
5f20: 6e 75 6d 2d 72 65 74 72 69 65 73 20 77 68 65 6e num-retries when
5f30: 20 74 68 65 72 65 20 61 72 65 20 6e 6f 20 74 65 there are no te
5f40: 73 74 73 20 72 75 6e 69 6e 67 0a 09 09 09 28 69 sts runing....(i
5f50: 66 20 28 65 71 3f 20 30 20 28 6c 69 73 74 2d 72 f (eq? 0 (list-r
5f60: 65 66 20 63 61 6e 2d 72 75 6e 2d 6d 6f 72 65 20 ef can-run-more
5f70: 31 29 29 0a 09 09 09 20 20 20 20 28 62 65 67 69 1)).... (begi
5f80: 6e 0a 09 09 09 20 20 20 20 20 20 28 69 66 20 28 n.... (if (
5f90: 3e 20 6e 75 6d 2d 72 65 74 72 69 65 73 20 31 30 > num-retries 10
5fa0: 30 29 20 3b 3b 20 66 69 72 73 74 20 31 30 30 20 0) ;; first 100
5fb0: 72 65 74 72 69 65 73 20 61 72 65 20 6c 6f 77 20 retries are low
5fc0: 74 69 6d 65 20 63 6f 73 74 0a 09 09 09 09 20 20 time cost.....
5fd0: 28 74 68 72 65 61 64 2d 73 6c 65 65 70 21 20 28 (thread-sleep! (
5fe0: 2b 20 32 20 2a 67 6c 6f 62 61 6c 2d 64 65 6c 74 + 2 *global-delt
5ff0: 61 2a 29 29 0a 09 09 09 09 20 20 28 74 68 72 65 a*))..... (thre
6000: 61 64 2d 73 6c 65 65 70 21 20 28 2b 20 30 2e 30 ad-sleep! (+ 0.0
6010: 31 20 2a 67 6c 6f 62 61 6c 2d 64 65 6c 74 61 2a 1 *global-delta*
6020: 29 29 29 0a 09 09 09 20 20 20 20 20 20 28 73 65 ))).... (se
6030: 74 21 20 6e 75 6d 2d 72 65 74 72 69 65 73 20 28 t! num-retries (
6040: 2b 20 6e 75 6d 2d 72 65 74 72 69 65 73 20 31 29 + num-retries 1)
6050: 29 29 29 0a 09 09 09 28 69 66 20 28 3e 20 6e 75 )))....(if (> nu
6060: 6d 2d 72 65 74 72 69 65 73 20 20 6d 61 78 2d 72 m-retries max-r
6070: 65 74 72 69 65 73 29 0a 09 09 09 20 20 20 20 28 etries).... (
6080: 69 66 20 28 6e 6f 74 20 28 6e 75 6c 6c 3f 20 74 if (not (null? t
6090: 61 6c 29 29 0a 09 09 09 09 28 6c 6f 6f 70 20 28 al)).....(loop (
60a0: 63 61 72 20 74 61 6c 29 28 63 64 72 20 74 61 6c car tal)(cdr tal
60b0: 29 20 72 65 67 69 73 74 65 72 65 64 20 72 65 72 ) registered rer
60c0: 75 6e 73 29 29 0a 09 09 09 20 20 20 20 28 6c 6f uns)).... (lo
60d0: 6f 70 20 28 63 61 72 20 6e 65 77 74 61 6c 29 28 op (car newtal)(
60e0: 63 64 72 20 6e 65 77 74 61 6c 29 20 72 65 67 69 cdr newtal) regi
60f0: 73 74 65 72 65 64 20 72 65 72 75 6e 73 29 29 29 stered reruns)))
6100: 20 3b 3b 20 61 6e 20 69 73 73 75 65 20 77 69 74 ;; an issue wit
6110: 68 20 70 72 65 72 65 71 73 20 6e 6f 74 20 79 65 h prereqs not ye
6120: 74 20 6d 65 74 3f 0a 09 09 20 20 20 20 20 20 20 t met?...
6130: 28 28 61 6e 64 20 28 6e 6f 74 20 28 6e 75 6c 6c ((and (not (null
6140: 3f 20 66 61 69 6c 73 29 29 28 65 71 3f 20 74 65 ? fails))(eq? te
6150: 73 74 6d 6f 64 65 20 27 6e 6f 72 6d 61 6c 29 29 stmode 'normal))
6160: 0a 09 09 09 28 64 65 62 75 67 3a 70 72 69 6e 74 ....(debug:print
6170: 2d 69 6e 66 6f 20 31 20 22 74 65 73 74 20 22 20 -info 1 "test "
6180: 20 68 65 64 20 22 20 28 6d 6f 64 65 3d 22 20 74 hed " (mode=" t
6190: 65 73 74 6d 6f 64 65 20 22 29 20 68 61 73 20 66 estmode ") has f
61a0: 61 69 6c 65 64 20 70 72 65 72 65 71 75 69 73 69 ailed prerequisi
61b0: 74 65 28 73 29 3b 20 22 0a 09 09 09 09 20 20 20 te(s); ".....
61c0: 20 20 28 73 74 72 69 6e 67 2d 69 6e 74 65 72 73 (string-inters
61d0: 70 65 72 73 65 20 28 6d 61 70 20 28 6c 61 6d 62 perse (map (lamb
61e0: 64 61 20 28 74 29 28 63 6f 6e 63 20 28 64 62 3a da (t)(conc (db:
61f0: 74 65 73 74 2d 67 65 74 2d 74 65 73 74 6e 61 6d test-get-testnam
6200: 65 20 74 29 20 22 3a 22 20 28 64 62 3a 74 65 73 e t) ":" (db:tes
6210: 74 2d 67 65 74 2d 73 74 61 74 65 20 74 29 22 2f t-get-state t)"/
6220: 22 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 73 74 "(db:test-get-st
6230: 61 74 75 73 20 74 29 29 29 20 66 61 69 6c 73 29 atus t))) fails)
6240: 20 22 2c 20 22 29 0a 09 09 09 09 20 20 20 20 20 ", ").....
6250: 22 2c 20 72 65 6d 6f 76 69 6e 67 20 69 74 20 66 ", removing it f
6260: 72 6f 6d 20 74 6f 2d 64 6f 20 6c 69 73 74 22 29 rom to-do list")
6270: 0a 09 09 09 28 69 66 20 28 6e 6f 74 20 28 6e 75 ....(if (not (nu
6280: 6c 6c 3f 20 74 61 6c 29 29 0a 09 09 09 20 20 20 ll? tal))....
6290: 20 28 62 65 67 69 6e 0a 20 20 20 20 20 20 20 20 (begin.
62a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
62b0: 20 20 20 20 20 20 3b 3b 20 28 74 68 72 65 61 64 ;; (thread
62c0: 2d 73 6c 65 65 70 21 20 2a 67 6c 6f 62 61 6c 2d -sleep! *global-
62d0: 64 65 6c 74 61 2a 29 0a 09 09 09 20 20 20 20 20 delta*)....
62e0: 20 28 6c 6f 6f 70 20 28 63 61 72 20 74 61 6c 29 (loop (car tal)
62f0: 28 63 64 72 20 74 61 6c 29 20 72 65 67 69 73 74 (cdr tal) regist
6300: 65 72 65 64 20 28 63 6f 6e 73 20 68 65 64 20 72 ered (cons hed r
6310: 65 72 75 6e 73 29 29 29 29 29 0a 09 09 20 20 20 eruns)))))...
6320: 20 20 20 20 28 65 6c 73 65 0a 09 09 09 28 64 65 (else....(de
6330: 62 75 67 3a 70 72 69 6e 74 20 38 20 22 45 52 52 bug:print 8 "ERR
6340: 4f 52 3a 20 4e 6f 20 68 61 6e 64 6c 65 72 20 66 OR: No handler f
6350: 6f 72 20 74 68 69 73 20 63 6f 6e 64 69 74 69 6f or this conditio
6360: 6e 2e 22 29 0a 09 09 09 28 74 68 72 65 61 64 2d n.")....(thread-
6370: 73 6c 65 65 70 21 20 28 2b 20 31 20 2a 67 6c 6f sleep! (+ 1 *glo
6380: 62 61 6c 2d 64 65 6c 74 61 2a 29 29 0a 09 09 09 bal-delta*))....
6390: 28 6c 6f 6f 70 20 28 63 61 72 20 6e 65 77 74 61 (loop (car newta
63a0: 6c 29 28 63 64 72 20 6e 65 77 74 61 6c 29 20 72 l)(cdr newtal) r
63b0: 65 67 69 73 74 65 72 65 64 20 72 65 72 75 6e 73 egistered reruns
63c0: 29 29 29 29 20 3b 3b 20 45 4e 44 20 4f 46 20 49 )))) ;; END OF I
63d0: 46 20 43 41 4e 20 52 55 4e 20 4d 4f 52 45 0a 0a F CAN RUN MORE..
63e0: 09 09 20 20 20 20 3b 3b 20 69 66 20 63 61 6e 27 .. ;; if can'
63f0: 74 20 72 75 6e 20 6d 6f 72 65 20 6a 75 73 74 20 t run more just
6400: 6c 6f 6f 70 20 77 69 74 68 20 6e 65 78 74 20 70 loop with next p
6410: 6f 73 73 69 62 6c 65 20 74 65 73 74 0a 09 09 20 ossible test...
6420: 20 20 20 28 62 65 67 69 6e 0a 09 09 20 20 20 20 (begin...
6430: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 (debug:print-i
6440: 6e 66 6f 20 34 20 22 70 72 6f 63 65 73 73 69 6e nfo 4 "processin
6450: 67 20 74 68 65 20 63 61 73 65 20 77 69 74 68 20 g the case with
6460: 61 20 6c 61 6d 62 64 61 20 66 6f 72 20 69 74 65 a lambda for ite
6470: 6d 73 20 6f 72 20 27 68 61 76 65 2d 70 72 6f 63 ms or 'have-proc
6480: 65 64 75 72 65 2e 20 4d 6f 76 69 6e 67 20 74 68 edure. Moving th
6490: 72 6f 75 67 68 20 74 68 65 20 71 75 65 75 65 20 rough the queue
64a0: 77 69 74 68 6f 75 74 20 64 72 6f 70 70 69 6e 67 without dropping
64b0: 20 22 20 68 65 64 29 0a 09 09 20 20 20 20 20 20 " hed)...
64c0: 3b 3b 20 28 74 68 72 65 61 64 2d 73 6c 65 65 70 ;; (thread-sleep
64d0: 21 20 28 2b 20 32 20 2a 67 6c 6f 62 61 6c 2d 64 ! (+ 2 *global-d
64e0: 65 6c 74 61 2a 29 29 0a 09 09 20 20 20 20 20 20 elta*))...
64f0: 28 6c 6f 6f 70 20 28 63 61 72 20 6e 65 77 74 61 (loop (car newta
6500: 6c 29 28 63 64 72 20 6e 65 77 74 61 6c 29 20 72 l)(cdr newtal) r
6510: 65 67 69 73 74 65 72 65 64 20 72 65 72 75 6e 73 egistered reruns
6520: 29 29 29 29 29 20 3b 3b 20 45 4e 44 20 4f 46 20 ))))) ;; END OF
6530: 28 6f 72 20 28 70 72 6f 63 65 64 75 72 65 3f 20 (or (procedure?
6540: 69 74 65 6d 73 29 28 65 71 3f 20 69 74 65 6d 73 items)(eq? items
6550: 20 27 68 61 76 65 2d 70 72 6f 63 65 64 75 72 65 'have-procedure
6560: 29 29 0a 09 20 20 20 20 20 0a 09 20 20 20 20 20 )).. ..
6570: 3b 3b 20 74 68 69 73 20 63 61 73 65 20 73 68 6f ;; this case sho
6580: 75 6c 64 20 6e 6f 74 20 68 61 70 70 65 6e 2c 20 uld not happen,
6590: 61 64 64 65 64 20 74 6f 20 68 65 6c 70 20 63 61 added to help ca
65a0: 74 63 68 20 61 6e 79 20 62 75 67 73 0a 09 20 20 tch any bugs..
65b0: 20 20 20 28 28 61 6e 64 20 28 6c 69 73 74 3f 20 ((and (list?
65c0: 69 74 65 6d 73 29 20 69 74 65 6d 64 61 74 29 0a items) itemdat).
65d0: 09 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 . (debug:pr
65e0: 69 6e 74 20 30 20 22 45 52 52 4f 52 3a 20 53 68 int 0 "ERROR: Sh
65f0: 6f 75 6c 64 20 6e 6f 74 20 68 61 76 65 20 61 20 ould not have a
6600: 6c 69 73 74 20 6f 66 20 69 74 65 6d 73 20 69 6e list of items in
6610: 20 61 20 74 65 73 74 20 61 6e 64 20 74 68 65 20 a test and the
6620: 69 74 65 6d 73 70 61 74 68 20 73 65 74 20 2d 20 itemspath set -
6630: 70 6c 65 61 73 65 20 72 65 70 6f 72 74 20 74 68 please report th
6640: 69 73 22 29 0a 09 20 20 20 20 20 20 28 65 78 69 is").. (exi
6650: 74 20 31 29 29 0a 09 20 20 20 20 20 28 28 6e 6f t 1)).. ((no
6660: 74 20 28 6e 75 6c 6c 3f 20 72 65 72 75 6e 73 29 t (null? reruns)
6670: 29 0a 09 20 20 20 20 20 20 28 6c 65 74 2a 20 28 ).. (let* (
6680: 28 6e 65 77 6c 73 74 20 28 74 65 73 74 73 3a 66 (newlst (tests:f
6690: 69 6c 74 65 72 2d 6e 6f 6e 2d 72 75 6e 6e 61 62 ilter-non-runnab
66a0: 6c 65 20 72 75 6e 2d 69 64 20 74 61 6c 20 74 65 le run-id tal te
66b0: 73 74 2d 72 65 63 6f 72 64 73 29 29 20 3b 3b 20 st-records)) ;;
66c0: 69 2e 65 2e 20 6e 6f 74 20 46 41 49 4c 2c 20 57 i.e. not FAIL, W
66d0: 41 49 56 45 44 2c 20 49 4e 43 4f 4d 50 4c 45 54 AIVED, INCOMPLET
66e0: 45 2c 20 50 41 53 53 2c 20 4b 49 4c 4c 45 44 2c E, PASS, KILLED,
66f0: 0a 09 09 20 20 20 20 20 28 6a 75 6e 6b 65 64 20 ... (junked
6700: 28 6c 73 65 74 2d 64 69 66 66 65 72 65 6e 63 65 (lset-difference
6710: 20 65 71 75 61 6c 3f 20 74 61 6c 20 6e 65 77 6c equal? tal newl
6720: 73 74 29 29 29 0a 09 09 28 64 65 62 75 67 3a 70 st)))...(debug:p
6730: 72 69 6e 74 2d 69 6e 66 6f 20 34 20 22 66 75 6c rint-info 4 "ful
6740: 6c 20 64 72 6f 70 20 74 68 72 6f 75 67 68 2c 20 l drop through,
6750: 69 66 20 72 65 72 75 6e 73 20 69 73 20 6c 65 73 if reruns is les
6760: 73 20 74 68 61 6e 20 31 30 30 20 77 65 20 77 69 s than 100 we wi
6770: 6c 6c 20 66 6f 72 63 65 20 72 65 74 72 79 20 74 ll force retry t
6780: 68 65 6d 2c 20 72 65 72 75 6e 73 3d 22 20 72 65 hem, reruns=" re
6790: 72 75 6e 73 20 22 2c 20 74 61 6c 3d 22 20 74 61 runs ", tal=" ta
67a0: 6c 29 0a 09 09 28 69 66 20 28 3c 20 6e 75 6d 2d l)...(if (< num-
67b0: 72 65 74 72 69 65 73 20 6d 61 78 2d 72 65 74 72 retries max-retr
67c0: 69 65 73 29 0a 09 09 20 20 20 20 28 73 65 74 21 ies)... (set!
67d0: 20 6e 65 77 6c 73 74 20 28 61 70 70 65 6e 64 20 newlst (append
67e0: 72 65 72 75 6e 73 20 6e 65 77 6c 73 74 29 29 29 reruns newlst)))
67f0: 0a 09 09 28 73 65 74 21 20 6e 75 6d 2d 72 65 74 ...(set! num-ret
6800: 72 69 65 73 20 28 2b 20 6e 75 6d 2d 72 65 74 72 ries (+ num-retr
6810: 69 65 73 20 31 29 29 0a 09 09 3b 3b 20 28 74 68 ies 1))...;; (th
6820: 72 65 61 64 2d 73 6c 65 65 70 21 20 28 2b 20 31 read-sleep! (+ 1
6830: 20 2a 67 6c 6f 62 61 6c 2d 64 65 6c 74 61 2a 29 *global-delta*)
6840: 29 0a 09 09 28 69 66 20 28 6e 6f 74 20 28 6e 75 )...(if (not (nu
6850: 6c 6c 3f 20 6e 65 77 6c 73 74 29 29 0a 09 09 20 ll? newlst))...
6860: 20 20 20 3b 3b 20 73 69 6e 63 65 20 72 65 72 75 ;; since reru
6870: 6e 73 20 68 61 76 65 20 62 65 65 6e 20 74 61 63 ns have been tac
6880: 6b 65 64 20 6f 6e 20 74 6f 20 6e 65 77 6c 73 74 ked on to newlst
6890: 20 63 72 65 61 74 65 20 6e 65 77 20 72 65 72 75 create new reru
68a0: 6e 73 20 66 72 6f 6d 20 6a 75 6e 6b 65 64 0a 09 ns from junked..
68b0: 09 20 20 20 20 28 6c 6f 6f 70 20 28 63 61 72 20 . (loop (car
68c0: 6e 65 77 6c 73 74 29 28 63 64 72 20 6e 65 77 6c newlst)(cdr newl
68d0: 73 74 29 20 72 65 67 69 73 74 65 72 65 64 20 28 st) registered (
68e0: 64 65 6c 65 74 65 2d 64 75 70 6c 69 63 61 74 65 delete-duplicate
68f0: 73 20 6a 75 6e 6b 65 64 29 29 29 29 29 0a 09 20 s junked)))))..
6900: 20 20 20 20 28 28 6e 6f 74 20 28 6e 75 6c 6c 3f ((not (null?
6910: 20 74 61 6c 29 29 0a 09 20 20 20 20 20 20 28 64 tal)).. (d
6920: 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 ebug:print-info
6930: 34 20 22 49 27 6d 20 70 72 65 74 74 79 20 73 75 4 "I'm pretty su
6940: 72 65 20 49 20 73 68 6f 75 6c 64 6e 27 74 20 67 re I shouldn't g
6950: 65 74 20 68 65 72 65 2e 22 29 29 0a 09 20 20 20 et here."))..
6960: 20 20 28 65 6c 73 65 0a 09 20 20 20 20 20 20 28 (else.. (
6970: 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f debug:print-info
6980: 20 34 20 22 45 78 69 74 69 6e 67 20 6c 6f 6f 70 4 "Exiting loop
6990: 20 77 69 74 68 2e 2e 2e 5c 6e 20 20 68 65 64 3d with...\n hed=
69a0: 22 20 68 65 64 20 22 5c 6e 20 20 74 61 6c 3d 22 " hed "\n tal="
69b0: 20 74 61 6c 20 22 5c 6e 20 20 72 65 72 75 6e 73 tal "\n reruns
69c0: 3d 22 20 72 65 72 75 6e 73 29 29 0a 09 20 20 20 =" reruns))..
69d0: 20 20 29 29 29 29 20 3b 3b 20 4c 45 54 2a 20 28 )))) ;; LET* (
69e0: 28 74 65 73 74 2d 72 65 63 6f 72 64 0a 0a 20 20 (test-record..
69f0: 20 20 3b 3b 20 77 65 20 67 65 74 20 68 65 72 65 ;; we get here
6a00: 20 6f 6e 20 22 64 72 6f 70 20 74 68 72 6f 75 67 on "drop throug
6a10: 68 22 20 2d 20 6c 6f 6f 70 20 66 6f 72 20 6e 65 h" - loop for ne
6a20: 78 74 20 74 65 73 74 20 69 6e 20 71 75 65 75 65 xt test in queue
6a30: 0a 20 20 20 20 3b 3b 20 46 49 58 4d 45 21 21 21 . ;; FIXME!!!
6a40: 21 20 54 48 49 53 20 53 48 4f 55 4c 44 20 4e 4f ! THIS SHOULD NO
6a50: 54 20 52 45 51 55 49 52 45 20 41 4e 20 45 58 49 T REQUIRE AN EXI
6a60: 54 21 21 21 21 21 21 21 0a 20 20 20 20 0a 20 20 T!!!!!!!. .
6a70: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 (debug:print-i
6a80: 6e 66 6f 20 31 20 22 41 6c 6c 20 74 65 73 74 73 nfo 1 "All tests
6a90: 20 6c 61 75 6e 63 68 65 64 22 29 0a 20 20 20 20 launched").
6aa0: 28 74 68 72 65 61 64 2d 73 6c 65 65 70 21 20 30 (thread-sleep! 0
6ab0: 2e 35 29 0a 20 20 20 20 3b 3b 20 46 49 58 4d 45 .5). ;; FIXME
6ac0: 21 20 54 68 69 73 20 68 61 72 73 68 20 65 78 69 ! This harsh exi
6ad0: 74 20 73 68 6f 75 6c 64 20 6e 6f 74 20 62 65 20 t should not be
6ae0: 6e 65 63 65 73 73 61 72 79 2e 2e 2e 2e 0a 20 20 necessary.....
6af0: 20 20 3b 3b 20 28 69 66 20 28 6e 6f 74 20 2a 72 ;; (if (not *r
6b00: 75 6e 72 65 6d 6f 74 65 2a 29 28 65 78 69 74 29 unremote*)(exit)
6b10: 29 20 3b 3b 20 0a 20 20 20 20 23 66 29 29 20 3b ) ;; . #f)) ;
6b20: 3b 20 72 65 74 75 72 6e 20 61 20 23 66 20 61 73 ; return a #f as
6b30: 20 61 20 68 69 6e 74 20 74 68 61 74 20 77 65 20 a hint that we
6b40: 61 72 65 20 64 6f 6e 65 0a 20 20 3b 3b 20 48 65 are done. ;; He
6b50: 72 65 20 77 65 20 6e 65 65 64 20 74 6f 20 63 68 re we need to ch
6b60: 65 63 6b 20 74 68 61 74 20 61 6c 6c 20 74 68 65 eck that all the
6b70: 20 74 65 73 74 73 20 72 65 6d 61 69 6e 69 6e 67 tests remaining
6b80: 20 74 6f 20 62 65 20 72 75 6e 20 61 72 65 20 65 to be run are e
6b90: 6c 69 67 69 62 6c 65 20 74 6f 20 72 75 6e 0a 20 ligible to run.
6ba0: 20 3b 3b 20 61 6e 64 20 61 72 65 20 6e 6f 74 20 ;; and are not
6bb0: 62 6c 6f 63 6b 65 64 20 62 79 20 66 61 69 6c 65 blocked by faile
6bc0: 64 0a 20 20 0a 0a 3b 3b 20 70 61 72 65 6e 74 2d d. ..;; parent-
6bd0: 74 65 73 74 20 69 73 20 74 68 65 72 65 20 61 73 test is there as
6be0: 20 61 20 70 6c 61 63 65 68 6f 6c 64 65 72 20 66 a placeholder f
6bf0: 6f 72 20 77 68 65 6e 20 70 61 72 65 6e 74 2d 74 or when parent-t
6c00: 65 73 74 73 20 63 61 6e 20 62 65 20 72 75 6e 20 ests can be run
6c10: 61 73 20 61 20 73 65 74 75 70 20 73 74 65 70 0a as a setup step.
6c20: 28 64 65 66 69 6e 65 20 28 72 75 6e 3a 74 65 73 (define (run:tes
6c30: 74 20 72 75 6e 2d 69 64 20 72 75 6e 6e 61 6d 65 t run-id runname
6c40: 20 6b 65 79 76 61 6c 6c 73 74 20 74 65 73 74 2d keyvallst test-
6c50: 72 65 63 6f 72 64 20 66 6c 61 67 73 20 70 61 72 record flags par
6c60: 65 6e 74 2d 74 65 73 74 29 0a 20 20 3b 3b 20 41 ent-test). ;; A
6c70: 6c 6c 20 74 68 65 73 65 20 76 61 72 73 20 6d 69 ll these vars mi
6c80: 67 68 74 20 62 65 20 72 65 66 65 72 65 6e 63 65 ght be reference
6c90: 64 20 62 79 20 74 68 65 20 74 65 73 74 63 6f 6e d by the testcon
6ca0: 66 69 67 20 66 69 6c 65 20 72 65 61 64 65 72 0a fig file reader.
6cb0: 20 20 28 6c 65 74 2a 20 28 28 74 65 73 74 2d 6e (let* ((test-n
6cc0: 61 6d 65 20 20 20 20 28 74 65 73 74 73 3a 74 65 ame (tests:te
6cd0: 73 74 71 75 65 75 65 2d 67 65 74 2d 74 65 73 74 stqueue-get-test
6ce0: 6e 61 6d 65 20 20 20 74 65 73 74 2d 72 65 63 6f name test-reco
6cf0: 72 64 29 29 0a 09 20 28 74 65 73 74 2d 77 61 69 rd)).. (test-wai
6d00: 74 6f 6e 73 20 28 74 65 73 74 73 3a 74 65 73 74 tons (tests:test
6d10: 71 75 65 75 65 2d 67 65 74 2d 77 61 69 74 6f 6e queue-get-waiton
6d20: 73 20 20 20 20 74 65 73 74 2d 72 65 63 6f 72 64 s test-record
6d30: 29 29 0a 09 20 28 74 65 73 74 2d 63 6f 6e 66 20 )).. (test-conf
6d40: 20 20 20 28 74 65 73 74 73 3a 74 65 73 74 71 75 (tests:testqu
6d50: 65 75 65 2d 67 65 74 2d 74 65 73 74 63 6f 6e 66 eue-get-testconf
6d60: 69 67 20 74 65 73 74 2d 72 65 63 6f 72 64 29 29 ig test-record))
6d70: 0a 09 20 28 69 74 65 6d 64 61 74 20 20 20 20 20 .. (itemdat
6d80: 20 28 74 65 73 74 73 3a 74 65 73 74 71 75 65 75 (tests:testqueu
6d90: 65 2d 67 65 74 2d 69 74 65 6d 64 61 74 20 20 20 e-get-itemdat
6da0: 20 74 65 73 74 2d 72 65 63 6f 72 64 29 29 0a 09 test-record))..
6db0: 20 28 74 65 73 74 2d 70 61 74 68 20 20 20 20 28 (test-path (
6dc0: 63 6f 6e 63 20 2a 74 6f 70 70 61 74 68 2a 20 22 conc *toppath* "
6dd0: 2f 74 65 73 74 73 2f 22 20 74 65 73 74 2d 6e 61 /tests/" test-na
6de0: 6d 65 29 29 20 3b 3b 20 63 6f 75 6c 64 20 75 73 me)) ;; could us
6df0: 65 20 74 65 73 74 73 3a 67 65 74 2d 74 65 73 74 e tests:get-test
6e00: 63 6f 6e 66 69 67 20 68 65 72 65 20 2e 2e 2e 0a config here ....
6e10: 09 20 28 66 6f 72 63 65 20 20 20 20 20 20 20 20 . (force
6e20: 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f (hash-table-ref/
6e30: 64 65 66 61 75 6c 74 20 66 6c 61 67 73 20 22 2d default flags "-
6e40: 66 6f 72 63 65 22 20 23 66 29 29 0a 09 20 28 72 force" #f)).. (r
6e50: 65 72 75 6e 20 20 20 20 20 20 20 20 28 68 61 73 erun (has
6e60: 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 h-table-ref/defa
6e70: 75 6c 74 20 66 6c 61 67 73 20 22 2d 72 65 72 75 ult flags "-reru
6e80: 6e 22 20 23 66 29 29 0a 09 20 28 6b 65 65 70 67 n" #f)).. (keepg
6e90: 6f 69 6e 67 20 20 20 20 28 68 61 73 68 2d 74 61 oing (hash-ta
6ea0: 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 ble-ref/default
6eb0: 66 6c 61 67 73 20 22 2d 6b 65 65 70 67 6f 69 6e flags "-keepgoin
6ec0: 67 22 20 23 66 29 29 0a 09 20 28 69 74 65 6d 2d g" #f)).. (item-
6ed0: 70 61 74 68 20 20 20 20 20 22 22 29 0a 09 20 28 path "").. (
6ee0: 64 62 20 20 20 20 20 20 20 20 20 20 20 23 66 29 db #f)
6ef0: 29 0a 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 ). (debug:pri
6f00: 6e 74 20 34 0a 09 09 20 22 74 65 73 74 2d 63 6f nt 4... "test-co
6f10: 6e 66 69 67 3a 20 22 20 28 68 61 73 68 2d 74 61 nfig: " (hash-ta
6f20: 62 6c 65 2d 3e 61 6c 69 73 74 20 74 65 73 74 2d ble->alist test-
6f30: 63 6f 6e 66 29 0a 09 09 20 22 5c 6e 20 20 20 69 conf)... "\n i
6f40: 74 65 6d 64 61 74 3a 20 22 20 69 74 65 6d 64 61 temdat: " itemda
6f50: 74 0a 09 09 20 29 0a 20 20 20 20 3b 3b 20 73 65 t... ). ;; se
6f60: 74 74 69 6e 67 20 69 74 65 6d 64 61 74 20 74 6f tting itemdat to
6f70: 20 61 20 6c 69 73 74 20 69 66 20 69 74 20 69 73 a list if it is
6f80: 20 23 66 0a 20 20 20 20 28 69 66 20 28 6e 6f 74 #f. (if (not
6f90: 20 69 74 65 6d 64 61 74 29 28 73 65 74 21 20 69 itemdat)(set! i
6fa0: 74 65 6d 64 61 74 20 27 28 29 29 29 0a 20 20 20 temdat '())).
6fb0: 20 28 73 65 74 21 20 69 74 65 6d 2d 70 61 74 68 (set! item-path
6fc0: 20 28 69 74 65 6d 2d 6c 69 73 74 2d 3e 70 61 74 (item-list->pat
6fd0: 68 20 69 74 65 6d 64 61 74 29 29 0a 20 20 20 20 h itemdat)).
6fe0: 28 64 65 62 75 67 3a 70 72 69 6e 74 20 32 20 22 (debug:print 2 "
6ff0: 41 74 74 65 6d 70 74 69 6e 67 20 74 6f 20 6c 61 Attempting to la
7000: 75 6e 63 68 20 74 65 73 74 20 22 20 74 65 73 74 unch test " test
7010: 2d 6e 61 6d 65 20 28 69 66 20 28 65 71 75 61 6c -name (if (equal
7020: 3f 20 69 74 65 6d 2d 70 61 74 68 20 22 2f 22 29 ? item-path "/")
7030: 20 22 2f 22 20 69 74 65 6d 2d 70 61 74 68 29 29 "/" item-path))
7040: 0a 20 20 20 20 28 73 65 74 65 6e 76 20 22 4d 54 . (setenv "MT
7050: 5f 54 45 53 54 5f 4e 41 4d 45 22 20 74 65 73 74 _TEST_NAME" test
7060: 2d 6e 61 6d 65 29 20 3b 3b 20 0a 20 20 20 20 28 -name) ;; . (
7070: 73 65 74 65 6e 76 20 22 4d 54 5f 52 55 4e 4e 41 setenv "MT_RUNNA
7080: 4d 45 22 20 20 20 72 75 6e 6e 61 6d 65 29 0a 20 ME" runname).
7090: 20 20 20 28 73 65 74 2d 6d 65 67 61 74 65 73 74 (set-megatest
70a0: 2d 65 6e 76 2d 76 61 72 73 20 72 75 6e 2d 69 64 -env-vars run-id
70b0: 29 20 3b 3b 20 74 68 65 73 65 20 6d 61 79 20 62 ) ;; these may b
70c0: 65 20 6e 65 65 64 65 64 20 62 79 20 74 68 65 20 e needed by the
70d0: 6c 61 75 6e 63 68 69 6e 67 20 70 72 6f 63 65 73 launching proces
70e0: 73 0a 20 20 20 20 28 63 68 61 6e 67 65 2d 64 69 s. (change-di
70f0: 72 65 63 74 6f 72 79 20 2a 74 6f 70 70 61 74 68 rectory *toppath
7100: 2a 29 0a 0a 20 20 20 20 3b 3b 20 48 65 72 65 20 *).. ;; Here
7110: 69 73 20 77 68 65 72 65 20 74 68 65 20 74 65 73 is where the tes
7120: 74 5f 6d 65 74 61 20 74 61 62 6c 65 20 69 73 20 t_meta table is
7130: 62 65 73 74 20 75 70 64 61 74 65 64 0a 20 20 20 best updated.
7140: 20 3b 3b 20 59 65 73 2c 20 61 6e 6f 74 68 65 72 ;; Yes, another
7150: 20 75 73 65 20 6f 66 20 61 20 67 6c 6f 62 61 6c use of a global
7160: 20 66 6f 72 20 63 61 63 68 69 6e 67 2e 20 4e 65 for caching. Ne
7170: 65 64 20 61 20 62 65 74 74 65 72 20 77 61 79 3f ed a better way?
7180: 0a 20 20 20 20 28 69 66 20 28 6e 6f 74 20 28 68 . (if (not (h
7190: 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 ash-table-ref/de
71a0: 66 61 75 6c 74 20 2a 74 65 73 74 2d 6d 65 74 61 fault *test-meta
71b0: 2d 75 70 64 61 74 65 64 2a 20 74 65 73 74 2d 6e -updated* test-n
71c0: 61 6d 65 20 23 66 29 29 0a 20 20 20 20 20 20 20 ame #f)).
71d0: 20 28 62 65 67 69 6e 0a 09 20 20 20 28 68 61 73 (begin.. (has
71e0: 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 2a 74 65 h-table-set! *te
71f0: 73 74 2d 6d 65 74 61 2d 75 70 64 61 74 65 64 2a st-meta-updated*
7200: 20 74 65 73 74 2d 6e 61 6d 65 20 23 74 29 0a 20 test-name #t).
7210: 20 20 20 20 20 20 20 20 20 20 28 6f 70 65 6e 2d (open-
7220: 72 75 6e 2d 63 6c 6f 73 65 20 72 75 6e 73 3a 75 run-close runs:u
7230: 70 64 61 74 65 2d 74 65 73 74 5f 6d 65 74 61 20 pdate-test_meta
7240: 64 62 20 74 65 73 74 2d 6e 61 6d 65 20 74 65 73 db test-name tes
7250: 74 2d 63 6f 6e 66 29 29 29 0a 20 20 20 20 0a 20 t-conf))). .
7260: 20 20 20 3b 3b 20 28 6c 61 6d 62 64 61 20 28 69 ;; (lambda (i
7270: 74 65 6d 64 61 74 29 20 3b 3b 3b 20 28 28 72 69 temdat) ;;; ((ri
7280: 70 65 6e 65 73 73 20 22 6f 76 65 72 72 69 70 65 peness "overripe
7290: 22 29 20 28 74 65 6d 70 65 72 61 74 75 72 65 20 ") (temperature
72a0: 22 63 6f 6f 6c 22 29 20 28 73 65 61 73 6f 6e 20 "cool") (season
72b0: 22 73 75 6d 6d 65 72 22 29 29 0a 20 20 20 20 28 "summer")). (
72c0: 6c 65 74 2a 20 28 28 6e 65 77 2d 74 65 73 74 2d let* ((new-test-
72d0: 70 61 74 68 20 28 73 74 72 69 6e 67 2d 69 6e 74 path (string-int
72e0: 65 72 73 70 65 72 73 65 20 28 63 6f 6e 73 20 74 ersperse (cons t
72f0: 65 73 74 2d 70 61 74 68 20 28 6d 61 70 20 63 61 est-path (map ca
7300: 64 72 20 69 74 65 6d 64 61 74 29 29 20 22 2f 22 dr itemdat)) "/"
7310: 29 29 0a 09 20 20 20 28 6e 65 77 2d 74 65 73 74 )).. (new-test
7320: 2d 6e 61 6d 65 20 28 69 66 20 28 65 71 75 61 6c -name (if (equal
7330: 3f 20 69 74 65 6d 2d 70 61 74 68 20 22 22 29 20 ? item-path "")
7340: 74 65 73 74 2d 6e 61 6d 65 20 28 63 6f 6e 63 20 test-name (conc
7350: 74 65 73 74 2d 6e 61 6d 65 20 22 2f 22 20 69 74 test-name "/" it
7360: 65 6d 2d 70 61 74 68 29 29 29 20 3b 3b 20 6a 75 em-path))) ;; ju
7370: 73 74 20 6e 65 65 64 20 69 74 20 74 6f 20 62 65 st need it to be
7380: 20 75 6e 69 71 75 65 0a 09 20 20 20 28 74 65 73 unique.. (tes
7390: 74 2d 69 64 20 20 20 20 20 20 20 28 63 64 62 3a t-id (cdb:
73a0: 72 65 6d 6f 74 65 2d 72 75 6e 20 64 62 3a 67 65 remote-run db:ge
73b0: 74 2d 74 65 73 74 2d 69 64 20 23 66 20 20 72 75 t-test-id #f ru
73c0: 6e 2d 69 64 20 74 65 73 74 2d 6e 61 6d 65 20 69 n-id test-name i
73d0: 74 65 6d 2d 70 61 74 68 29 29 0a 09 20 20 20 28 tem-path)).. (
73e0: 74 65 73 74 64 61 74 20 20 20 20 20 20 20 28 63 testdat (c
73f0: 64 62 3a 67 65 74 2d 74 65 73 74 2d 69 6e 66 6f db:get-test-info
7400: 2d 62 79 2d 69 64 20 2a 72 75 6e 72 65 6d 6f 74 -by-id *runremot
7410: 65 2a 20 74 65 73 74 2d 69 64 29 29 29 0a 20 20 e* test-id))).
7420: 20 20 20 20 28 69 66 20 28 6e 6f 74 20 74 65 73 (if (not tes
7430: 74 64 61 74 29 0a 09 20 20 28 62 65 67 69 6e 0a tdat).. (begin.
7440: 09 20 20 20 20 3b 3b 20 65 6e 73 75 72 65 20 74 . ;; ensure t
7450: 68 61 74 20 74 68 65 20 70 61 74 68 20 65 78 69 hat the path exi
7460: 73 74 73 20 62 65 66 6f 72 65 20 72 65 67 69 73 sts before regis
7470: 74 65 72 69 6e 67 20 74 68 65 20 74 65 73 74 0a tering the test.
7480: 09 20 20 20 20 3b 3b 20 4e 4f 50 45 3a 20 43 61 . ;; NOPE: Ca
7490: 6e 6e 6f 74 21 20 44 6f 6e 27 74 20 6b 6e 6f 77 nnot! Don't know
74a0: 20 79 65 74 20 77 68 69 63 68 20 64 69 73 6b 20 yet which disk
74b0: 61 72 65 61 20 77 69 6c 6c 20 62 65 20 61 73 73 area will be ass
74c0: 69 67 6e 65 64 2e 2e 2e 2e 0a 09 20 20 20 20 3b igned...... ;
74d0: 3b 20 28 73 79 73 74 65 6d 20 28 63 6f 6e 63 20 ; (system (conc
74e0: 22 6d 6b 64 69 72 20 2d 70 20 22 20 6e 65 77 2d "mkdir -p " new-
74f0: 74 65 73 74 2d 70 61 74 68 29 29 0a 09 20 20 20 test-path))..
7500: 20 3b 3b 0a 09 20 20 20 20 3b 3b 20 28 6f 70 65 ;;.. ;; (ope
7510: 6e 2d 72 75 6e 2d 63 6c 6f 73 65 20 74 65 73 74 n-run-close test
7520: 73 3a 72 65 67 69 73 74 65 72 2d 74 65 73 74 20 s:register-test
7530: 64 62 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 6e db run-id test-n
7540: 61 6d 65 20 69 74 65 6d 2d 70 61 74 68 29 0a 09 ame item-path)..
7550: 20 20 20 20 3b 3b 0a 09 20 20 20 20 3b 3b 20 4e ;;.. ;; N
7560: 42 2f 2f 20 66 6f 72 20 74 68 65 20 61 62 6f 76 B// for the abov
7570: 65 20 6c 69 6e 65 2e 20 49 20 77 61 6e 74 20 74 e line. I want t
7580: 68 65 20 74 65 73 74 20 74 6f 20 62 65 20 72 65 he test to be re
7590: 67 69 73 74 65 72 65 64 20 6c 6f 6e 67 20 62 65 gistered long be
75a0: 66 6f 72 65 20 74 68 69 73 20 72 6f 75 74 69 6e fore this routin
75b0: 65 20 67 65 74 73 20 63 61 6c 6c 65 64 21 0a 09 e gets called!..
75c0: 20 20 20 20 3b 3b 0a 09 20 20 20 20 28 73 65 74 ;;.. (set
75d0: 21 20 74 65 73 74 2d 69 64 20 28 6f 70 65 6e 2d ! test-id (open-
75e0: 72 75 6e 2d 63 6c 6f 73 65 20 64 62 3a 67 65 74 run-close db:get
75f0: 2d 74 65 73 74 2d 69 64 20 64 62 20 72 75 6e 2d -test-id db run-
7600: 69 64 20 74 65 73 74 2d 6e 61 6d 65 20 69 74 65 id test-name ite
7610: 6d 2d 70 61 74 68 29 29 0a 09 20 20 20 20 28 69 m-path)).. (i
7620: 66 20 28 6e 6f 74 20 74 65 73 74 2d 69 64 29 0a f (not test-id).
7630: 09 09 28 62 65 67 69 6e 0a 09 09 20 20 28 64 65 ..(begin... (de
7640: 62 75 67 3a 70 72 69 6e 74 20 32 20 22 57 41 52 bug:print 2 "WAR
7650: 4e 3a 20 54 65 73 74 20 6e 6f 74 20 70 72 65 2d N: Test not pre-
7660: 63 72 65 61 74 65 64 3f 20 74 65 73 74 2d 6e 61 created? test-na
7670: 6d 65 3d 22 20 74 65 73 74 2d 6e 61 6d 65 20 22 me=" test-name "
7680: 2c 20 69 74 65 6d 2d 70 61 74 68 3d 22 20 69 74 , item-path=" it
7690: 65 6d 2d 70 61 74 68 20 22 2c 20 72 75 6e 2d 69 em-path ", run-i
76a0: 64 3d 22 20 72 75 6e 2d 69 64 29 0a 09 09 20 20 d=" run-id)...
76b0: 28 63 64 62 3a 74 65 73 74 73 2d 72 65 67 69 73 (cdb:tests-regis
76c0: 74 65 72 2d 74 65 73 74 20 2a 72 75 6e 72 65 6d ter-test *runrem
76d0: 6f 74 65 2a 20 72 75 6e 2d 69 64 20 74 65 73 74 ote* run-id test
76e0: 2d 6e 61 6d 65 20 69 74 65 6d 2d 70 61 74 68 29 -name item-path)
76f0: 0a 09 09 20 20 28 73 65 74 21 20 74 65 73 74 2d ... (set! test-
7700: 69 64 20 28 6f 70 65 6e 2d 72 75 6e 2d 63 6c 6f id (open-run-clo
7710: 73 65 20 64 62 3a 67 65 74 2d 74 65 73 74 2d 69 se db:get-test-i
7720: 64 20 64 62 20 72 75 6e 2d 69 64 20 74 65 73 74 d db run-id test
7730: 2d 6e 61 6d 65 20 69 74 65 6d 2d 70 61 74 68 29 -name item-path)
7740: 29 29 29 0a 09 20 20 20 20 28 64 65 62 75 67 3a ))).. (debug:
7750: 70 72 69 6e 74 2d 69 6e 66 6f 20 34 20 22 74 65 print-info 4 "te
7760: 73 74 2d 69 64 3d 22 20 74 65 73 74 2d 69 64 20 st-id=" test-id
7770: 22 2c 20 72 75 6e 2d 69 64 3d 22 20 72 75 6e 2d ", run-id=" run-
7780: 69 64 20 22 2c 20 74 65 73 74 2d 6e 61 6d 65 3d id ", test-name=
7790: 22 20 74 65 73 74 2d 6e 61 6d 65 20 22 2c 20 69 " test-name ", i
77a0: 74 65 6d 2d 70 61 74 68 3d 5c 22 22 20 69 74 65 tem-path=\"" ite
77b0: 6d 2d 70 61 74 68 20 22 5c 22 22 29 0a 09 20 20 m-path "\"")..
77c0: 20 20 28 73 65 74 21 20 74 65 73 74 64 61 74 20 (set! testdat
77d0: 28 63 64 62 3a 67 65 74 2d 74 65 73 74 2d 69 6e (cdb:get-test-in
77e0: 66 6f 2d 62 79 2d 69 64 20 2a 72 75 6e 72 65 6d fo-by-id *runrem
77f0: 6f 74 65 2a 20 74 65 73 74 2d 69 64 29 29 29 29 ote* test-id))))
7800: 0a 20 20 20 20 20 20 28 73 65 74 21 20 74 65 73 . (set! tes
7810: 74 2d 69 64 20 28 64 62 3a 74 65 73 74 2d 67 65 t-id (db:test-ge
7820: 74 2d 69 64 20 74 65 73 74 64 61 74 29 29 0a 20 t-id testdat)).
7830: 20 20 20 20 20 28 63 68 61 6e 67 65 2d 64 69 72 (change-dir
7840: 65 63 74 6f 72 79 20 74 65 73 74 2d 70 61 74 68 ectory test-path
7850: 29 0a 20 20 20 20 20 20 28 63 61 73 65 20 28 69 ). (case (i
7860: 66 20 66 6f 72 63 65 20 3b 3b 20 28 61 72 67 73 f force ;; (args
7870: 3a 67 65 74 2d 61 72 67 20 22 2d 66 6f 72 63 65 :get-arg "-force
7880: 22 29 0a 09 09 27 4e 4f 54 5f 53 54 41 52 54 45 ")...'NOT_STARTE
7890: 44 0a 09 09 28 69 66 20 74 65 73 74 64 61 74 0a D...(if testdat.
78a0: 09 09 20 20 20 20 28 73 74 72 69 6e 67 2d 3e 73 .. (string->s
78b0: 79 6d 62 6f 6c 20 28 74 65 73 74 3a 67 65 74 2d ymbol (test:get-
78c0: 73 74 61 74 65 20 74 65 73 74 64 61 74 29 29 0a state testdat)).
78d0: 09 09 20 20 20 20 27 66 61 69 6c 65 64 2d 74 6f .. 'failed-to
78e0: 2d 69 6e 73 65 72 74 29 29 0a 09 28 28 66 61 69 -insert))..((fai
78f0: 6c 65 64 2d 74 6f 2d 69 6e 73 65 72 74 29 0a 09 led-to-insert)..
7900: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 (debug:print 0
7910: 22 45 52 52 4f 52 3a 20 46 61 69 6c 65 64 20 74 "ERROR: Failed t
7920: 6f 20 69 6e 73 65 72 74 20 74 68 65 20 72 65 63 o insert the rec
7930: 6f 72 64 20 69 6e 74 6f 20 74 68 65 20 64 62 22 ord into the db"
7940: 29 29 0a 09 28 28 4e 4f 54 5f 53 54 41 52 54 45 ))..((NOT_STARTE
7950: 44 20 43 4f 4d 50 4c 45 54 45 44 20 44 45 4c 45 D COMPLETED DELE
7960: 54 45 44 29 0a 09 20 28 6c 65 74 20 28 28 72 75 TED).. (let ((ru
7970: 6e 66 6c 61 67 20 23 66 29 29 0a 09 20 20 20 28 nflag #f)).. (
7980: 63 6f 6e 64 0a 09 20 20 20 20 3b 3b 20 2d 66 6f cond.. ;; -fo
7990: 72 63 65 2c 20 72 75 6e 20 6e 6f 20 6d 61 74 74 rce, run no matt
79a0: 65 72 20 77 68 61 74 0a 09 20 20 20 20 28 66 6f er what.. (fo
79b0: 72 63 65 20 28 73 65 74 21 20 72 75 6e 66 6c 61 rce (set! runfla
79c0: 67 20 23 74 29 29 0a 09 20 20 20 20 3b 3b 20 4e g #t)).. ;; N
79d0: 4f 54 5f 53 54 41 52 54 45 44 2c 20 72 75 6e 20 OT_STARTED, run
79e0: 6e 6f 20 6d 61 74 74 65 72 20 77 68 61 74 0a 09 no matter what..
79f0: 20 20 20 20 28 28 6d 65 6d 62 65 72 20 28 74 65 ((member (te
7a00: 73 74 3a 67 65 74 2d 73 74 61 74 65 20 74 65 73 st:get-state tes
7a10: 74 64 61 74 29 20 27 28 22 44 45 4c 45 54 45 44 tdat) '("DELETED
7a20: 22 20 22 4e 4f 54 5f 53 54 41 52 54 45 44 22 29 " "NOT_STARTED")
7a30: 29 28 73 65 74 21 20 72 75 6e 66 6c 61 67 20 23 )(set! runflag #
7a40: 74 29 29 0a 09 20 20 20 20 3b 3b 20 6e 6f 74 20 t)).. ;; not
7a50: 2d 72 65 72 75 6e 20 61 6e 64 20 50 41 53 53 2c -rerun and PASS,
7a60: 20 57 41 52 4e 20 6f 72 20 43 48 45 43 4b 2c 20 WARN or CHECK,
7a70: 64 6f 20 6e 6f 20 72 75 6e 0a 09 20 20 20 20 28 do no run.. (
7a80: 28 61 6e 64 20 28 6f 72 20 28 6e 6f 74 20 72 65 (and (or (not re
7a90: 72 75 6e 29 0a 09 09 20 20 20 20 20 20 6b 65 65 run)... kee
7aa0: 70 67 6f 69 6e 67 29 0a 09 09 20 20 3b 3b 20 52 pgoing)... ;; R
7ab0: 65 71 75 69 72 65 20 74 6f 20 66 6f 72 63 65 20 equire to force
7ac0: 72 65 2d 72 75 6e 20 66 6f 72 20 43 4f 4d 50 4c re-run for COMPL
7ad0: 45 54 45 44 20 6f 72 20 2a 61 6e 79 74 68 69 6e ETED or *anythin
7ae0: 67 2a 20 2b 20 50 41 53 53 2c 57 41 52 4e 20 6f g* + PASS,WARN o
7af0: 72 20 43 48 45 43 4b 0a 09 09 20 20 28 6f 72 20 r CHECK... (or
7b00: 28 6d 65 6d 62 65 72 20 28 74 65 73 74 3a 67 65 (member (test:ge
7b10: 74 2d 73 74 61 74 75 73 20 74 65 73 74 64 61 74 t-status testdat
7b20: 29 20 27 28 22 50 41 53 53 22 20 22 57 41 52 4e ) '("PASS" "WARN
7b30: 22 20 22 43 48 45 43 4b 22 20 22 53 4b 49 50 22 " "CHECK" "SKIP"
7b40: 29 29 0a 09 09 20 20 20 20 20 20 28 6d 65 6d 62 ))... (memb
7b50: 65 72 20 28 74 65 73 74 3a 67 65 74 2d 73 74 61 er (test:get-sta
7b60: 74 65 20 20 74 65 73 74 64 61 74 29 20 27 28 22 te testdat) '("
7b70: 43 4f 4d 50 4c 45 54 45 44 22 29 29 29 29 20 0a COMPLETED")))) .
7b80: 09 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 . (debug:pri
7b90: 6e 74 2d 69 6e 66 6f 20 32 20 22 72 75 6e 6e 69 nt-info 2 "runni
7ba0: 6e 67 20 74 65 73 74 20 22 20 74 65 73 74 2d 6e ng test " test-n
7bb0: 61 6d 65 20 22 2f 22 20 69 74 65 6d 2d 70 61 74 ame "/" item-pat
7bc0: 68 20 22 20 73 75 70 70 72 65 73 73 65 64 20 61 h " suppressed a
7bd0: 73 20 69 74 20 69 73 20 22 20 28 74 65 73 74 3a s it is " (test:
7be0: 67 65 74 2d 73 74 61 74 65 20 74 65 73 74 64 61 get-state testda
7bf0: 74 29 20 22 20 61 6e 64 20 22 20 28 74 65 73 74 t) " and " (test
7c00: 3a 67 65 74 2d 73 74 61 74 75 73 20 74 65 73 74 :get-status test
7c10: 64 61 74 29 29 0a 09 20 20 20 20 20 28 73 65 74 dat)).. (set
7c20: 21 20 72 75 6e 66 6c 61 67 20 23 66 29 29 0a 09 ! runflag #f))..
7c30: 20 20 20 20 3b 3b 20 2d 72 65 72 75 6e 20 61 6e ;; -rerun an
7c40: 64 20 73 74 61 74 75 73 20 69 73 20 6f 6e 65 20 d status is one
7c50: 6f 66 20 74 68 65 20 73 70 65 63 69 66 65 64 2c of the specifed,
7c60: 20 72 75 6e 20 69 74 0a 09 20 20 20 20 28 28 61 run it.. ((a
7c70: 6e 64 20 72 65 72 75 6e 0a 09 09 20 20 28 6c 65 nd rerun... (le
7c80: 74 2a 20 28 28 72 65 72 75 6e 6c 73 74 20 20 20 t* ((rerunlst
7c90: 28 73 74 72 69 6e 67 2d 73 70 6c 69 74 20 72 65 (string-split re
7ca0: 72 75 6e 20 22 2c 22 29 29 0a 09 09 09 20 28 6d run ",")).... (m
7cb0: 75 73 74 2d 72 65 72 75 6e 20 28 6d 65 6d 62 65 ust-rerun (membe
7cc0: 72 20 28 74 65 73 74 3a 67 65 74 2d 73 74 61 74 r (test:get-stat
7cd0: 75 73 20 74 65 73 74 64 61 74 29 20 72 65 72 75 us testdat) reru
7ce0: 6e 6c 73 74 29 29 29 0a 09 09 20 20 20 20 28 64 nlst)))... (d
7cf0: 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 ebug:print-info
7d00: 33 20 22 2d 72 65 72 75 6e 20 6c 69 73 74 3a 20 3 "-rerun list:
7d10: 22 20 72 65 72 75 6e 20 22 2c 20 74 65 73 74 2d " rerun ", test-
7d20: 73 74 61 74 75 73 3a 20 22 20 28 74 65 73 74 3a status: " (test:
7d30: 67 65 74 2d 73 74 61 74 75 73 20 74 65 73 74 64 get-status testd
7d40: 61 74 29 22 2c 20 6d 75 73 74 2d 72 65 72 75 6e at)", must-rerun
7d50: 3a 20 22 20 6d 75 73 74 2d 72 65 72 75 6e 29 0a : " must-rerun).
7d60: 09 09 20 20 20 20 6d 75 73 74 2d 72 65 72 75 6e .. must-rerun
7d70: 29 29 0a 09 20 20 20 20 20 28 64 65 62 75 67 3a )).. (debug:
7d80: 70 72 69 6e 74 2d 69 6e 66 6f 20 32 20 22 52 65 print-info 2 "Re
7d90: 72 75 6e 20 66 6f 72 63 65 64 20 66 6f 72 20 74 run forced for t
7da0: 65 73 74 20 22 20 74 65 73 74 2d 6e 61 6d 65 20 est " test-name
7db0: 22 2f 22 20 69 74 65 6d 2d 70 61 74 68 29 0a 09 "/" item-path)..
7dc0: 20 20 20 20 20 28 73 65 74 21 20 72 75 6e 66 6c (set! runfl
7dd0: 61 67 20 23 74 29 29 0a 09 20 20 20 20 3b 3b 20 ag #t)).. ;;
7de0: 2d 6b 65 65 70 67 6f 69 6e 67 2c 20 64 6f 20 6e -keepgoing, do n
7df0: 6f 74 20 72 65 72 75 6e 20 46 41 49 4c 0a 09 20 ot rerun FAIL..
7e00: 20 20 20 28 28 61 6e 64 20 6b 65 65 70 67 6f 69 ((and keepgoi
7e10: 6e 67 0a 09 09 20 20 28 6d 65 6d 62 65 72 20 28 ng... (member (
7e20: 74 65 73 74 3a 67 65 74 2d 73 74 61 74 75 73 20 test:get-status
7e30: 74 65 73 74 64 61 74 29 20 27 28 22 46 41 49 4c testdat) '("FAIL
7e40: 22 29 29 29 0a 09 20 20 20 20 20 28 73 65 74 21 "))).. (set!
7e50: 20 72 75 6e 66 6c 61 67 20 23 66 29 29 0a 09 20 runflag #f))..
7e60: 20 20 20 28 28 61 6e 64 20 28 6e 6f 74 20 72 65 ((and (not re
7e70: 72 75 6e 29 0a 09 09 20 20 28 6d 65 6d 62 65 72 run)... (member
7e80: 20 28 74 65 73 74 3a 67 65 74 2d 73 74 61 74 75 (test:get-statu
7e90: 73 20 74 65 73 74 64 61 74 29 20 27 28 22 46 41 s testdat) '("FA
7ea0: 49 4c 22 20 22 6e 2f 61 22 29 29 29 0a 09 20 20 IL" "n/a")))..
7eb0: 20 20 20 28 73 65 74 21 20 72 75 6e 66 6c 61 67 (set! runflag
7ec0: 20 23 74 29 29 0a 09 20 20 20 20 28 65 6c 73 65 #t)).. (else
7ed0: 20 28 73 65 74 21 20 72 75 6e 66 6c 61 67 20 23 (set! runflag #
7ee0: 66 29 29 29 0a 09 20 20 20 28 64 65 62 75 67 3a f))).. (debug:
7ef0: 70 72 69 6e 74 20 36 20 22 52 55 4e 4e 49 4e 47 print 6 "RUNNING
7f00: 20 3d 3e 20 72 75 6e 66 6c 61 67 3a 20 22 20 72 => runflag: " r
7f10: 75 6e 66 6c 61 67 20 22 20 53 54 41 54 45 3a 20 unflag " STATE:
7f20: 22 20 28 74 65 73 74 3a 67 65 74 2d 73 74 61 74 " (test:get-stat
7f30: 65 20 74 65 73 74 64 61 74 29 20 22 20 53 54 41 e testdat) " STA
7f40: 54 55 53 3a 20 22 20 28 74 65 73 74 3a 67 65 74 TUS: " (test:get
7f50: 2d 73 74 61 74 75 73 20 74 65 73 74 64 61 74 29 -status testdat)
7f60: 29 0a 09 20 20 20 28 69 66 20 28 6e 6f 74 20 72 ).. (if (not r
7f70: 75 6e 66 6c 61 67 29 0a 09 20 20 20 20 20 20 20 unflag)..
7f80: 28 69 66 20 28 6e 6f 74 20 70 61 72 65 6e 74 2d (if (not parent-
7f90: 74 65 73 74 29 0a 09 09 20 20 20 28 64 65 62 75 test)... (debu
7fa0: 67 3a 70 72 69 6e 74 20 31 20 22 4e 4f 54 45 3a g:print 1 "NOTE:
7fb0: 20 4e 6f 74 20 73 74 61 72 74 69 6e 67 20 74 65 Not starting te
7fc0: 73 74 20 22 20 6e 65 77 2d 74 65 73 74 2d 6e 61 st " new-test-na
7fd0: 6d 65 20 22 20 61 73 20 69 74 20 69 73 20 73 74 me " as it is st
7fe0: 61 74 65 20 5c 22 22 20 28 74 65 73 74 3a 67 65 ate \"" (test:ge
7ff0: 74 2d 73 74 61 74 65 20 74 65 73 74 64 61 74 29 t-state testdat)
8000: 20 0a 09 09 09 09 22 5c 22 20 61 6e 64 20 73 74 ....."\" and st
8010: 61 74 75 73 20 5c 22 22 20 28 74 65 73 74 3a 67 atus \"" (test:g
8020: 65 74 2d 73 74 61 74 75 73 20 74 65 73 74 64 61 et-status testda
8030: 74 29 20 22 5c 22 2c 20 75 73 65 20 2d 72 65 72 t) "\", use -rer
8040: 75 6e 20 5c 22 22 20 28 74 65 73 74 3a 67 65 74 un \"" (test:get
8050: 2d 73 74 61 74 75 73 20 74 65 73 74 64 61 74 29 -status testdat)
8060: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
8070: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8080: 20 22 5c 22 20 6f 72 20 2d 66 6f 72 63 65 20 74 "\" or -force t
8090: 6f 20 6f 76 65 72 72 69 64 65 22 29 29 0a 09 20 o override"))..
80a0: 20 20 20 20 20 20 3b 3b 20 4e 4f 54 45 3a 20 4e ;; NOTE: N
80b0: 6f 20 6c 6f 6e 67 65 72 20 62 65 20 63 68 65 63 o longer be chec
80c0: 6b 69 6e 67 20 70 72 65 72 65 71 75 69 73 69 74 king prerequisit
80d0: 65 73 20 68 65 72 65 21 20 57 69 6c 6c 20 6e 65 es here! Will ne
80e0: 76 65 72 20 67 65 74 20 68 65 72 65 20 75 6e 6c ver get here unl
80f0: 65 73 73 20 70 72 65 72 65 71 73 20 61 72 65 0a ess prereqs are.
8100: 09 20 20 20 20 20 20 20 3b 3b 20 20 20 20 20 20 . ;;
8110: 20 61 6c 72 65 61 64 79 20 6d 65 74 2e 0a 09 20 already met...
8120: 20 20 20 20 20 20 3b 3b 20 54 68 69 73 20 77 6f ;; This wo
8130: 75 6c 64 20 62 65 20 61 20 67 72 65 61 74 20 70 uld be a great p
8140: 6c 61 63 65 20 74 6f 20 64 6f 20 74 68 65 20 70 lace to do the p
8150: 72 6f 63 65 73 73 2d 66 6f 72 6b 0a 09 20 20 20 rocess-fork..
8160: 20 20 20 20 28 69 66 20 28 6e 6f 74 20 28 6c 61 (if (not (la
8170: 75 6e 63 68 2d 74 65 73 74 20 23 66 20 72 75 6e unch-test #f run
8180: 2d 69 64 20 72 75 6e 6e 61 6d 65 20 74 65 73 74 -id runname test
8190: 2d 63 6f 6e 66 20 6b 65 79 76 61 6c 6c 73 74 20 -conf keyvallst
81a0: 74 65 73 74 2d 6e 61 6d 65 20 74 65 73 74 2d 70 test-name test-p
81b0: 61 74 68 20 69 74 65 6d 64 61 74 20 66 6c 61 67 ath itemdat flag
81c0: 73 29 29 0a 09 09 20 20 20 28 62 65 67 69 6e 0a s))... (begin.
81d0: 09 09 20 20 20 20 20 28 70 72 69 6e 74 20 22 45 .. (print "E
81e0: 52 52 4f 52 3a 20 46 61 69 6c 65 64 20 74 6f 20 RROR: Failed to
81f0: 6c 61 75 6e 63 68 20 74 68 65 20 74 65 73 74 2e launch the test.
8200: 20 45 78 69 74 69 6e 67 20 61 73 20 73 6f 6f 6e Exiting as soon
8210: 20 61 73 20 70 6f 73 73 69 62 6c 65 22 29 0a 09 as possible")..
8220: 09 20 20 20 20 20 28 73 65 74 21 20 2a 67 6c 6f . (set! *glo
8230: 62 61 6c 65 78 69 74 73 74 61 74 75 73 2a 20 31 balexitstatus* 1
8240: 29 20 3b 3b 20 0a 09 09 20 20 20 20 20 28 70 72 ) ;; ... (pr
8250: 6f 63 65 73 73 2d 73 69 67 6e 61 6c 20 28 63 75 ocess-signal (cu
8260: 72 72 65 6e 74 2d 70 72 6f 63 65 73 73 2d 69 64 rrent-process-id
8270: 29 20 73 69 67 6e 61 6c 2f 6b 69 6c 6c 29 29 29 ) signal/kill)))
8280: 29 29 29 0a 09 28 28 4b 49 4c 4c 45 44 29 20 0a )))..((KILLED) .
8290: 09 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 31 . (debug:print 1
82a0: 20 22 4e 4f 54 45 3a 20 22 20 6e 65 77 2d 74 65 "NOTE: " new-te
82b0: 73 74 2d 6e 61 6d 65 20 22 20 69 73 20 61 6c 72 st-name " is alr
82c0: 65 61 64 79 20 72 75 6e 6e 69 6e 67 20 6f 72 20 eady running or
82d0: 77 61 73 20 65 78 70 6c 69 63 74 6c 79 20 6b 69 was explictly ki
82e0: 6c 6c 65 64 2c 20 75 73 65 20 2d 66 6f 72 63 65 lled, use -force
82f0: 20 74 6f 20 6c 61 75 6e 63 68 20 69 74 2e 22 29 to launch it.")
8300: 29 0a 09 28 28 4c 41 55 4e 43 48 45 44 20 52 45 )..((LAUNCHED RE
8310: 4d 4f 54 45 48 4f 53 54 53 54 41 52 54 20 52 55 MOTEHOSTSTART RU
8320: 4e 4e 49 4e 47 29 20 20 0a 09 20 28 69 66 20 28 NNING) .. (if (
8330: 3e 20 28 2d 20 28 63 75 72 72 65 6e 74 2d 73 65 > (- (current-se
8340: 63 6f 6e 64 73 29 28 2b 20 28 64 62 3a 74 65 73 conds)(+ (db:tes
8350: 74 2d 67 65 74 2d 65 76 65 6e 74 5f 74 69 6d 65 t-get-event_time
8360: 20 74 65 73 74 64 61 74 29 0a 09 09 09 09 20 20 testdat).....
8370: 20 20 20 20 20 28 64 62 3a 74 65 73 74 2d 67 65 (db:test-ge
8380: 74 2d 72 75 6e 5f 64 75 72 61 74 69 6f 6e 20 74 t-run_duration t
8390: 65 73 74 64 61 74 29 29 29 0a 09 09 36 30 30 29 estdat)))...600)
83a0: 20 3b 3b 20 69 2e 65 2e 20 6e 6f 20 75 70 64 61 ;; i.e. no upda
83b0: 74 65 20 66 6f 72 20 6d 6f 72 65 20 74 68 61 6e te for more than
83c0: 20 36 30 30 20 73 65 63 6f 6e 64 73 0a 09 20 20 600 seconds..
83d0: 20 20 20 28 62 65 67 69 6e 0a 09 20 20 20 20 20 (begin..
83e0: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 (debug:print 0
83f0: 20 22 57 41 52 4e 49 4e 47 3a 20 54 65 73 74 20 "WARNING: Test
8400: 22 20 74 65 73 74 2d 6e 61 6d 65 20 22 20 61 70 " test-name " ap
8410: 70 65 61 72 73 20 74 6f 20 62 65 20 64 65 61 64 pears to be dead
8420: 2e 20 46 6f 72 63 69 6e 67 20 69 74 20 74 6f 20 . Forcing it to
8430: 73 74 61 74 65 20 49 4e 43 4f 4d 50 4c 45 54 45 state INCOMPLETE
8440: 20 61 6e 64 20 73 74 61 74 75 73 20 53 54 55 43 and status STUC
8450: 4b 2f 44 45 41 44 22 29 0a 09 20 20 20 20 20 20 K/DEAD")..
8460: 20 28 74 65 73 74 73 3a 74 65 73 74 2d 73 65 74 (tests:test-set
8470: 2d 73 74 61 74 75 73 21 20 74 65 73 74 2d 69 64 -status! test-id
8480: 20 22 49 4e 43 4f 4d 50 4c 45 54 45 22 20 22 53 "INCOMPLETE" "S
8490: 54 55 43 4b 2f 44 45 41 44 22 20 22 54 65 73 74 TUCK/DEAD" "Test
84a0: 20 69 73 20 73 74 75 63 6b 20 6f 72 20 64 65 61 is stuck or dea
84b0: 64 22 20 23 66 29 29 0a 09 20 20 20 20 20 28 64 d" #f)).. (d
84c0: 65 62 75 67 3a 70 72 69 6e 74 20 32 20 22 4e 4f ebug:print 2 "NO
84d0: 54 45 3a 20 22 20 74 65 73 74 2d 6e 61 6d 65 20 TE: " test-name
84e0: 22 20 69 73 20 61 6c 72 65 61 64 79 20 72 75 6e " is already run
84f0: 6e 69 6e 67 22 29 29 29 0a 09 28 65 6c 73 65 20 ning")))..(else
8500: 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 (debug:pri
8510: 6e 74 20 30 20 22 45 52 52 4f 52 3a 20 46 61 69 nt 0 "ERROR: Fai
8520: 6c 65 64 20 74 6f 20 6c 61 75 6e 63 68 20 74 65 led to launch te
8530: 73 74 20 22 20 6e 65 77 2d 74 65 73 74 2d 6e 61 st " new-test-na
8540: 6d 65 20 22 2e 20 55 6e 72 65 63 6f 67 6e 69 73 me ". Unrecognis
8550: 65 64 20 73 74 61 74 65 20 22 20 28 74 65 73 74 ed state " (test
8560: 3a 67 65 74 2d 73 74 61 74 65 20 74 65 73 74 64 :get-state testd
8570: 61 74 29 29 29 29 29 29 29 0a 0a 3b 3b 3d 3d 3d at)))))))..;;===
8580: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8590: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
85a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
85b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
85c0: 3d 3d 3d 0a 3b 3b 20 45 4e 44 20 4f 46 20 4e 45 ===.;; END OF NE
85d0: 57 20 53 54 55 46 46 0a 3b 3b 3d 3d 3d 3d 3d 3d W STUFF.;;======
85e0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
85f0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8600: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8610: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8620: 0a 0a 28 64 65 66 69 6e 65 20 28 67 65 74 2d 64 ..(define (get-d
8630: 69 72 2d 75 70 2d 6e 20 64 69 72 20 2e 20 70 61 ir-up-n dir . pa
8640: 72 61 6d 73 29 20 0a 20 20 28 6c 65 74 20 28 28 rams) . (let ((
8650: 64 70 61 72 74 73 20 20 28 73 74 72 69 6e 67 2d dparts (string-
8660: 73 70 6c 69 74 20 64 69 72 20 22 2f 22 29 29 0a split dir "/")).
8670: 09 28 63 6f 75 6e 74 20 20 20 28 69 66 20 28 6e .(count (if (n
8680: 75 6c 6c 3f 20 70 61 72 61 6d 73 29 20 31 20 28 ull? params) 1 (
8690: 63 61 72 20 70 61 72 61 6d 73 29 29 29 29 0a 20 car params)))).
86a0: 20 20 20 28 63 6f 6e 63 20 22 2f 22 20 28 73 74 (conc "/" (st
86b0: 72 69 6e 67 2d 69 6e 74 65 72 73 70 65 72 73 65 ring-intersperse
86c0: 20 0a 09 20 20 20 20 20 20 20 28 74 61 6b 65 20 .. (take
86d0: 64 70 61 72 74 73 20 28 2d 20 28 6c 65 6e 67 74 dparts (- (lengt
86e0: 68 20 64 70 61 72 74 73 29 20 63 6f 75 6e 74 29 h dparts) count)
86f0: 29 0a 09 20 20 20 20 20 20 20 22 2f 22 29 29 29 ).. "/")))
8700: 29 0a 3b 3b 20 52 65 6d 6f 76 65 20 72 75 6e 73 ).;; Remove runs
8710: 0a 3b 3b 20 66 69 65 6c 64 73 20 61 72 65 20 70 .;; fields are p
8720: 61 73 73 69 6e 67 20 69 6e 20 74 68 72 6f 75 67 assing in throug
8730: 68 20 0a 3b 3b 20 61 63 74 69 6f 6e 3a 0a 3b 3b h .;; action:.;;
8740: 20 20 20 20 27 72 65 6d 6f 76 65 2d 72 75 6e 73 'remove-runs
8750: 0a 3b 3b 20 20 20 20 27 73 65 74 2d 73 74 61 74 .;; 'set-stat
8760: 65 2d 73 74 61 74 75 73 0a 3b 3b 0a 3b 3b 20 4e e-status.;;.;; N
8770: 42 2f 2f 20 73 68 6f 75 6c 64 20 70 61 73 73 20 B// should pass
8780: 69 6e 20 6b 65 79 73 3f 0a 3b 3b 0a 28 64 65 66 in keys?.;;.(def
8790: 69 6e 65 20 28 72 75 6e 73 3a 6f 70 65 72 61 74 ine (runs:operat
87a0: 65 2d 6f 6e 20 61 63 74 69 6f 6e 20 72 75 6e 6e e-on action runn
87b0: 61 6d 65 70 61 74 74 20 74 65 73 74 70 61 74 74 amepatt testpatt
87c0: 20 23 21 6b 65 79 20 28 73 74 61 74 65 20 23 66 #!key (state #f
87d0: 29 28 73 74 61 74 75 73 20 23 66 29 28 6e 65 77 )(status #f)(new
87e0: 2d 73 74 61 74 65 2d 73 74 61 74 75 73 20 23 66 -state-status #f
87f0: 29 29 0a 20 20 28 63 6f 6d 6d 6f 6e 3a 63 6c 65 )). (common:cle
8800: 61 72 2d 63 61 63 68 65 73 29 20 3b 3b 20 63 6c ar-caches) ;; cl
8810: 65 61 72 20 61 6c 6c 20 63 61 63 68 65 73 0a 20 ear all caches.
8820: 20 28 6c 65 74 2a 20 28 28 64 62 20 20 20 20 20 (let* ((db
8830: 20 20 20 20 20 20 23 66 29 0a 09 20 28 6b 65 79 #f).. (key
8840: 73 20 20 20 20 20 20 20 20 20 28 6f 70 65 6e 2d s (open-
8850: 72 75 6e 2d 63 6c 6f 73 65 20 64 62 3a 67 65 74 run-close db:get
8860: 2d 6b 65 79 73 20 64 62 29 29 0a 09 20 28 72 75 -keys db)).. (ru
8870: 6e 64 61 74 20 20 20 20 20 20 20 28 6f 70 65 6e ndat (open
8880: 2d 72 75 6e 2d 63 6c 6f 73 65 20 72 75 6e 73 3a -run-close runs:
8890: 67 65 74 2d 72 75 6e 73 2d 62 79 2d 70 61 74 74 get-runs-by-patt
88a0: 20 64 62 20 6b 65 79 73 20 72 75 6e 6e 61 6d 65 db keys runname
88b0: 70 61 74 74 29 29 0a 09 20 28 68 65 61 64 65 72 patt)).. (header
88c0: 20 20 20 20 20 20 20 28 76 65 63 74 6f 72 2d 72 (vector-r
88d0: 65 66 20 72 75 6e 64 61 74 20 30 29 29 0a 09 20 ef rundat 0))..
88e0: 28 72 75 6e 73 20 20 20 20 20 20 20 20 20 28 76 (runs (v
88f0: 65 63 74 6f 72 2d 72 65 66 20 72 75 6e 64 61 74 ector-ref rundat
8900: 20 31 29 29 0a 09 20 28 73 74 61 74 65 73 20 20 1)).. (states
8910: 20 20 20 20 20 28 69 66 20 73 74 61 74 65 20 20 (if state
8920: 28 73 74 72 69 6e 67 2d 73 70 6c 69 74 20 73 74 (string-split st
8930: 61 74 65 20 20 22 2c 22 29 20 27 28 29 29 29 0a ate ",") '())).
8940: 09 20 28 73 74 61 74 75 73 65 73 20 20 20 20 20 . (statuses
8950: 28 69 66 20 73 74 61 74 75 73 20 28 73 74 72 69 (if status (stri
8960: 6e 67 2d 73 70 6c 69 74 20 73 74 61 74 75 73 20 ng-split status
8970: 22 2c 22 29 20 27 28 29 29 29 0a 09 20 28 73 74 ",") '())).. (st
8980: 61 74 65 2d 73 74 61 74 75 73 20 28 69 66 20 28 ate-status (if (
8990: 73 74 72 69 6e 67 3f 20 6e 65 77 2d 73 74 61 74 string? new-stat
89a0: 65 2d 73 74 61 74 75 73 29 20 28 73 74 72 69 6e e-status) (strin
89b0: 67 2d 73 70 6c 69 74 20 6e 65 77 2d 73 74 61 74 g-split new-stat
89c0: 65 2d 73 74 61 74 75 73 20 22 2c 22 29 20 27 28 e-status ",") '(
89d0: 23 66 20 23 66 29 29 29 29 0a 20 20 20 20 28 64 #f #f)))). (d
89e0: 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 ebug:print-info
89f0: 34 20 22 72 75 6e 73 3a 6f 70 65 72 61 74 65 2d 4 "runs:operate-
8a00: 6f 6e 20 3d 3e 20 48 65 61 64 65 72 3a 20 22 20 on => Header: "
8a10: 68 65 61 64 65 72 20 22 20 61 63 74 69 6f 6e 3a header " action:
8a20: 20 22 20 61 63 74 69 6f 6e 20 22 20 6e 65 77 2d " action " new-
8a30: 73 74 61 74 65 2d 73 74 61 74 75 73 3a 20 22 20 state-status: "
8a40: 6e 65 77 2d 73 74 61 74 65 2d 73 74 61 74 75 73 new-state-status
8a50: 29 0a 20 20 20 20 28 69 66 20 28 3e 20 32 20 28 ). (if (> 2 (
8a60: 6c 65 6e 67 74 68 20 73 74 61 74 65 2d 73 74 61 length state-sta
8a70: 74 75 73 29 29 0a 09 28 62 65 67 69 6e 0a 09 20 tus))..(begin..
8a80: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 (debug:print 0
8a90: 22 45 52 52 4f 52 3a 20 74 68 65 20 70 61 72 61 "ERROR: the para
8aa0: 6d 65 74 65 72 20 74 6f 20 2d 73 65 74 2d 73 74 meter to -set-st
8ab0: 61 74 65 2d 73 74 61 74 75 73 20 69 73 20 61 20 ate-status is a
8ac0: 63 6f 6d 6d 61 20 64 65 6c 69 6d 69 74 65 64 20 comma delimited
8ad0: 73 74 72 69 6e 67 2e 20 45 2e 67 2e 20 43 4f 4d string. E.g. COM
8ae0: 50 4c 45 54 45 44 2c 46 41 49 4c 22 29 0a 09 20 PLETED,FAIL")..
8af0: 20 28 65 78 69 74 29 29 29 0a 20 20 20 20 28 66 (exit))). (f
8b00: 6f 72 2d 65 61 63 68 0a 20 20 20 20 20 28 6c 61 or-each. (la
8b10: 6d 62 64 61 20 28 72 75 6e 29 0a 20 20 20 20 20 mbda (run).
8b20: 20 20 28 6c 65 74 20 28 28 72 75 6e 6b 65 79 20 (let ((runkey
8b30: 28 73 74 72 69 6e 67 2d 69 6e 74 65 72 73 70 65 (string-interspe
8b40: 72 73 65 20 28 6d 61 70 20 28 6c 61 6d 62 64 61 rse (map (lambda
8b50: 20 28 6b 29 0a 09 09 09 09 09 09 28 64 62 3a 67 (k).......(db:g
8b60: 65 74 2d 76 61 6c 75 65 2d 62 79 2d 68 65 61 64 et-value-by-head
8b70: 65 72 20 72 75 6e 20 68 65 61 64 65 72 20 28 76 er run header (v
8b80: 65 63 74 6f 72 2d 72 65 66 20 6b 20 30 29 29 29 ector-ref k 0)))
8b90: 20 6b 65 79 73 29 20 22 2f 22 29 29 0a 09 20 20 keys) "/"))..
8ba0: 20 20 20 28 64 69 72 73 2d 74 6f 2d 72 65 6d 6f (dirs-to-remo
8bb0: 76 65 20 28 6d 61 6b 65 2d 68 61 73 68 2d 74 61 ve (make-hash-ta
8bc0: 62 6c 65 29 29 29 0a 09 20 28 6c 65 74 2a 20 28 ble))).. (let* (
8bd0: 28 72 75 6e 2d 69 64 20 20 20 20 28 64 62 3a 67 (run-id (db:g
8be0: 65 74 2d 76 61 6c 75 65 2d 62 79 2d 68 65 61 64 et-value-by-head
8bf0: 65 72 20 72 75 6e 20 68 65 61 64 65 72 20 22 69 er run header "i
8c00: 64 22 29 29 0a 09 09 28 72 75 6e 2d 73 74 61 74 d"))...(run-stat
8c10: 65 20 28 64 62 3a 67 65 74 2d 76 61 6c 75 65 2d e (db:get-value-
8c20: 62 79 2d 68 65 61 64 65 72 20 72 75 6e 20 68 65 by-header run he
8c30: 61 64 65 72 20 22 73 74 61 74 65 22 29 29 0a 09 ader "state"))..
8c40: 09 28 74 65 73 74 73 20 20 20 20 20 28 69 66 20 .(tests (if
8c50: 28 6e 6f 74 20 28 65 71 75 61 6c 3f 20 72 75 6e (not (equal? run
8c60: 2d 73 74 61 74 65 20 22 6c 6f 63 6b 65 64 22 29 -state "locked")
8c70: 29 0a 09 09 09 20 20 20 20 20 20 20 28 6f 70 65 ).... (ope
8c80: 6e 2d 72 75 6e 2d 63 6c 6f 73 65 20 64 62 3a 67 n-run-close db:g
8c90: 65 74 2d 74 65 73 74 73 2d 66 6f 72 2d 72 75 6e et-tests-for-run
8ca0: 20 64 62 20 72 75 6e 2d 69 64 0a 09 09 09 09 09 db run-id......
8cb0: 09 20 20 20 20 20 20 74 65 73 74 70 61 74 74 20 . testpatt
8cc0: 73 74 61 74 65 73 20 73 74 61 74 75 73 65 73 0a states statuses.
8cd0: 09 09 09 09 09 09 20 20 20 20 20 20 6e 6f 74 2d ...... not-
8ce0: 69 6e 3a 20 20 23 66 0a 09 09 09 09 09 09 20 20 in: #f.......
8cf0: 20 20 20 20 73 6f 72 74 2d 62 79 3a 20 28 63 61 sort-by: (ca
8d00: 73 65 20 61 63 74 69 6f 6e 0a 09 09 09 09 09 09 se action.......
8d10: 09 09 20 28 28 72 65 6d 6f 76 65 2d 72 75 6e 73 .. ((remove-runs
8d20: 29 20 27 72 75 6e 64 69 72 29 0a 09 09 09 09 09 ) 'rundir)......
8d30: 09 09 09 20 28 65 6c 73 65 20 20 20 20 20 20 20 ... (else
8d40: 20 20 20 27 65 76 65 6e 74 5f 74 69 6d 65 29 29 'event_time))
8d50: 29 0a 09 09 09 20 20 20 20 20 20 20 27 28 29 29 ).... '())
8d60: 29 0a 09 09 28 6c 61 73 74 74 70 61 74 68 20 22 )...(lasttpath "
8d70: 2f 64 6f 65 73 2f 6e 6f 74 2f 65 78 69 73 74 2f /does/not/exist/
8d80: 49 2f 68 6f 70 65 22 29 29 0a 09 20 20 20 28 64 I/hope")).. (d
8d90: 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 ebug:print-info
8da0: 34 20 22 72 75 6e 73 3a 6f 70 65 72 61 74 65 2d 4 "runs:operate-
8db0: 6f 6e 20 72 75 6e 3d 22 20 72 75 6e 20 22 2c 20 on run=" run ",
8dc0: 68 65 61 64 65 72 3d 22 20 68 65 61 64 65 72 29 header=" header)
8dd0: 0a 09 20 20 20 28 69 66 20 28 6e 6f 74 20 28 6e .. (if (not (n
8de0: 75 6c 6c 3f 20 74 65 73 74 73 29 29 0a 09 20 20 ull? tests))..
8df0: 20 20 20 20 20 28 62 65 67 69 6e 0a 09 09 20 28 (begin... (
8e00: 63 61 73 65 20 61 63 74 69 6f 6e 0a 09 09 20 20 case action...
8e10: 20 28 28 72 65 6d 6f 76 65 2d 72 75 6e 73 29 0a ((remove-runs).
8e20: 09 09 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 .. (debug:pri
8e30: 6e 74 20 31 20 22 52 65 6d 6f 76 69 6e 67 20 74 nt 1 "Removing t
8e40: 65 73 74 73 20 66 6f 72 20 72 75 6e 3a 20 22 20 ests for run: "
8e50: 72 75 6e 6b 65 79 20 22 20 22 20 28 64 62 3a 67 runkey " " (db:g
8e60: 65 74 2d 76 61 6c 75 65 2d 62 79 2d 68 65 61 64 et-value-by-head
8e70: 65 72 20 72 75 6e 20 68 65 61 64 65 72 20 22 72 er run header "r
8e80: 75 6e 6e 61 6d 65 22 29 29 29 0a 09 09 20 20 20 unname")))...
8e90: 28 28 73 65 74 2d 73 74 61 74 65 2d 73 74 61 74 ((set-state-stat
8ea0: 75 73 29 0a 09 09 20 20 20 20 28 64 65 62 75 67 us)... (debug
8eb0: 3a 70 72 69 6e 74 20 31 20 22 4d 6f 64 69 66 79 :print 1 "Modify
8ec0: 69 6e 67 20 73 74 61 74 65 20 61 6e 64 20 73 74 ing state and st
8ed0: 61 75 73 20 66 6f 72 20 74 65 73 74 73 20 66 6f aus for tests fo
8ee0: 72 20 72 75 6e 3a 20 22 20 72 75 6e 6b 65 79 20 r run: " runkey
8ef0: 22 20 22 20 28 64 62 3a 67 65 74 2d 76 61 6c 75 " " (db:get-valu
8f00: 65 2d 62 79 2d 68 65 61 64 65 72 20 72 75 6e 20 e-by-header run
8f10: 68 65 61 64 65 72 20 22 72 75 6e 6e 61 6d 65 22 header "runname"
8f20: 29 29 29 0a 09 09 20 20 20 28 28 70 72 69 6e 74 )))... ((print
8f30: 2d 72 75 6e 29 0a 09 09 20 20 20 20 28 64 65 62 -run)... (deb
8f40: 75 67 3a 70 72 69 6e 74 20 31 20 22 50 72 69 6e ug:print 1 "Prin
8f50: 74 69 6e 67 20 69 6e 66 6f 20 66 6f 72 20 72 75 ting info for ru
8f60: 6e 20 22 20 72 75 6e 6b 65 79 20 22 2c 20 72 75 n " runkey ", ru
8f70: 6e 3d 22 20 72 75 6e 20 22 2c 20 74 65 73 74 73 n=" run ", tests
8f80: 3d 22 20 74 65 73 74 73 20 22 2c 20 68 65 61 64 =" tests ", head
8f90: 65 72 3d 22 20 68 65 61 64 65 72 29 0a 09 09 20 er=" header)...
8fa0: 20 20 20 61 63 74 69 6f 6e 29 0a 09 09 20 20 20 action)...
8fb0: 28 65 6c 73 65 0a 09 09 20 20 20 20 28 64 65 62 (else... (deb
8fc0: 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 30 20 ug:print-info 0
8fd0: 22 61 63 74 69 6f 6e 20 6e 6f 74 20 72 65 63 6f "action not reco
8fe0: 67 6e 69 73 65 64 20 22 20 61 63 74 69 6f 6e 29 gnised " action)
8ff0: 29 29 0a 09 09 20 28 66 6f 72 2d 65 61 63 68 0a ))... (for-each.
9000: 09 09 20 20 28 6c 61 6d 62 64 61 20 28 74 65 73 .. (lambda (tes
9010: 74 29 0a 09 09 20 20 20 20 28 6c 65 74 2a 20 28 t)... (let* (
9020: 28 69 74 65 6d 2d 70 61 74 68 20 28 64 62 3a 74 (item-path (db:t
9030: 65 73 74 2d 67 65 74 2d 69 74 65 6d 2d 70 61 74 est-get-item-pat
9040: 68 20 74 65 73 74 29 29 0a 09 09 09 20 20 20 28 h test)).... (
9050: 74 65 73 74 2d 6e 61 6d 65 20 28 64 62 3a 74 65 test-name (db:te
9060: 73 74 2d 67 65 74 2d 74 65 73 74 6e 61 6d 65 20 st-get-testname
9070: 74 65 73 74 29 29 0a 09 09 09 20 20 20 28 72 75 test)).... (ru
9080: 6e 2d 64 69 72 20 20 20 28 64 62 3a 74 65 73 74 n-dir (db:test
9090: 2d 67 65 74 2d 72 75 6e 64 69 72 20 74 65 73 74 -get-rundir test
90a0: 29 29 20 20 20 20 3b 3b 20 72 75 6e 20 64 69 72 )) ;; run dir
90b0: 20 69 73 20 66 72 6f 6d 20 74 68 65 20 6c 69 6e is from the lin
90c0: 6b 20 74 72 65 65 0a 09 09 09 20 20 20 28 72 65 k tree.... (re
90d0: 61 6c 2d 64 69 72 20 20 28 69 66 20 28 66 69 6c al-dir (if (fil
90e0: 65 2d 65 78 69 73 74 73 3f 20 72 75 6e 2d 64 69 e-exists? run-di
90f0: 72 29 0a 09 09 09 09 09 20 20 28 72 65 73 6f 6c r)...... (resol
9100: 76 65 2d 70 61 74 68 6e 61 6d 65 20 72 75 6e 2d ve-pathname run-
9110: 64 69 72 29 0a 09 09 09 09 09 20 20 23 66 29 29 dir)...... #f))
9120: 0a 09 09 09 20 20 20 28 74 65 73 74 2d 69 64 20 .... (test-id
9130: 20 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 69 (db:test-get-i
9140: 64 20 74 65 73 74 29 29 29 0a 09 09 20 20 20 20 d test)))...
9150: 20 20 3b 3b 20 20 20 28 74 64 62 20 20 20 20 20 ;; (tdb
9160: 20 20 28 64 62 3a 6f 70 65 6e 2d 74 65 73 74 2d (db:open-test-
9170: 64 62 20 72 75 6e 2d 64 69 72 29 29 29 0a 09 09 db run-dir)))...
9180: 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 (debug:pri
9190: 6e 74 2d 69 6e 66 6f 20 34 20 22 74 65 73 74 3d nt-info 4 "test=
91a0: 22 20 74 65 73 74 29 20 3b 3b 20 20 20 22 20 28 " test) ;; " (
91b0: 64 62 3a 74 65 73 74 2d 67 65 74 2d 74 65 73 74 db:test-get-test
91c0: 6e 61 6d 65 20 74 65 73 74 29 20 22 20 69 64 3a name test) " id:
91d0: 20 22 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d " (db:test-get-
91e0: 69 64 20 74 65 73 74 29 20 22 20 22 20 69 74 65 id test) " " ite
91f0: 6d 2d 70 61 74 68 20 22 20 61 63 74 69 6f 6e 3a m-path " action:
9200: 20 22 20 61 63 74 69 6f 6e 29 0a 09 09 20 20 20 " action)...
9210: 20 20 20 28 63 61 73 65 20 61 63 74 69 6f 6e 0a (case action.
9220: 09 09 09 28 28 72 65 6d 6f 76 65 2d 72 75 6e 73 ...((remove-runs
9230: 29 20 3b 3b 20 74 68 65 20 74 64 62 20 69 73 20 ) ;; the tdb is
9240: 66 6f 72 20 66 75 74 75 72 65 20 70 6f 73 73 69 for future possi
9250: 62 6c 65 2e 20 0a 09 09 09 20 28 6f 70 65 6e 2d ble. .... (open-
9260: 72 75 6e 2d 63 6c 6f 73 65 20 64 62 3a 64 65 6c run-close db:del
9270: 65 74 65 2d 74 65 73 74 2d 72 65 63 6f 72 64 73 ete-test-records
9280: 20 64 62 20 23 66 20 28 64 62 3a 74 65 73 74 2d db #f (db:test-
9290: 67 65 74 2d 69 64 20 74 65 73 74 29 29 0a 09 09 get-id test))...
92a0: 09 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 . (debug:print-i
92b0: 6e 66 6f 20 31 20 22 41 74 74 65 6d 70 74 69 6e nfo 1 "Attemptin
92c0: 67 20 74 6f 20 72 65 6d 6f 76 65 20 22 20 28 69 g to remove " (i
92d0: 66 20 72 65 61 6c 2d 64 69 72 20 28 63 6f 6e 63 f real-dir (conc
92e0: 20 22 20 64 69 72 20 22 20 72 65 61 6c 2d 64 69 " dir " real-di
92f0: 72 20 22 20 61 6e 64 20 22 29 20 22 22 29 20 22 r " and ") "") "
9300: 20 6c 69 6e 6b 20 22 20 72 75 6e 2d 64 69 72 29 link " run-dir)
9310: 0a 09 09 09 20 28 69 66 20 28 61 6e 64 20 72 65 .... (if (and re
9320: 61 6c 2d 64 69 72 20 0a 09 09 09 09 20 20 28 3e al-dir ..... (>
9330: 20 28 73 74 72 69 6e 67 2d 6c 65 6e 67 74 68 20 (string-length
9340: 72 65 61 6c 2d 64 69 72 29 20 35 29 0a 09 09 09 real-dir) 5)....
9350: 09 20 20 28 66 69 6c 65 2d 65 78 69 73 74 73 3f . (file-exists?
9360: 20 72 65 61 6c 2d 64 69 72 29 29 20 3b 3b 20 62 real-dir)) ;; b
9370: 61 64 20 68 65 75 72 69 73 74 69 63 20 62 75 74 ad heuristic but
9380: 20 73 68 6f 75 6c 64 20 70 72 65 76 65 6e 74 20 should prevent
9390: 2f 74 6d 70 20 2f 68 6f 6d 65 20 65 74 63 2e 0a /tmp /home etc..
93a0: 09 09 09 20 20 20 20 20 28 62 65 67 69 6e 20 3b ... (begin ;
93b0: 3b 20 6c 65 74 2a 20 28 28 72 65 61 6c 70 61 74 ; let* ((realpat
93c0: 68 20 28 72 65 73 6f 6c 76 65 2d 70 61 74 68 6e h (resolve-pathn
93d0: 61 6d 65 20 72 75 6e 2d 64 69 72 29 29 29 0a 09 ame run-dir)))..
93e0: 09 09 20 20 20 20 20 20 20 28 64 65 62 75 67 3a .. (debug:
93f0: 70 72 69 6e 74 2d 69 6e 66 6f 20 31 20 22 52 65 print-info 1 "Re
9400: 63 75 72 73 69 76 65 6c 79 20 72 65 6d 6f 76 69 cursively removi
9410: 6e 67 20 22 20 72 65 61 6c 2d 64 69 72 29 0a 09 ng " real-dir)..
9420: 09 09 20 20 20 20 20 20 20 28 69 66 20 28 66 69 .. (if (fi
9430: 6c 65 2d 65 78 69 73 74 73 3f 20 72 65 61 6c 2d le-exists? real-
9440: 64 69 72 29 0a 09 09 09 09 20 20 20 28 69 66 20 dir)..... (if
9450: 28 3e 20 28 73 79 73 74 65 6d 20 28 63 6f 6e 63 (> (system (conc
9460: 20 22 72 6d 20 2d 72 66 20 22 20 72 65 61 6c 2d "rm -rf " real-
9470: 64 69 72 29 29 20 30 29 0a 09 09 09 09 20 20 20 dir)) 0).....
9480: 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 (debug:print
9490: 20 30 20 22 45 52 52 4f 52 3a 20 54 68 65 72 65 0 "ERROR: There
94a0: 20 77 61 73 20 61 20 70 72 6f 62 6c 65 6d 20 72 was a problem r
94b0: 65 6d 6f 76 69 6e 67 20 22 20 72 65 61 6c 2d 64 emoving " real-d
94c0: 69 72 20 22 20 77 69 74 68 20 72 6d 20 2d 66 22 ir " with rm -f"
94d0: 29 29 0a 09 09 09 09 20 20 20 28 64 65 62 75 67 ))..... (debug
94e0: 3a 70 72 69 6e 74 20 30 20 22 57 41 52 4e 49 4e :print 0 "WARNIN
94f0: 47 3a 20 74 65 73 74 20 64 69 72 20 22 20 72 65 G: test dir " re
9500: 61 6c 2d 64 69 72 20 22 20 61 70 70 65 61 72 73 al-dir " appears
9510: 20 74 6f 20 6e 6f 74 20 65 78 69 73 74 20 6f 72 to not exist or
9520: 20 69 73 20 6e 6f 74 20 72 65 61 64 61 62 6c 65 is not readable
9530: 22 29 29 29 0a 09 09 09 20 20 20 20 20 28 69 66 "))).... (if
9540: 20 72 65 61 6c 2d 64 69 72 20 0a 09 09 09 09 20 real-dir .....
9550: 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 22 (debug:print 0 "
9560: 57 41 52 4e 49 4e 47 3a 20 64 69 72 65 63 74 6f WARNING: directo
9570: 72 79 20 22 20 72 65 61 6c 2d 64 69 72 20 22 20 ry " real-dir "
9580: 64 6f 65 73 20 6e 6f 74 20 65 78 69 73 74 22 29 does not exist")
9590: 0a 09 09 09 09 20 28 64 65 62 75 67 3a 70 72 69 ..... (debug:pri
95a0: 6e 74 20 30 20 22 57 41 52 4e 49 4e 47 3a 20 6e nt 0 "WARNING: n
95b0: 6f 20 72 65 61 6c 20 64 69 72 65 63 74 6f 72 79 o real directory
95c0: 20 63 6f 72 72 6f 73 70 6f 6e 64 69 6e 67 20 74 corrosponding t
95d0: 6f 20 6c 69 6e 6b 20 22 20 72 75 6e 2d 64 69 72 o link " run-dir
95e0: 20 22 2c 20 6e 6f 74 68 69 6e 67 20 64 6f 6e 65 ", nothing done
95f0: 22 29 29 29 0a 09 09 09 20 28 69 66 20 28 73 79 "))).... (if (sy
9600: 6d 62 6f 6c 69 63 2d 6c 69 6e 6b 3f 20 72 75 6e mbolic-link? run
9610: 2d 64 69 72 29 0a 09 09 09 20 20 20 20 20 28 62 -dir).... (b
9620: 65 67 69 6e 0a 09 09 09 20 20 20 20 20 20 20 28 egin.... (
9630: 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f debug:print-info
9640: 20 31 20 22 52 65 6d 6f 76 69 6e 67 20 73 79 6d 1 "Removing sym
9650: 6c 69 6e 6b 20 22 20 72 75 6e 2d 64 69 72 29 0a link " run-dir).
9660: 09 09 09 20 20 20 20 20 20 20 28 68 61 6e 64 6c ... (handl
9670: 65 2d 65 78 63 65 70 74 69 6f 6e 73 0a 09 09 09 e-exceptions....
9680: 09 65 78 6e 0a 09 09 09 09 28 64 65 62 75 67 3a .exn.....(debug:
9690: 70 72 69 6e 74 20 30 20 22 45 52 52 4f 52 3a 20 print 0 "ERROR:
96a0: 20 46 61 69 6c 65 64 20 74 6f 20 72 65 6d 6f 76 Failed to remov
96b0: 65 20 73 79 6d 6c 69 6e 6b 20 22 20 72 75 6e 2d e symlink " run-
96c0: 64 69 72 20 28 28 63 6f 6e 64 69 74 69 6f 6e 2d dir ((condition-
96d0: 70 72 6f 70 65 72 74 79 2d 61 63 63 65 73 73 6f property-accesso
96e0: 72 20 27 65 78 6e 20 27 6d 65 73 73 61 67 65 29 r 'exn 'message)
96f0: 20 65 78 6e 29 20 22 2c 20 61 74 74 65 6d 70 74 exn) ", attempt
9700: 69 6e 67 20 74 6f 20 63 6f 6e 74 69 6e 75 65 22 ing to continue"
9710: 29 0a 09 09 09 09 28 64 65 6c 65 74 65 2d 66 69 ).....(delete-fi
9720: 6c 65 20 72 75 6e 2d 64 69 72 29 29 29 0a 09 09 le run-dir)))...
9730: 09 20 20 20 20 20 28 69 66 20 28 64 69 72 65 63 . (if (direc
9740: 74 6f 72 79 3f 20 72 75 6e 2d 64 69 72 29 0a 09 tory? run-dir)..
9750: 09 09 09 20 28 69 66 20 28 3e 20 28 64 69 72 65 ... (if (> (dire
9760: 63 74 6f 72 79 2d 66 6f 6c 64 20 28 6c 61 6d 62 ctory-fold (lamb
9770: 64 61 20 28 66 20 78 29 28 2b 20 31 20 78 29 29 da (f x)(+ 1 x))
9780: 20 30 20 72 75 6e 2d 64 69 72 29 20 30 29 0a 09 0 run-dir) 0)..
9790: 09 09 09 20 20 20 20 20 28 64 65 62 75 67 3a 70 ... (debug:p
97a0: 72 69 6e 74 20 30 20 22 57 41 52 4e 49 4e 47 3a rint 0 "WARNING:
97b0: 20 72 65 66 75 73 69 6e 67 20 74 6f 20 72 65 6d refusing to rem
97c0: 6f 76 65 20 22 20 72 75 6e 2d 64 69 72 20 22 20 ove " run-dir "
97d0: 61 73 20 69 74 20 69 73 20 6e 6f 74 20 65 6d 70 as it is not emp
97e0: 74 79 22 29 0a 09 09 09 09 20 20 20 20 20 20 28 ty")..... (
97f0: 68 61 6e 64 6c 65 2d 65 78 63 65 70 74 69 6f 6e handle-exception
9800: 73 0a 09 09 09 09 20 20 20 20 20 20 20 65 78 6e s..... exn
9810: 0a 09 09 09 09 20 20 20 20 20 20 20 28 64 65 62 ..... (deb
9820: 75 67 3a 70 72 69 6e 74 20 30 20 22 45 52 52 4f ug:print 0 "ERRO
9830: 52 3a 20 20 46 61 69 6c 65 64 20 74 6f 20 72 65 R: Failed to re
9840: 6d 6f 76 65 20 64 69 72 65 63 74 6f 72 79 20 22 move directory "
9850: 20 72 75 6e 2d 64 69 72 20 28 28 63 6f 6e 64 69 run-dir ((condi
9860: 74 69 6f 6e 2d 70 72 6f 70 65 72 74 79 2d 61 63 tion-property-ac
9870: 63 65 73 73 6f 72 20 27 65 78 6e 20 27 6d 65 73 cessor 'exn 'mes
9880: 73 61 67 65 29 20 65 78 6e 29 20 22 2c 20 61 74 sage) exn) ", at
9890: 74 65 6d 70 74 69 6e 67 20 74 6f 20 63 6f 6e 74 tempting to cont
98a0: 69 6e 75 65 22 29 0a 09 09 09 09 20 20 20 20 20 inue").....
98b0: 20 20 28 64 65 6c 65 74 65 2d 64 69 72 65 63 74 (delete-direct
98c0: 6f 72 79 20 72 75 6e 2d 64 69 72 29 29 29 0a 09 ory run-dir)))..
98d0: 09 09 09 20 28 69 66 20 72 75 6e 2d 64 69 72 0a ... (if run-dir.
98e0: 09 09 09 09 20 20 20 20 20 28 64 65 62 75 67 3a .... (debug:
98f0: 70 72 69 6e 74 20 30 20 22 57 41 52 4e 49 4e 47 print 0 "WARNING
9900: 3a 20 6e 6f 74 20 72 65 6d 6f 76 69 6e 67 20 22 : not removing "
9910: 20 72 75 6e 2d 64 69 72 20 22 20 61 73 20 69 74 run-dir " as it
9920: 20 65 69 74 68 65 72 20 64 6f 65 73 6e 27 74 20 either doesn't
9930: 65 78 69 73 74 20 6f 72 20 69 73 20 6e 6f 74 20 exist or is not
9940: 61 20 73 79 6d 6c 69 6e 6b 22 29 0a 09 09 09 09 a symlink").....
9950: 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e (debug:prin
9960: 74 20 30 20 22 4e 4f 54 45 3a 20 74 68 65 20 72 t 0 "NOTE: the r
9970: 75 6e 20 64 69 72 20 66 6f 72 20 74 68 69 73 20 un dir for this
9980: 74 65 73 74 20 69 73 20 75 6e 64 65 66 69 6e 65 test is undefine
9990: 64 2e 20 54 65 73 74 20 6d 61 79 20 68 61 76 65 d. Test may have
99a0: 20 61 6c 72 65 61 64 79 20 62 65 65 6e 20 64 65 already been de
99b0: 6c 65 74 65 64 2e 22 29 29 0a 09 09 09 09 20 29 leted."))..... )
99c0: 29 29 0a 09 09 09 28 28 73 65 74 2d 73 74 61 74 ))....((set-stat
99d0: 65 2d 73 74 61 74 75 73 29 0a 09 09 09 20 28 64 e-status).... (d
99e0: 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 ebug:print-info
99f0: 32 20 22 6e 65 77 20 73 74 61 74 65 20 22 20 28 2 "new state " (
9a00: 63 61 72 20 73 74 61 74 65 2d 73 74 61 74 75 73 car state-status
9a10: 29 20 22 2c 20 6e 65 77 20 73 74 61 74 75 73 20 ) ", new status
9a20: 22 20 28 63 61 64 72 20 73 74 61 74 65 2d 73 74 " (cadr state-st
9a30: 61 74 75 73 29 29 0a 09 09 09 20 28 6f 70 65 6e atus)).... (open
9a40: 2d 72 75 6e 2d 63 6c 6f 73 65 20 64 62 3a 74 65 -run-close db:te
9a50: 73 74 2d 73 65 74 2d 73 74 61 74 65 2d 73 74 61 st-set-state-sta
9a60: 74 75 73 2d 62 79 2d 69 64 20 64 62 20 28 64 62 tus-by-id db (db
9a70: 3a 74 65 73 74 2d 67 65 74 2d 69 64 20 74 65 73 :test-get-id tes
9a80: 74 29 20 28 63 61 72 20 73 74 61 74 65 2d 73 74 t) (car state-st
9a90: 61 74 75 73 29 28 63 61 64 72 20 73 74 61 74 65 atus)(cadr state
9aa0: 2d 73 74 61 74 75 73 29 20 23 66 29 29 29 29 29 -status) #f)))))
9ab0: 0a 09 09 20 20 28 73 6f 72 74 20 74 65 73 74 73 ... (sort tests
9ac0: 20 28 6c 61 6d 62 64 61 20 28 61 20 62 29 28 6c (lambda (a b)(l
9ad0: 65 74 20 28 28 64 69 72 61 20 28 64 62 3a 74 65 et ((dira (db:te
9ae0: 73 74 2d 67 65 74 2d 72 75 6e 64 69 72 20 61 29 st-get-rundir a)
9af0: 29 0a 09 09 09 09 09 09 20 28 64 69 72 62 20 28 )....... (dirb (
9b00: 64 62 3a 74 65 73 74 2d 67 65 74 2d 72 75 6e 64 db:test-get-rund
9b10: 69 72 20 62 29 29 29 0a 09 09 09 09 09 20 20 20 ir b)))......
9b20: 20 20 28 69 66 20 28 61 6e 64 20 28 73 74 72 69 (if (and (stri
9b30: 6e 67 3f 20 64 69 72 61 29 28 73 74 72 69 6e 67 ng? dira)(string
9b40: 3f 20 64 69 72 62 29 29 0a 09 09 09 09 09 09 20 ? dirb)).......
9b50: 28 3e 20 28 73 74 72 69 6e 67 2d 6c 65 6e 67 74 (> (string-lengt
9b60: 68 20 64 69 72 61 29 28 73 74 72 69 6e 67 2d 6c h dira)(string-l
9b70: 65 6e 67 74 68 20 64 69 72 62 29 29 0a 09 09 09 ength dirb))....
9b80: 09 09 09 20 23 66 29 29 29 29 29 29 29 0a 09 20 ... #f)))))))..
9b90: 20 20 3b 3b 20 72 65 6d 6f 76 65 20 74 68 65 20 ;; remove the
9ba0: 72 75 6e 20 69 66 20 7a 65 72 6f 20 74 65 73 74 run if zero test
9bb0: 73 20 72 65 6d 61 69 6e 0a 09 20 20 20 28 69 66 s remain.. (if
9bc0: 20 28 65 71 3f 20 61 63 74 69 6f 6e 20 27 72 65 (eq? action 're
9bd0: 6d 6f 76 65 2d 72 75 6e 73 29 0a 09 20 20 20 20 move-runs)..
9be0: 20 20 20 28 6c 65 74 20 28 28 72 65 6d 74 65 73 (let ((remtes
9bf0: 74 73 20 28 6f 70 65 6e 2d 72 75 6e 2d 63 6c 6f ts (open-run-clo
9c00: 73 65 20 64 62 3a 67 65 74 2d 74 65 73 74 73 2d se db:get-tests-
9c10: 66 6f 72 2d 72 75 6e 20 64 62 20 28 64 62 3a 67 for-run db (db:g
9c20: 65 74 2d 76 61 6c 75 65 2d 62 79 2d 68 65 61 64 et-value-by-head
9c30: 65 72 20 72 75 6e 20 68 65 61 64 65 72 20 22 69 er run header "i
9c40: 64 22 29 20 23 66 20 27 28 22 44 45 4c 45 54 45 d") #f '("DELETE
9c50: 44 22 29 20 27 28 22 6e 2f 61 22 29 20 6e 6f 74 D") '("n/a") not
9c60: 2d 69 6e 3a 20 23 74 29 29 29 0a 09 09 20 28 69 -in: #t)))... (i
9c70: 66 20 28 6e 75 6c 6c 3f 20 72 65 6d 74 65 73 74 f (null? remtest
9c80: 73 29 20 3b 3b 20 6e 6f 20 6d 6f 72 65 20 74 65 s) ;; no more te
9c90: 73 74 73 20 72 65 6d 61 69 6e 69 6e 67 0a 09 09 sts remaining...
9ca0: 20 20 20 20 20 28 6c 65 74 2a 20 28 28 64 70 61 (let* ((dpa
9cb0: 72 74 73 20 20 28 73 74 72 69 6e 67 2d 73 70 6c rts (string-spl
9cc0: 69 74 20 6c 61 73 74 74 70 61 74 68 20 22 2f 22 it lasttpath "/"
9cd0: 29 29 0a 09 09 09 20 20 20 20 28 72 75 6e 70 61 )).... (runpa
9ce0: 74 68 20 28 63 6f 6e 63 20 22 2f 22 20 28 73 74 th (conc "/" (st
9cf0: 72 69 6e 67 2d 69 6e 74 65 72 73 70 65 72 73 65 ring-intersperse
9d00: 20 0a 09 09 09 09 09 09 28 74 61 6b 65 20 64 70 .......(take dp
9d10: 61 72 74 73 20 28 2d 20 28 6c 65 6e 67 74 68 20 arts (- (length
9d20: 64 70 61 72 74 73 29 20 31 29 29 0a 09 09 09 09 dparts) 1)).....
9d30: 09 09 22 2f 22 29 29 29 29 0a 09 09 20 20 20 20 .."/"))))...
9d40: 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 (debug:print
9d50: 31 20 22 52 65 6d 6f 76 69 6e 67 20 72 75 6e 3a 1 "Removing run:
9d60: 20 22 20 72 75 6e 6b 65 79 20 22 20 22 20 28 64 " runkey " " (d
9d70: 62 3a 67 65 74 2d 76 61 6c 75 65 2d 62 79 2d 68 b:get-value-by-h
9d80: 65 61 64 65 72 20 72 75 6e 20 68 65 61 64 65 72 eader run header
9d90: 20 22 72 75 6e 6e 61 6d 65 22 29 20 22 20 61 6e "runname") " an
9da0: 64 20 72 65 6c 61 74 65 64 20 72 65 63 6f 72 64 d related record
9db0: 22 29 0a 09 09 20 20 20 20 20 20 20 28 6f 70 65 ")... (ope
9dc0: 6e 2d 72 75 6e 2d 63 6c 6f 73 65 20 64 62 3a 64 n-run-close db:d
9dd0: 65 6c 65 74 65 2d 72 75 6e 20 64 62 20 72 75 6e elete-run db run
9de0: 2d 69 64 29 0a 09 09 20 20 20 20 20 20 20 3b 3b -id)... ;;
9df0: 20 54 68 69 73 20 69 73 20 61 20 70 72 65 74 74 This is a prett
9e00: 79 20 67 6f 6f 64 20 70 6c 61 63 65 20 74 6f 20 y good place to
9e10: 70 75 72 67 65 20 6f 6c 64 20 44 45 4c 45 54 45 purge old DELETE
9e20: 44 20 74 65 73 74 73 0a 09 09 20 20 20 20 20 20 D tests...
9e30: 20 28 6f 70 65 6e 2d 72 75 6e 2d 63 6c 6f 73 65 (open-run-close
9e40: 20 64 62 3a 64 65 6c 65 74 65 2d 74 65 73 74 73 db:delete-tests
9e50: 2d 66 6f 72 2d 72 75 6e 20 64 62 20 72 75 6e 2d -for-run db run-
9e60: 69 64 29 0a 09 09 20 20 20 20 20 20 20 28 6f 70 id)... (op
9e70: 65 6e 2d 72 75 6e 2d 63 6c 6f 73 65 20 64 62 3a en-run-close db:
9e80: 64 65 6c 65 74 65 2d 6f 6c 64 2d 64 65 6c 65 74 delete-old-delet
9e90: 65 64 2d 74 65 73 74 2d 72 65 63 6f 72 64 73 20 ed-test-records
9ea0: 64 62 29 0a 09 09 20 20 20 20 20 20 20 28 6f 70 db)... (op
9eb0: 65 6e 2d 72 75 6e 2d 63 6c 6f 73 65 20 64 62 3a en-run-close db:
9ec0: 73 65 74 2d 76 61 72 20 64 62 20 22 44 45 4c 45 set-var db "DELE
9ed0: 54 45 44 5f 54 45 53 54 53 22 20 28 63 75 72 72 TED_TESTS" (curr
9ee0: 65 6e 74 2d 73 65 63 6f 6e 64 73 29 29 0a 09 09 ent-seconds))...
9ef0: 20 20 20 20 20 20 20 3b 3b 20 6e 65 65 64 20 74 ;; need t
9f00: 6f 20 66 69 67 75 72 65 20 6f 75 74 20 74 68 65 o figure out the
9f10: 20 70 61 74 68 20 74 6f 20 74 68 65 20 72 75 6e path to the run
9f20: 20 64 69 72 20 61 6e 64 20 72 65 6d 6f 76 65 20 dir and remove
9f30: 69 74 20 69 66 20 65 6d 70 74 79 0a 09 09 20 20 it if empty...
9f40: 20 20 20 20 20 3b 3b 20 20 20 20 28 69 66 20 28 ;; (if (
9f50: 6e 75 6c 6c 3f 20 28 67 6c 6f 62 20 28 63 6f 6e null? (glob (con
9f60: 63 20 72 75 6e 70 61 74 68 20 22 2f 2a 22 29 29 c runpath "/*"))
9f70: 29 0a 09 09 20 20 20 20 20 20 20 3b 3b 20 20 20 )... ;;
9f80: 20 20 20 20 20 28 62 65 67 69 6e 0a 09 09 20 20 (begin...
9f90: 20 20 20 20 20 3b 3b 20 09 20 28 64 65 62 75 67 ;; . (debug
9fa0: 3a 70 72 69 6e 74 20 31 20 22 52 65 6d 6f 76 69 :print 1 "Removi
9fb0: 6e 67 20 72 75 6e 20 64 69 72 20 22 20 72 75 6e ng run dir " run
9fc0: 70 61 74 68 29 0a 09 09 20 20 20 20 20 20 20 3b path)... ;
9fd0: 3b 20 09 20 28 73 79 73 74 65 6d 20 28 63 6f 6e ; . (system (con
9fe0: 63 20 22 72 6d 64 69 72 20 2d 70 20 22 20 72 75 c "rmdir -p " ru
9ff0: 6e 70 61 74 68 29 29 29 29 0a 09 09 20 20 20 20 npath))))...
a000: 20 20 20 29 29 29 29 29 0a 09 20 29 29 0a 20 20 ))))).. )).
a010: 20 20 20 72 75 6e 73 29 29 0a 20 20 23 74 29 0a runs)). #t).
a020: 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d .;;=============
a030: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
a040: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
a050: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
a060: 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 52 6f 75 =========.;; Rou
a070: 74 69 6e 65 73 20 66 6f 72 20 6d 61 6e 69 70 75 tines for manipu
a080: 6c 61 74 69 6e 67 20 72 75 6e 73 0a 3b 3b 3d 3d lating runs.;;==
a090: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
a0a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
a0b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
a0c0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
a0d0: 3d 3d 3d 3d 0a 0a 3b 3b 20 53 69 6e 63 65 20 6d ====..;; Since m
a0e0: 61 6e 79 20 63 61 6c 6c 73 20 74 6f 20 61 20 72 any calls to a r
a0f0: 75 6e 20 72 65 71 75 69 72 65 20 70 72 65 74 74 un require prett
a100: 79 20 6d 75 63 68 20 74 68 65 20 73 61 6d 65 20 y much the same
a110: 73 65 74 75 70 20 0a 3b 3b 20 74 68 69 73 20 77 setup .;; this w
a120: 72 61 70 70 65 72 20 69 73 20 75 73 65 64 20 74 rapper is used t
a130: 6f 20 72 65 64 75 63 65 20 74 68 65 20 72 65 70 o reduce the rep
a140: 6c 69 63 61 74 69 6f 6e 20 6f 66 20 63 6f 64 65 lication of code
a150: 0a 28 64 65 66 69 6e 65 20 28 67 65 6e 65 72 61 .(define (genera
a160: 6c 2d 72 75 6e 2d 63 61 6c 6c 20 73 77 69 74 63 l-run-call switc
a170: 68 6e 61 6d 65 20 61 63 74 69 6f 6e 2d 64 65 73 hname action-des
a180: 63 20 70 72 6f 63 29 0a 20 20 28 6c 65 74 20 28 c proc). (let (
a190: 28 72 75 6e 6e 61 6d 65 20 28 61 72 67 73 3a 67 (runname (args:g
a1a0: 65 74 2d 61 72 67 20 22 3a 72 75 6e 6e 61 6d 65 et-arg ":runname
a1b0: 22 29 29 0a 09 28 74 61 72 67 65 74 20 20 28 69 "))..(target (i
a1c0: 66 20 28 61 72 67 73 3a 67 65 74 2d 61 72 67 20 f (args:get-arg
a1d0: 22 2d 74 61 72 67 65 74 22 29 0a 09 09 20 20 20 "-target")...
a1e0: 20 20 28 61 72 67 73 3a 67 65 74 2d 61 72 67 20 (args:get-arg
a1f0: 22 2d 74 61 72 67 65 74 22 29 0a 09 09 20 20 20 "-target")...
a200: 20 20 28 61 72 67 73 3a 67 65 74 2d 61 72 67 20 (args:get-arg
a210: 22 2d 72 65 71 74 61 72 67 22 29 29 29 0a 09 28 "-reqtarg")))..(
a220: 74 68 31 20 20 20 20 20 23 66 29 29 0a 20 20 20 th1 #f)).
a230: 20 28 63 6f 6e 64 0a 20 20 20 20 20 28 28 6e 6f (cond. ((no
a240: 74 20 74 61 72 67 65 74 29 0a 20 20 20 20 20 20 t target).
a250: 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 22 (debug:print 0 "
a260: 45 52 52 4f 52 3a 20 4d 69 73 73 69 6e 67 20 72 ERROR: Missing r
a270: 65 71 75 69 72 65 64 20 70 61 72 61 6d 65 74 65 equired paramete
a280: 72 20 66 6f 72 20 22 20 73 77 69 74 63 68 6e 61 r for " switchna
a290: 6d 65 20 22 2c 20 79 6f 75 20 6d 75 73 74 20 73 me ", you must s
a2a0: 70 65 63 69 66 79 20 74 68 65 20 74 61 72 67 65 pecify the targe
a2b0: 74 20 77 69 74 68 20 2d 74 61 72 67 65 74 22 29 t with -target")
a2c0: 0a 20 20 20 20 20 20 28 65 78 69 74 20 33 29 29 . (exit 3))
a2d0: 0a 20 20 20 20 20 28 28 6e 6f 74 20 72 75 6e 6e . ((not runn
a2e0: 61 6d 65 29 0a 20 20 20 20 20 20 28 64 65 62 75 ame). (debu
a2f0: 67 3a 70 72 69 6e 74 20 30 20 22 45 52 52 4f 52 g:print 0 "ERROR
a300: 3a 20 4d 69 73 73 69 6e 67 20 72 65 71 75 69 72 : Missing requir
a310: 65 64 20 70 61 72 61 6d 65 74 65 72 20 66 6f 72 ed parameter for
a320: 20 22 20 73 77 69 74 63 68 6e 61 6d 65 20 22 2c " switchname ",
a330: 20 79 6f 75 20 6d 75 73 74 20 73 70 65 63 69 66 you must specif
a340: 79 20 74 68 65 20 72 75 6e 20 6e 61 6d 65 20 77 y the run name w
a350: 69 74 68 20 3a 72 75 6e 6e 61 6d 65 20 72 75 6e ith :runname run
a360: 6e 61 6d 65 22 29 0a 20 20 20 20 20 20 28 65 78 name"). (ex
a370: 69 74 20 33 29 29 0a 20 20 20 20 20 28 65 6c 73 it 3)). (els
a380: 65 0a 20 20 20 20 20 20 28 6c 65 74 20 28 28 64 e. (let ((d
a390: 62 20 20 20 23 66 29 0a 09 20 20 20 20 28 6b 65 b #f).. (ke
a3a0: 79 73 20 23 66 29 29 0a 09 28 69 66 20 28 6e 6f ys #f))..(if (no
a3b0: 74 20 28 73 65 74 75 70 2d 66 6f 72 2d 72 75 6e t (setup-for-run
a3c0: 29 29 0a 09 20 20 20 20 28 62 65 67 69 6e 20 0a )).. (begin .
a3d0: 09 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 . (debug:pr
a3e0: 69 6e 74 20 30 20 22 46 61 69 6c 65 64 20 74 6f int 0 "Failed to
a3f0: 20 73 65 74 75 70 2c 20 65 78 69 74 69 6e 67 22 setup, exiting"
a400: 29 0a 09 20 20 20 20 20 20 28 65 78 69 74 20 31 ).. (exit 1
a410: 29 29 29 0a 09 28 69 66 20 28 61 72 67 73 3a 67 )))..(if (args:g
a420: 65 74 2d 61 72 67 20 22 2d 73 65 72 76 65 72 22 et-arg "-server"
a430: 29 0a 09 20 20 20 20 28 6f 70 65 6e 2d 72 75 6e ).. (open-run
a440: 2d 63 6c 6f 73 65 20 73 65 72 76 65 72 3a 73 74 -close server:st
a450: 61 72 74 20 64 62 20 28 61 72 67 73 3a 67 65 74 art db (args:get
a460: 2d 61 72 67 20 22 2d 73 65 72 76 65 72 22 29 29 -arg "-server"))
a470: 29 0a 20 09 20 20 20 20 3b 3b 20 28 69 66 20 28 ). . ;; (if (
a480: 6e 6f 74 20 28 6f 72 20 28 61 72 67 73 3a 67 65 not (or (args:ge
a490: 74 2d 61 72 67 20 22 2d 72 75 6e 61 6c 6c 22 29 t-arg "-runall")
a4a0: 20 20 20 20 20 3b 3b 20 72 75 6e 61 6c 6c 20 61 ;; runall a
a4b0: 6e 64 20 72 75 6e 74 65 73 74 73 20 61 72 65 20 nd runtests are
a4c0: 61 6c 6c 6f 77 65 64 20 74 6f 20 62 65 20 73 65 allowed to be se
a4d0: 72 76 65 72 73 0a 20 09 20 20 20 20 3b 3b 20 20 rvers. . ;;
a4e0: 20 20 20 09 20 28 61 72 67 73 3a 67 65 74 2d 61 . (args:get-a
a4f0: 72 67 20 22 2d 72 75 6e 74 65 73 74 73 22 29 29 rg "-runtests"))
a500: 29 0a 09 20 20 20 20 3b 3b 20 20 20 20 20 28 63 ).. ;; (c
a510: 6c 69 65 6e 74 3a 73 65 74 75 70 29 20 3b 3b 20 lient:setup) ;;
a520: 54 68 69 73 20 69 73 20 61 20 64 75 70 6c 69 63 This is a duplic
a530: 61 74 65 20 73 74 61 72 74 75 70 21 21 21 3f 3f ate startup!!!??
a540: 3f 20 42 55 47 3f 0a 09 20 20 20 20 3b 3b 20 20 ? BUG?.. ;;
a550: 20 20 20 29 29 0a 09 28 73 65 74 21 20 6b 65 79 ))..(set! key
a560: 73 20 28 6f 70 65 6e 2d 72 75 6e 2d 63 6c 6f 73 s (open-run-clos
a570: 65 20 64 62 3a 67 65 74 2d 6b 65 79 73 20 64 62 e db:get-keys db
a580: 29 29 0a 09 3b 3b 20 68 61 76 65 20 65 6e 6f 75 ))..;; have enou
a590: 67 68 20 74 6f 20 70 72 6f 63 65 73 73 20 2d 74 gh to process -t
a5a0: 61 72 67 65 74 20 6f 72 20 2d 72 65 71 74 61 72 arget or -reqtar
a5b0: 67 20 68 65 72 65 0a 09 28 69 66 20 28 61 72 67 g here..(if (arg
a5c0: 73 3a 67 65 74 2d 61 72 67 20 22 2d 72 65 71 74 s:get-arg "-reqt
a5d0: 61 72 67 22 29 0a 09 20 20 20 20 28 6c 65 74 2a arg").. (let*
a5e0: 20 28 28 72 75 6e 63 6f 6e 66 69 67 66 20 28 63 ((runconfigf (c
a5f0: 6f 6e 63 20 20 2a 74 6f 70 70 61 74 68 2a 20 22 onc *toppath* "
a600: 2f 72 75 6e 63 6f 6e 66 69 67 73 2e 63 6f 6e 66 /runconfigs.conf
a610: 69 67 22 29 29 20 3b 3b 20 44 4f 20 4e 4f 54 20 ig")) ;; DO NOT
a620: 45 56 41 4c 55 41 54 45 20 41 4c 4c 20 0a 09 09 EVALUATE ALL ...
a630: 20 20 20 28 72 75 6e 63 6f 6e 66 69 67 20 20 28 (runconfig (
a640: 72 65 61 64 2d 63 6f 6e 66 69 67 20 72 75 6e 63 read-config runc
a650: 6f 6e 66 69 67 66 20 23 66 20 23 74 20 65 6e 76 onfigf #f #t env
a660: 69 72 6f 6e 2d 70 61 74 74 3a 20 23 66 29 29 29 iron-patt: #f)))
a670: 20 0a 09 20 20 20 20 20 20 28 69 66 20 28 68 61 .. (if (ha
a680: 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 sh-table-ref/def
a690: 61 75 6c 74 20 72 75 6e 63 6f 6e 66 69 67 20 28 ault runconfig (
a6a0: 61 72 67 73 3a 67 65 74 2d 61 72 67 20 22 2d 72 args:get-arg "-r
a6b0: 65 71 74 61 72 67 22 29 20 23 66 29 0a 09 09 20 eqtarg") #f)...
a6c0: 20 28 6b 65 79 73 3a 74 61 72 67 65 74 2d 73 65 (keys:target-se
a6d0: 74 2d 61 72 67 73 20 6b 65 79 73 20 28 61 72 67 t-args keys (arg
a6e0: 73 3a 67 65 74 2d 61 72 67 20 22 2d 72 65 71 74 s:get-arg "-reqt
a6f0: 61 72 67 22 29 20 61 72 67 73 3a 61 72 67 2d 68 arg") args:arg-h
a700: 61 73 68 29 0a 09 09 20 20 28 62 65 67 69 6e 0a ash)... (begin.
a710: 09 09 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 .. (debug:pri
a720: 6e 74 20 30 20 22 45 52 52 4f 52 3a 20 5b 22 20 nt 0 "ERROR: ["
a730: 28 61 72 67 73 3a 67 65 74 2d 61 72 67 20 22 2d (args:get-arg "-
a740: 72 65 71 74 61 72 67 22 29 20 22 5d 20 6e 6f 74 reqtarg") "] not
a750: 20 66 6f 75 6e 64 20 69 6e 20 22 20 72 75 6e 63 found in " runc
a760: 6f 6e 66 69 67 66 29 0a 09 09 20 20 20 20 28 69 onfigf)... (i
a770: 66 20 64 62 20 28 73 71 6c 69 74 65 33 3a 66 69 f db (sqlite3:fi
a780: 6e 61 6c 69 7a 65 21 20 64 62 29 29 0a 09 09 20 nalize! db))...
a790: 20 20 20 28 65 78 69 74 20 31 29 29 29 29 0a 09 (exit 1))))..
a7a0: 20 20 20 20 28 69 66 20 28 61 72 67 73 3a 67 65 (if (args:ge
a7b0: 74 2d 61 72 67 20 22 2d 74 61 72 67 65 74 22 29 t-arg "-target")
a7c0: 0a 09 09 28 6b 65 79 73 3a 74 61 72 67 65 74 2d ...(keys:target-
a7d0: 73 65 74 2d 61 72 67 73 20 6b 65 79 73 20 28 61 set-args keys (a
a7e0: 72 67 73 3a 67 65 74 2d 61 72 67 20 22 2d 74 61 rgs:get-arg "-ta
a7f0: 72 67 65 74 22 20 61 72 67 73 3a 61 72 67 2d 68 rget" args:arg-h
a800: 61 73 68 29 20 61 72 67 73 3a 61 72 67 2d 68 61 ash) args:arg-ha
a810: 73 68 29 29 29 0a 09 28 69 66 20 28 6e 6f 74 20 sh)))..(if (not
a820: 28 63 61 72 20 2a 63 6f 6e 66 69 67 69 6e 66 6f (car *configinfo
a830: 2a 29 29 0a 09 20 20 20 20 28 62 65 67 69 6e 0a *)).. (begin.
a840: 09 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 . (debug:pr
a850: 69 6e 74 20 30 20 22 45 52 52 4f 52 3a 20 41 74 int 0 "ERROR: At
a860: 74 65 6d 70 74 65 64 20 74 6f 20 22 20 61 63 74 tempted to " act
a870: 69 6f 6e 2d 64 65 73 63 20 22 20 62 75 74 20 72 ion-desc " but r
a880: 75 6e 20 61 72 65 61 20 63 6f 6e 66 69 67 20 66 un area config f
a890: 69 6c 65 20 6e 6f 74 20 66 6f 75 6e 64 22 29 0a ile not found").
a8a0: 09 20 20 20 20 20 20 28 65 78 69 74 20 31 29 29 . (exit 1))
a8b0: 0a 09 20 20 20 20 3b 3b 20 45 78 74 72 61 63 74 .. ;; Extract
a8c0: 20 6f 75 74 20 73 74 75 66 66 20 6e 65 65 64 65 out stuff neede
a8d0: 64 20 69 6e 20 6d 6f 73 74 20 6f 72 20 6d 61 6e d in most or man
a8e0: 79 20 63 61 6c 6c 73 0a 09 20 20 20 20 3b 3b 20 y calls.. ;;
a8f0: 68 65 72 65 20 74 68 65 6e 20 63 61 6c 6c 20 70 here then call p
a900: 72 6f 63 0a 09 20 20 20 20 28 6c 65 74 2a 20 28 roc.. (let* (
a910: 28 6b 65 79 6e 61 6d 65 73 20 20 20 28 6d 61 70 (keynames (map
a920: 20 6b 65 79 3a 67 65 74 2d 66 69 65 6c 64 6e 61 key:get-fieldna
a930: 6d 65 20 6b 65 79 73 29 29 0a 09 09 20 20 20 28 me keys))... (
a940: 6b 65 79 76 61 6c 6c 73 74 20 20 28 6b 65 79 73 keyvallst (keys
a950: 2d 3e 76 61 6c 6c 69 73 74 20 6b 65 79 73 20 23 ->vallist keys #
a960: 74 29 29 29 0a 09 20 20 20 20 20 20 28 70 72 6f t))).. (pro
a970: 63 20 74 61 72 67 65 74 20 72 75 6e 6e 61 6d 65 c target runname
a980: 20 6b 65 79 73 20 6b 65 79 6e 61 6d 65 73 20 6b keys keynames k
a990: 65 79 76 61 6c 6c 73 74 29 29 29 0a 09 28 69 66 eyvallst)))..(if
a9a0: 20 74 68 31 20 28 74 68 72 65 61 64 2d 6a 6f 69 th1 (thread-joi
a9b0: 6e 21 20 74 68 31 29 29 0a 09 28 69 66 20 64 62 n! th1))..(if db
a9c0: 20 28 73 71 6c 69 74 65 33 3a 66 69 6e 61 6c 69 (sqlite3:finali
a9d0: 7a 65 21 20 64 62 29 29 0a 09 28 73 65 74 21 20 ze! db))..(set!
a9e0: 2a 64 69 64 73 6f 6d 65 74 68 69 6e 67 2a 20 23 *didsomething* #
a9f0: 74 29 29 29 29 29 29 0a 0a 3b 3b 3d 3d 3d 3d 3d t))))))..;;=====
aa00: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
aa10: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
aa20: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
aa30: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
aa40: 3d 0a 3b 3b 20 4c 6f 63 6b 2f 75 6e 6c 6f 63 6b =.;; Lock/unlock
aa50: 20 72 75 6e 73 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d runs.;;========
aa60: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
aa70: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
aa80: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
aa90: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a ==============..
aaa0: 28 64 65 66 69 6e 65 20 28 72 75 6e 73 3a 68 61 (define (runs:ha
aab0: 6e 64 6c 65 2d 6c 6f 63 6b 69 6e 67 20 74 61 72 ndle-locking tar
aac0: 67 65 74 20 6b 65 79 73 20 72 75 6e 6e 61 6d 65 get keys runname
aad0: 20 6c 6f 63 6b 20 75 6e 6c 6f 63 6b 20 75 73 65 lock unlock use
aae0: 72 29 0a 20 20 28 6c 65 74 2a 20 28 28 64 62 20 r). (let* ((db
aaf0: 20 20 20 20 20 20 23 66 29 0a 09 20 28 72 75 6e #f).. (run
ab00: 64 61 74 20 20 20 28 6f 70 65 6e 2d 72 75 6e 2d dat (open-run-
ab10: 63 6c 6f 73 65 20 72 75 6e 73 3a 67 65 74 2d 72 close runs:get-r
ab20: 75 6e 73 2d 62 79 2d 70 61 74 74 20 64 62 20 6b uns-by-patt db k
ab30: 65 79 73 20 72 75 6e 6e 61 6d 65 29 29 0a 09 20 eys runname))..
ab40: 28 68 65 61 64 65 72 20 20 20 28 76 65 63 74 6f (header (vecto
ab50: 72 2d 72 65 66 20 72 75 6e 64 61 74 20 30 29 29 r-ref rundat 0))
ab60: 0a 09 20 28 72 75 6e 73 20 20 20 20 20 28 76 65 .. (runs (ve
ab70: 63 74 6f 72 2d 72 65 66 20 72 75 6e 64 61 74 20 ctor-ref rundat
ab80: 31 29 29 29 0a 20 20 20 20 28 66 6f 72 2d 65 61 1))). (for-ea
ab90: 63 68 20 28 6c 61 6d 62 64 61 20 28 72 75 6e 29 ch (lambda (run)
aba0: 0a 09 09 28 6c 65 74 20 28 28 72 75 6e 2d 69 64 ...(let ((run-id
abb0: 20 28 64 62 3a 67 65 74 2d 76 61 6c 75 65 2d 62 (db:get-value-b
abc0: 79 2d 68 65 61 64 65 72 20 72 75 6e 20 68 65 61 y-header run hea
abd0: 64 65 72 20 22 69 64 22 29 29 29 0a 09 09 20 20 der "id")))...
abe0: 28 69 66 20 28 6f 72 20 6c 6f 63 6b 0a 09 09 09 (if (or lock....
abf0: 20 20 28 61 6e 64 20 75 6e 6c 6f 63 6b 0a 09 09 (and unlock...
ac00: 09 20 20 20 20 20 20 20 28 62 65 67 69 6e 0a 09 . (begin..
ac10: 09 09 09 20 28 70 72 69 6e 74 20 22 44 6f 20 79 ... (print "Do y
ac20: 6f 75 20 72 65 61 6c 6c 79 20 77 69 73 68 20 74 ou really wish t
ac30: 6f 20 75 6e 6c 6f 63 6b 20 72 75 6e 20 22 20 72 o unlock run " r
ac40: 75 6e 2d 69 64 20 22 3f 5c 6e 20 20 20 79 2f 6e un-id "?\n y/n
ac50: 3a 20 22 29 0a 09 09 09 09 20 28 65 71 75 61 6c : ")..... (equal
ac60: 3f 20 22 79 22 20 28 72 65 61 64 2d 6c 69 6e 65 ? "y" (read-line
ac70: 29 29 29 29 29 0a 09 09 20 20 20 20 20 20 28 6f )))))... (o
ac80: 70 65 6e 2d 72 75 6e 2d 63 6c 6f 73 65 20 64 62 pen-run-close db
ac90: 3a 6c 6f 63 6b 2f 75 6e 6c 6f 63 6b 2d 72 75 6e :lock/unlock-run
aca0: 20 64 62 20 72 75 6e 2d 69 64 20 6c 6f 63 6b 20 db run-id lock
acb0: 75 6e 6c 6f 63 6b 20 75 73 65 72 29 0a 09 09 20 unlock user)...
acc0: 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e (debug:prin
acd0: 74 2d 69 6e 66 6f 20 30 20 22 53 6b 69 70 70 69 t-info 0 "Skippi
ace0: 6e 67 20 6c 6f 63 6b 2f 75 6e 6c 6f 63 6b 20 6f ng lock/unlock o
acf0: 6e 20 22 20 72 75 6e 2d 69 64 29 29 29 29 0a 09 n " run-id))))..
ad00: 20 20 20 20 20 20 72 75 6e 73 29 29 29 0a 3b 3b runs))).;;
ad10: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
ad20: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
ad30: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
ad40: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
ad50: 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 52 6f 6c 6c 75 70 ======.;; Rollup
ad60: 20 72 75 6e 73 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d runs.;;========
ad70: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
ad80: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
ad90: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
ada0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a ==============..
adb0: 3b 3b 20 55 70 64 61 74 65 20 74 68 65 20 74 65 ;; Update the te
adc0: 73 74 5f 6d 65 74 61 20 74 61 62 6c 65 20 66 6f st_meta table fo
add0: 72 20 74 68 69 73 20 74 65 73 74 0a 28 64 65 66 r this test.(def
ade0: 69 6e 65 20 28 72 75 6e 73 3a 75 70 64 61 74 65 ine (runs:update
adf0: 2d 74 65 73 74 5f 6d 65 74 61 20 64 62 20 74 65 -test_meta db te
ae00: 73 74 2d 6e 61 6d 65 20 74 65 73 74 2d 63 6f 6e st-name test-con
ae10: 66 29 0a 20 20 28 6c 65 74 20 28 28 63 75 72 72 f). (let ((curr
ae20: 72 65 63 6f 72 64 20 28 63 64 62 3a 72 65 6d 6f record (cdb:remo
ae30: 74 65 2d 72 75 6e 20 64 62 3a 74 65 73 74 6d 65 te-run db:testme
ae40: 74 61 2d 67 65 74 2d 72 65 63 6f 72 64 20 64 62 ta-get-record db
ae50: 20 74 65 73 74 2d 6e 61 6d 65 29 29 29 0a 20 20 test-name))).
ae60: 20 20 28 69 66 20 28 6e 6f 74 20 63 75 72 72 72 (if (not currr
ae70: 65 63 6f 72 64 29 0a 09 28 62 65 67 69 6e 0a 09 ecord)..(begin..
ae80: 20 20 28 73 65 74 21 20 63 75 72 72 72 65 63 6f (set! currreco
ae90: 72 64 20 28 6d 61 6b 65 2d 76 65 63 74 6f 72 20 rd (make-vector
aea0: 31 30 20 23 66 29 29 0a 09 20 20 28 63 64 62 3a 10 #f)).. (cdb:
aeb0: 72 65 6d 6f 74 65 2d 72 75 6e 20 64 62 3a 74 65 remote-run db:te
aec0: 73 74 6d 65 74 61 2d 61 64 64 2d 72 65 63 6f 72 stmeta-add-recor
aed0: 64 20 64 62 20 74 65 73 74 2d 6e 61 6d 65 29 29 d db test-name))
aee0: 29 0a 20 20 20 20 28 66 6f 72 2d 65 61 63 68 20 ). (for-each
aef0: 0a 20 20 20 20 20 28 6c 61 6d 62 64 61 20 28 6b . (lambda (k
af00: 65 79 29 0a 20 20 20 20 20 20 20 28 6c 65 74 2a ey). (let*
af10: 20 28 28 69 64 78 20 28 63 61 64 72 20 6b 65 79 ((idx (cadr key
af20: 29 29 0a 09 20 20 20 20 20 20 28 66 6c 64 20 28 )).. (fld (
af30: 63 61 72 20 20 6b 65 79 29 29 0a 09 20 20 20 20 car key))..
af40: 20 20 28 76 61 6c 20 28 63 6f 6e 66 69 67 2d 6c (val (config-l
af50: 6f 6f 6b 75 70 20 74 65 73 74 2d 63 6f 6e 66 20 ookup test-conf
af60: 22 74 65 73 74 5f 6d 65 74 61 22 20 66 6c 64 29 "test_meta" fld)
af70: 29 29 0a 09 20 3b 3b 20 28 64 65 62 75 67 3a 70 )).. ;; (debug:p
af80: 72 69 6e 74 20 35 20 22 69 64 78 3a 20 22 20 69 rint 5 "idx: " i
af90: 64 78 20 22 20 66 6c 64 3a 20 22 20 66 6c 64 20 dx " fld: " fld
afa0: 22 20 76 61 6c 3a 20 22 20 76 61 6c 29 0a 09 20 " val: " val)..
afb0: 28 69 66 20 28 61 6e 64 20 76 61 6c 20 28 6e 6f (if (and val (no
afc0: 74 20 28 65 71 75 61 6c 3f 20 28 76 65 63 74 6f t (equal? (vecto
afd0: 72 2d 72 65 66 20 63 75 72 72 72 65 63 6f 72 64 r-ref currrecord
afe0: 20 69 64 78 29 20 76 61 6c 29 29 29 0a 09 20 20 idx) val)))..
aff0: 20 20 20 28 62 65 67 69 6e 0a 09 20 20 20 20 20 (begin..
b000: 20 20 28 70 72 69 6e 74 20 22 55 70 64 61 74 69 (print "Updati
b010: 6e 67 20 22 20 74 65 73 74 2d 6e 61 6d 65 20 22 ng " test-name "
b020: 20 22 20 66 6c 64 20 22 20 74 6f 20 22 20 76 61 " fld " to " va
b030: 6c 29 0a 09 20 20 20 20 20 20 20 28 63 64 62 3a l).. (cdb:
b040: 72 65 6d 6f 74 65 2d 72 75 6e 20 64 62 3a 74 65 remote-run db:te
b050: 73 74 6d 65 74 61 2d 75 70 64 61 74 65 2d 66 69 stmeta-update-fi
b060: 65 6c 64 20 64 62 20 74 65 73 74 2d 6e 61 6d 65 eld db test-name
b070: 20 66 6c 64 20 76 61 6c 29 29 29 29 29 0a 20 20 fld val))))).
b080: 20 20 20 27 28 28 22 61 75 74 68 6f 72 22 20 32 '(("author" 2
b090: 29 28 22 6f 77 6e 65 72 22 20 33 29 28 22 64 65 )("owner" 3)("de
b0a0: 73 63 72 69 70 74 69 6f 6e 22 20 34 29 28 22 72 scription" 4)("r
b0b0: 65 76 69 65 77 65 64 22 20 35 29 28 22 74 61 67 eviewed" 5)("tag
b0c0: 73 22 20 39 29 29 29 29 29 0a 0a 3b 3b 20 55 70 s" 9)))))..;; Up
b0d0: 64 61 74 65 20 74 65 73 74 5f 6d 65 74 61 20 66 date test_meta f
b0e0: 6f 72 20 61 6c 6c 20 74 65 73 74 73 0a 28 64 65 or all tests.(de
b0f0: 66 69 6e 65 20 28 72 75 6e 73 3a 75 70 64 61 74 fine (runs:updat
b100: 65 2d 61 6c 6c 2d 74 65 73 74 5f 6d 65 74 61 20 e-all-test_meta
b110: 64 62 29 0a 20 20 28 6c 65 74 20 28 28 74 65 73 db). (let ((tes
b120: 74 2d 6e 61 6d 65 73 20 28 74 65 73 74 73 3a 67 t-names (tests:g
b130: 65 74 2d 76 61 6c 69 64 2d 74 65 73 74 73 29 29 et-valid-tests))
b140: 29 0a 20 20 20 20 28 66 6f 72 2d 65 61 63 68 20 ). (for-each
b150: 0a 20 20 20 20 20 28 6c 61 6d 62 64 61 20 28 74 . (lambda (t
b160: 65 73 74 2d 6e 61 6d 65 29 0a 20 20 20 20 20 20 est-name).
b170: 20 28 6c 65 74 2a 20 28 28 74 65 73 74 2d 70 61 (let* ((test-pa
b180: 74 68 20 20 20 20 28 63 6f 6e 63 20 2a 74 6f 70 th (conc *top
b190: 70 61 74 68 2a 20 22 2f 74 65 73 74 73 2f 22 20 path* "/tests/"
b1a0: 74 65 73 74 2d 6e 61 6d 65 29 29 0a 09 20 20 20 test-name))..
b1b0: 20 20 20 28 74 65 73 74 2d 63 6f 6e 66 69 67 66 (test-configf
b1c0: 20 28 63 6f 6e 63 20 74 65 73 74 2d 70 61 74 68 (conc test-path
b1d0: 20 22 2f 74 65 73 74 63 6f 6e 66 69 67 22 29 29 "/testconfig"))
b1e0: 0a 09 20 20 20 20 20 20 28 74 65 73 74 65 78 69 .. (testexi
b1f0: 73 74 73 20 20 20 28 61 6e 64 20 28 66 69 6c 65 sts (and (file
b200: 2d 65 78 69 73 74 73 3f 20 74 65 73 74 2d 63 6f -exists? test-co
b210: 6e 66 69 67 66 29 28 66 69 6c 65 2d 72 65 61 64 nfigf)(file-read
b220: 2d 61 63 63 65 73 73 3f 20 74 65 73 74 2d 63 6f -access? test-co
b230: 6e 66 69 67 66 29 29 29 0a 09 20 20 20 20 20 20 nfigf)))..
b240: 3b 3b 20 72 65 61 64 20 63 6f 6e 66 69 67 73 20 ;; read configs
b250: 77 69 74 68 20 74 72 69 63 6b 73 20 74 75 72 6e with tricks turn
b260: 65 64 20 6f 66 66 20 28 69 2e 65 2e 20 6e 6f 20 ed off (i.e. no
b270: 73 79 73 74 65 6d 29 0a 09 20 20 20 20 20 20 28 system).. (
b280: 74 65 73 74 2d 63 6f 6e 66 20 20 20 20 28 69 66 test-conf (if
b290: 20 74 65 73 74 65 78 69 73 74 73 20 28 72 65 61 testexists (rea
b2a0: 64 2d 63 6f 6e 66 69 67 20 74 65 73 74 2d 63 6f d-config test-co
b2b0: 6e 66 69 67 66 20 23 66 20 23 66 29 28 6d 61 6b nfigf #f #f)(mak
b2c0: 65 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 29 29 e-hash-table))))
b2d0: 0a 09 20 3b 3b 20 75 73 65 20 74 68 65 20 6f 70 .. ;; use the op
b2e0: 65 6e 2d 72 75 6e 2d 63 6c 6f 73 65 20 69 6e 73 en-run-close ins
b2f0: 74 65 61 64 20 6f 66 20 70 61 73 73 69 6e 67 20 tead of passing
b300: 69 6e 20 64 62 0a 09 20 28 72 75 6e 73 3a 75 70 in db.. (runs:up
b310: 64 61 74 65 2d 74 65 73 74 5f 6d 65 74 61 20 23 date-test_meta #
b320: 66 20 74 65 73 74 2d 6e 61 6d 65 20 74 65 73 74 f test-name test
b330: 2d 63 6f 6e 66 29 29 29 0a 20 20 20 20 20 74 65 -conf))). te
b340: 73 74 2d 6e 61 6d 65 73 29 29 29 0a 0a 3b 3b 20 st-names)))..;;
b350: 54 68 69 73 20 63 6f 75 6c 64 20 70 72 6f 62 61 This could proba
b360: 62 6c 79 20 62 65 20 72 65 66 61 63 74 6f 72 65 bly be refactore
b370: 64 20 69 6e 74 6f 20 6f 6e 65 20 63 6f 6d 70 6c d into one compl
b380: 65 78 20 71 75 65 72 79 20 2e 2e 2e 0a 28 64 65 ex query ....(de
b390: 66 69 6e 65 20 28 72 75 6e 73 3a 72 6f 6c 6c 75 fine (runs:rollu
b3a0: 70 2d 72 75 6e 20 6b 65 79 73 20 6b 65 79 76 61 p-run keys keyva
b3b0: 6c 6c 73 74 20 72 75 6e 6e 61 6d 65 20 75 73 65 llst runname use
b3c0: 72 29 20 3b 3b 20 77 61 73 20 74 61 72 67 65 74 r) ;; was target
b3d0: 2c 20 6e 6f 77 20 6b 65 79 76 61 6c 6c 73 74 0a , now keyvallst.
b3e0: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 34 (debug:print 4
b3f0: 20 22 72 75 6e 73 3a 72 6f 6c 6c 75 70 2d 72 75 "runs:rollup-ru
b400: 6e 2c 20 6b 65 79 73 3a 20 22 20 6b 65 79 73 20 n, keys: " keys
b410: 22 20 6b 65 79 76 61 6c 6c 73 74 3a 20 22 20 6b " keyvallst: " k
b420: 65 79 76 61 6c 6c 73 74 20 22 20 3a 72 75 6e 6e eyvallst " :runn
b430: 61 6d 65 20 22 20 72 75 6e 6e 61 6d 65 20 22 20 ame " runname "
b440: 75 73 65 72 3a 20 22 20 75 73 65 72 29 0a 20 20 user: " user).
b450: 28 6c 65 74 2a 20 28 28 64 62 20 20 20 20 20 20 (let* ((db
b460: 20 20 20 20 20 20 20 20 23 66 29 20 3b 3b 20 28 #f) ;; (
b470: 6b 65 79 76 61 6c 6c 6c 73 74 20 20 20 20 20 20 keyvalllst
b480: 28 6b 65 79 73 3a 74 61 72 67 65 74 2d 3e 6b 65 (keys:target->ke
b490: 79 76 61 6c 20 6b 65 79 73 20 74 61 72 67 65 74 yval keys target
b4a0: 29 29 0a 09 20 28 6e 65 77 2d 72 75 6e 2d 69 64 )).. (new-run-id
b4b0: 20 20 20 20 20 20 28 63 64 62 3a 72 65 6d 6f 74 (cdb:remot
b4c0: 65 2d 72 75 6e 20 64 62 3a 72 65 67 69 73 74 65 e-run db:registe
b4d0: 72 2d 72 75 6e 20 23 66 20 6b 65 79 73 20 6b 65 r-run #f keys ke
b4e0: 79 76 61 6c 6c 73 74 20 72 75 6e 6e 61 6d 65 20 yvallst runname
b4f0: 22 6e 65 77 22 20 22 6e 2f 61 22 20 75 73 65 72 "new" "n/a" user
b500: 29 29 0a 09 20 28 70 72 65 76 2d 74 65 73 74 73 )).. (prev-tests
b510: 20 20 20 20 20 20 28 6f 70 65 6e 2d 72 75 6e 2d (open-run-
b520: 63 6c 6f 73 65 20 74 65 73 74 3a 67 65 74 2d 6d close test:get-m
b530: 61 74 63 68 69 6e 67 2d 70 72 65 76 69 6f 75 73 atching-previous
b540: 2d 74 65 73 74 2d 72 75 6e 2d 72 65 63 6f 72 64 -test-run-record
b550: 73 20 64 62 20 6e 65 77 2d 72 75 6e 2d 69 64 20 s db new-run-id
b560: 22 25 22 20 22 25 22 29 29 0a 09 20 28 63 75 72 "%" "%")).. (cur
b570: 72 2d 74 65 73 74 73 20 20 20 20 20 20 28 6f 70 r-tests (op
b580: 65 6e 2d 72 75 6e 2d 63 6c 6f 73 65 20 64 62 3a en-run-close db:
b590: 67 65 74 2d 74 65 73 74 73 2d 66 6f 72 2d 72 75 get-tests-for-ru
b5a0: 6e 20 64 62 20 6e 65 77 2d 72 75 6e 2d 69 64 20 n db new-run-id
b5b0: 22 25 2f 25 22 20 27 28 29 20 27 28 29 29 29 0a "%/%" '() '())).
b5c0: 09 20 28 63 75 72 72 2d 74 65 73 74 73 2d 68 61 . (curr-tests-ha
b5d0: 73 68 20 28 6d 61 6b 65 2d 68 61 73 68 2d 74 61 sh (make-hash-ta
b5e0: 62 6c 65 29 29 29 0a 20 20 20 20 28 6f 70 65 6e ble))). (open
b5f0: 2d 72 75 6e 2d 63 6c 6f 73 65 20 64 62 3a 75 70 -run-close db:up
b600: 64 61 74 65 2d 72 75 6e 2d 65 76 65 6e 74 5f 74 date-run-event_t
b610: 69 6d 65 20 64 62 20 6e 65 77 2d 72 75 6e 2d 69 ime db new-run-i
b620: 64 29 0a 20 20 20 20 3b 3b 20 69 6e 64 65 78 20 d). ;; index
b630: 74 68 65 20 61 6c 72 65 61 64 79 20 73 61 76 65 the already save
b640: 64 20 74 65 73 74 73 20 62 79 20 74 65 73 74 6e d tests by testn
b650: 61 6d 65 20 61 6e 64 20 69 74 65 6d 64 61 74 20 ame and itemdat
b660: 69 6e 20 63 75 72 72 2d 74 65 73 74 73 2d 68 61 in curr-tests-ha
b670: 73 68 0a 20 20 20 20 28 66 6f 72 2d 65 61 63 68 sh. (for-each
b680: 0a 20 20 20 20 20 28 6c 61 6d 62 64 61 20 28 74 . (lambda (t
b690: 65 73 74 64 61 74 29 0a 20 20 20 20 20 20 20 28 estdat). (
b6a0: 6c 65 74 2a 20 28 28 74 65 73 74 6e 61 6d 65 20 let* ((testname
b6b0: 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 74 65 (db:test-get-te
b6c0: 73 74 6e 61 6d 65 20 74 65 73 74 64 61 74 29 29 stname testdat))
b6d0: 0a 09 20 20 20 20 20 20 28 69 74 65 6d 2d 70 61 .. (item-pa
b6e0: 74 68 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d th (db:test-get-
b6f0: 69 74 65 6d 2d 70 61 74 68 20 74 65 73 74 64 61 item-path testda
b700: 74 29 29 0a 09 20 20 20 20 20 20 28 66 75 6c 6c t)).. (full
b710: 2d 6e 61 6d 65 20 28 63 6f 6e 63 20 74 65 73 74 -name (conc test
b720: 6e 61 6d 65 20 22 2f 22 20 69 74 65 6d 2d 70 61 name "/" item-pa
b730: 74 68 29 29 29 0a 09 20 28 68 61 73 68 2d 74 61 th))).. (hash-ta
b740: 62 6c 65 2d 73 65 74 21 20 63 75 72 72 2d 74 65 ble-set! curr-te
b750: 73 74 73 2d 68 61 73 68 20 66 75 6c 6c 2d 6e 61 sts-hash full-na
b760: 6d 65 20 74 65 73 74 64 61 74 29 29 29 0a 20 20 me testdat))).
b770: 20 20 20 63 75 72 72 2d 74 65 73 74 73 29 0a 20 curr-tests).
b780: 20 20 20 3b 3b 20 4e 4f 50 45 3a 20 4e 6f 6e 2d ;; NOPE: Non-
b790: 6f 70 74 69 6d 61 6c 20 61 70 70 72 6f 61 63 68 optimal approach
b7a0: 2e 20 54 72 79 20 74 68 69 73 20 69 6e 73 74 65 . Try this inste
b7b0: 61 64 2e 0a 20 20 20 20 3b 3b 20 20 20 31 2e 20 ad.. ;; 1.
b7c0: 74 65 73 74 73 20 61 72 65 20 72 65 63 65 69 76 tests are receiv
b7d0: 65 64 20 69 6e 20 61 20 6c 69 73 74 2c 20 6d 6f ed in a list, mo
b7e0: 73 74 20 72 65 63 65 6e 74 20 66 69 72 73 74 0a st recent first.
b7f0: 20 20 20 20 3b 3b 20 20 20 32 2e 20 72 65 70 6c ;; 2. repl
b800: 61 63 65 20 74 68 65 20 72 6f 6c 6c 75 70 20 74 ace the rollup t
b810: 65 73 74 20 77 69 74 68 20 74 68 65 20 6e 65 77 est with the new
b820: 20 2a 61 6c 77 61 79 73 2a 0a 20 20 20 20 28 66 *always*. (f
b830: 6f 72 2d 65 61 63 68 20 0a 20 20 20 20 20 28 6c or-each . (l
b840: 61 6d 62 64 61 20 28 74 65 73 74 64 61 74 29 0a ambda (testdat).
b850: 20 20 20 20 20 20 20 28 6c 65 74 2a 20 28 28 74 (let* ((t
b860: 65 73 74 6e 61 6d 65 20 20 28 64 62 3a 74 65 73 estname (db:tes
b870: 74 2d 67 65 74 2d 74 65 73 74 6e 61 6d 65 20 74 t-get-testname t
b880: 65 73 74 64 61 74 29 29 0a 09 20 20 20 20 20 20 estdat))..
b890: 28 69 74 65 6d 2d 70 61 74 68 20 28 64 62 3a 74 (item-path (db:t
b8a0: 65 73 74 2d 67 65 74 2d 69 74 65 6d 2d 70 61 74 est-get-item-pat
b8b0: 68 20 74 65 73 74 64 61 74 29 29 0a 09 20 20 20 h testdat))..
b8c0: 20 20 20 28 66 75 6c 6c 2d 6e 61 6d 65 20 28 63 (full-name (c
b8d0: 6f 6e 63 20 74 65 73 74 6e 61 6d 65 20 22 2f 22 onc testname "/"
b8e0: 20 69 74 65 6d 2d 70 61 74 68 29 29 0a 09 20 20 item-path))..
b8f0: 20 20 20 20 28 70 72 65 76 2d 74 65 73 74 2d 64 (prev-test-d
b900: 61 74 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 at (hash-table-r
b910: 65 66 2f 64 65 66 61 75 6c 74 20 63 75 72 72 2d ef/default curr-
b920: 74 65 73 74 73 2d 68 61 73 68 20 66 75 6c 6c 2d tests-hash full-
b930: 6e 61 6d 65 20 23 66 29 29 0a 09 20 20 20 20 20 name #f))..
b940: 20 28 74 65 73 74 2d 73 74 65 70 73 20 20 20 20 (test-steps
b950: 20 20 28 6f 70 65 6e 2d 72 75 6e 2d 63 6c 6f 73 (open-run-clos
b960: 65 20 64 62 3a 67 65 74 2d 73 74 65 70 73 2d 66 e db:get-steps-f
b970: 6f 72 2d 74 65 73 74 20 64 62 20 28 64 62 3a 74 or-test db (db:t
b980: 65 73 74 2d 67 65 74 2d 69 64 20 74 65 73 74 64 est-get-id testd
b990: 61 74 29 29 29 0a 09 20 20 20 20 20 20 28 6e 65 at))).. (ne
b9a0: 77 2d 74 65 73 74 2d 72 65 63 6f 72 64 20 23 66 w-test-record #f
b9b0: 29 29 0a 09 20 3b 3b 20 72 65 70 6c 61 63 65 20 )).. ;; replace
b9c0: 74 68 65 73 65 20 77 69 74 68 20 69 6e 73 65 72 these with inser
b9d0: 74 20 2e 2e 2e 20 73 65 6c 65 63 74 0a 09 20 28 t ... select.. (
b9e0: 61 70 70 6c 79 20 73 71 6c 69 74 65 33 3a 65 78 apply sqlite3:ex
b9f0: 65 63 75 74 65 20 0a 09 09 64 62 20 0a 09 09 28 ecute ...db ...(
ba00: 63 6f 6e 63 20 22 49 4e 53 45 52 54 20 4f 52 20 conc "INSERT OR
ba10: 52 45 50 4c 41 43 45 20 49 4e 54 4f 20 74 65 73 REPLACE INTO tes
ba20: 74 73 20 28 72 75 6e 5f 69 64 2c 74 65 73 74 6e ts (run_id,testn
ba30: 61 6d 65 2c 73 74 61 74 65 2c 73 74 61 74 75 73 ame,state,status
ba40: 2c 65 76 65 6e 74 5f 74 69 6d 65 2c 68 6f 73 74 ,event_time,host
ba50: 2c 63 70 75 6c 6f 61 64 2c 64 69 73 6b 66 72 65 ,cpuload,diskfre
ba60: 65 2c 75 6e 61 6d 65 2c 72 75 6e 64 69 72 2c 69 e,uname,rundir,i
ba70: 74 65 6d 5f 70 61 74 68 2c 72 75 6e 5f 64 75 72 tem_path,run_dur
ba80: 61 74 69 6f 6e 2c 66 69 6e 61 6c 5f 6c 6f 67 66 ation,final_logf
ba90: 2c 63 6f 6d 6d 65 6e 74 29 20 22 0a 09 09 20 20 ,comment) "...
baa0: 20 20 20 20 22 56 41 4c 55 45 53 20 28 3f 2c 3f "VALUES (?,?
bab0: 2c 3f 2c 3f 2c 3f 2c 3f 2c 3f 2c 3f 2c 3f 2c 3f ,?,?,?,?,?,?,?,?
bac0: 2c 3f 2c 3f 2c 3f 2c 3f 29 3b 22 29 0a 09 09 6e ,?,?,?,?);")...n
bad0: 65 77 2d 72 75 6e 2d 69 64 20 28 63 64 64 72 20 ew-run-id (cddr
bae0: 28 76 65 63 74 6f 72 2d 3e 6c 69 73 74 20 74 65 (vector->list te
baf0: 73 74 64 61 74 29 29 29 0a 09 20 28 73 65 74 21 stdat))).. (set!
bb00: 20 6e 65 77 2d 74 65 73 74 64 61 74 20 28 63 61 new-testdat (ca
bb10: 72 20 28 6f 70 65 6e 2d 72 75 6e 2d 63 6c 6f 73 r (open-run-clos
bb20: 65 20 64 62 3a 67 65 74 2d 74 65 73 74 73 2d 66 e db:get-tests-f
bb30: 6f 72 2d 72 75 6e 20 64 62 20 6e 65 77 2d 72 75 or-run db new-ru
bb40: 6e 2d 69 64 20 28 63 6f 6e 63 20 74 65 73 74 6e n-id (conc testn
bb50: 61 6d 65 20 22 2f 22 20 69 74 65 6d 2d 70 61 74 ame "/" item-pat
bb60: 68 29 20 27 28 29 20 27 28 29 29 29 29 0a 09 20 h) '() '())))..
bb70: 28 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 (hash-table-set!
bb80: 20 63 75 72 72 2d 74 65 73 74 73 2d 68 61 73 68 curr-tests-hash
bb90: 20 66 75 6c 6c 2d 6e 61 6d 65 20 6e 65 77 2d 74 full-name new-t
bba0: 65 73 74 64 61 74 29 20 3b 3b 20 74 68 69 73 20 estdat) ;; this
bbb0: 63 6f 75 6c 64 20 62 65 20 63 6f 6e 66 75 73 69 could be confusi
bbc0: 6e 67 2c 20 77 68 69 63 68 20 72 65 63 6f 72 64 ng, which record
bbd0: 20 73 68 6f 75 6c 64 20 67 6f 20 69 6e 74 6f 20 should go into
bbe0: 74 68 65 20 6c 6f 6f 6b 75 70 20 74 61 62 6c 65 the lookup table
bbf0: 3f 0a 09 20 3b 3b 20 4e 6f 77 20 64 75 70 6c 69 ?.. ;; Now dupli
bc00: 63 61 74 65 20 74 68 65 20 74 65 73 74 20 73 74 cate the test st
bc10: 65 70 73 0a 09 20 28 64 65 62 75 67 3a 70 72 69 eps.. (debug:pri
bc20: 6e 74 20 34 20 22 43 6f 70 79 69 6e 67 20 72 65 nt 4 "Copying re
bc30: 63 6f 72 64 73 20 69 6e 20 74 65 73 74 5f 73 74 cords in test_st
bc40: 65 70 73 20 66 72 6f 6d 20 74 65 73 74 5f 69 64 eps from test_id
bc50: 3d 22 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d =" (db:test-get-
bc60: 69 64 20 74 65 73 74 64 61 74 29 20 22 20 74 6f id testdat) " to
bc70: 20 22 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d " (db:test-get-
bc80: 69 64 20 6e 65 77 2d 74 65 73 74 64 61 74 29 29 id new-testdat))
bc90: 0a 09 20 28 6f 70 65 6e 2d 72 75 6e 2d 63 6c 6f .. (open-run-clo
bca0: 73 65 20 0a 09 20 20 28 6c 61 6d 62 64 61 20 28 se .. (lambda (
bcb0: 29 0a 09 20 20 20 20 28 73 71 6c 69 74 65 33 3a ).. (sqlite3:
bcc0: 65 78 65 63 75 74 65 20 0a 09 20 20 20 20 20 64 execute .. d
bcd0: 62 20 0a 09 20 20 20 20 20 28 63 6f 6e 63 20 22 b .. (conc "
bce0: 49 4e 53 45 52 54 20 4f 52 20 52 45 50 4c 41 43 INSERT OR REPLAC
bcf0: 45 20 49 4e 54 4f 20 74 65 73 74 5f 73 74 65 70 E INTO test_step
bd00: 73 20 28 74 65 73 74 5f 69 64 2c 73 74 65 70 6e s (test_id,stepn
bd10: 61 6d 65 2c 73 74 61 74 65 2c 73 74 61 74 75 73 ame,state,status
bd20: 2c 65 76 65 6e 74 5f 74 69 6d 65 2c 63 6f 6d 6d ,event_time,comm
bd30: 65 6e 74 29 20 22 0a 09 09 20 20 20 22 53 45 4c ent) "... "SEL
bd40: 45 43 54 20 22 20 28 64 62 3a 74 65 73 74 2d 67 ECT " (db:test-g
bd50: 65 74 2d 69 64 20 6e 65 77 2d 74 65 73 74 64 61 et-id new-testda
bd60: 74 29 20 22 2c 73 74 65 70 6e 61 6d 65 2c 73 74 t) ",stepname,st
bd70: 61 74 65 2c 73 74 61 74 75 73 2c 65 76 65 6e 74 ate,status,event
bd80: 5f 74 69 6d 65 2c 63 6f 6d 6d 65 6e 74 20 46 52 _time,comment FR
bd90: 4f 4d 20 74 65 73 74 5f 73 74 65 70 73 20 57 48 OM test_steps WH
bda0: 45 52 45 20 74 65 73 74 5f 69 64 3d 3f 3b 22 29 ERE test_id=?;")
bdb0: 0a 09 20 20 20 20 20 28 64 62 3a 74 65 73 74 2d .. (db:test-
bdc0: 67 65 74 2d 69 64 20 74 65 73 74 64 61 74 29 29 get-id testdat))
bdd0: 0a 09 20 20 20 20 3b 3b 20 4e 6f 77 20 64 75 70 .. ;; Now dup
bde0: 6c 69 63 61 74 65 20 74 68 65 20 74 65 73 74 20 licate the test
bdf0: 64 61 74 61 0a 09 20 20 20 20 28 64 65 62 75 67 data.. (debug
be00: 3a 70 72 69 6e 74 20 34 20 22 43 6f 70 79 69 6e :print 4 "Copyin
be10: 67 20 72 65 63 6f 72 64 73 20 69 6e 20 74 65 73 g records in tes
be20: 74 5f 64 61 74 61 20 66 72 6f 6d 20 74 65 73 74 t_data 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 20 20 20 28 73 71 6c 69 74 65 t)).. (sqlite
be80: 33 3a 65 78 65 63 75 74 65 20 0a 09 20 20 20 20 3:execute ..
be90: 20 64 62 20 0a 09 20 20 20 20 20 28 63 6f 6e 63 db .. (conc
bea0: 20 22 49 4e 53 45 52 54 20 4f 52 20 52 45 50 4c "INSERT OR REPL
beb0: 41 43 45 20 49 4e 54 4f 20 74 65 73 74 5f 64 61 ACE INTO test_da
bec0: 74 61 20 28 74 65 73 74 5f 69 64 2c 63 61 74 65 ta (test_id,cate
bed0: 67 6f 72 79 2c 76 61 72 69 61 62 6c 65 2c 76 61 gory,variable,va
bee0: 6c 75 65 2c 65 78 70 65 63 74 65 64 2c 74 6f 6c lue,expected,tol
bef0: 2c 75 6e 69 74 73 2c 63 6f 6d 6d 65 6e 74 29 20 ,units,comment)
bf00: 22 0a 09 09 20 20 20 22 53 45 4c 45 43 54 20 22 "... "SELECT "
bf10: 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 69 64 (db:test-get-id
bf20: 20 6e 65 77 2d 74 65 73 74 64 61 74 29 20 22 2c new-testdat) ",
bf30: 63 61 74 65 67 6f 72 79 2c 76 61 72 69 61 62 6c category,variabl
bf40: 65 2c 76 61 6c 75 65 2c 65 78 70 65 63 74 65 64 e,value,expected
bf50: 2c 74 6f 6c 2c 75 6e 69 74 73 2c 63 6f 6d 6d 65 ,tol,units,comme
bf60: 6e 74 20 46 52 4f 4d 20 74 65 73 74 5f 64 61 74 nt FROM test_dat
bf70: 61 20 57 48 45 52 45 20 74 65 73 74 5f 69 64 3d a WHERE test_id=
bf80: 3f 3b 22 29 0a 09 20 20 20 20 20 28 64 62 3a 74 ?;").. (db:t
bf90: 65 73 74 2d 67 65 74 2d 69 64 20 74 65 73 74 64 est-get-id testd
bfa0: 61 74 29 29 29 29 0a 09 20 29 29 0a 20 20 20 20 at)))).. )).
bfb0: 20 70 72 65 76 2d 74 65 73 74 73 29 29 29 0a 09 prev-tests)))..
bfc0: 20 0a 20 20 20 20 20 0a . .