0000: 0a 3b 3b 20 43 6f 70 79 72 69 67 68 74 20 32 30 .;; Copyright 20
0010: 30 36 2d 32 30 31 32 2c 20 4d 61 74 74 68 65 77 06-2012, Matthew
0020: 20 57 65 6c 6c 61 6e 64 2e 0a 3b 3b 20 0a 3b 3b Welland..;; .;;
0030: 20 20 54 68 69 73 20 70 72 6f 67 72 61 6d 20 69 This program i
0040: 73 20 6d 61 64 65 20 61 76 61 69 6c 61 62 6c 65 s made available
0050: 20 75 6e 64 65 72 20 74 68 65 20 47 4e 55 20 47 under the GNU G
0060: 50 4c 20 76 65 72 73 69 6f 6e 20 32 2e 30 20 6f PL version 2.0 o
0070: 72 0a 3b 3b 20 20 67 72 65 61 74 65 72 2e 20 53 r.;; greater. S
0080: 65 65 20 74 68 65 20 61 63 63 6f 6d 70 61 6e 79 ee the accompany
0090: 69 6e 67 20 66 69 6c 65 20 43 4f 50 59 49 4e 47 ing file COPYING
00a0: 20 66 6f 72 20 64 65 74 61 69 6c 73 2e 0a 3b 3b for details..;;
00b0: 20 0a 3b 3b 20 20 54 68 69 73 20 70 72 6f 67 72 .;; This progr
00c0: 61 6d 20 69 73 20 64 69 73 74 72 69 62 75 74 65 am is distribute
00d0: 64 20 57 49 54 48 4f 55 54 20 41 4e 59 20 57 41 d WITHOUT ANY WA
00e0: 52 52 41 4e 54 59 3b 20 77 69 74 68 6f 75 74 20 RRANTY; without
00f0: 65 76 65 6e 20 74 68 65 0a 3b 3b 20 20 69 6d 70 even the.;; imp
0100: 6c 69 65 64 20 77 61 72 72 61 6e 74 79 20 6f 66 lied warranty of
0110: 20 4d 45 52 43 48 41 4e 54 41 42 49 4c 49 54 59 MERCHANTABILITY
0120: 20 6f 72 20 46 49 54 4e 45 53 53 20 46 4f 52 20 or FITNESS FOR
0130: 41 20 50 41 52 54 49 43 55 4c 41 52 0a 3b 3b 20 A PARTICULAR.;;
0140: 20 50 55 52 50 4f 53 45 2e 0a 0a 3b 3b 20 20 73 PURPOSE...;; s
0150: 74 72 66 74 69 6d 65 28 27 25 6d 2f 25 64 2f 25 trftime('%m/%d/%
0160: 59 20 25 48 3a 25 4d 3a 25 53 27 2c 27 6e 6f 77 Y %H:%M:%S','now
0170: 27 2c 27 6c 6f 63 61 6c 74 69 6d 65 27 29 0a 0a ','localtime')..
0180: 28 75 73 65 20 73 71 6c 69 74 65 33 20 73 72 66 (use sqlite3 srf
0190: 69 2d 31 20 70 6f 73 69 78 20 72 65 67 65 78 20 i-1 posix regex
01a0: 72 65 67 65 78 2d 63 61 73 65 20 73 72 66 69 2d regex-case srfi-
01b0: 36 39 20 64 6f 74 2d 6c 6f 63 6b 69 6e 67 20 28 69 dot-locking (
01c0: 73 72 66 69 20 31 38 29 20 70 6f 73 69 78 2d 65 srfi 18) posix-e
01d0: 78 74 72 61 73 20 64 69 72 65 63 74 6f 72 79 2d xtras directory-
01e0: 75 74 69 6c 73 29 0a 28 69 6d 70 6f 72 74 20 28 utils).(import (
01f0: 70 72 65 66 69 78 20 73 71 6c 69 74 65 33 20 73 prefix sqlite3 s
0200: 71 6c 69 74 65 33 3a 29 29 0a 0a 28 64 65 63 6c qlite3:))..(decl
0210: 61 72 65 20 28 75 6e 69 74 20 72 75 6e 73 29 29 are (unit runs))
0220: 0a 28 64 65 63 6c 61 72 65 20 28 75 73 65 73 20 .(declare (uses
0230: 64 62 29 29 0a 28 64 65 63 6c 61 72 65 20 28 75 db)).(declare (u
0240: 73 65 73 20 63 6f 6d 6d 6f 6e 29 29 0a 28 64 65 ses common)).(de
0250: 63 6c 61 72 65 20 28 75 73 65 73 20 69 74 65 6d clare (uses item
0260: 73 29 29 0a 28 64 65 63 6c 61 72 65 20 28 75 73 s)).(declare (us
0270: 65 73 20 72 75 6e 63 6f 6e 66 69 67 29 29 0a 28 es runconfig)).(
0280: 64 65 63 6c 61 72 65 20 28 75 73 65 73 20 74 65 declare (uses te
0290: 73 74 73 29 29 0a 28 64 65 63 6c 61 72 65 20 28 sts)).(declare (
02a0: 75 73 65 73 20 73 65 72 76 65 72 29 29 0a 0a 28 uses server))..(
02b0: 69 6e 63 6c 75 64 65 20 22 63 6f 6d 6d 6f 6e 5f include "common_
02c0: 72 65 63 6f 72 64 73 2e 73 63 6d 22 29 0a 28 69 records.scm").(i
02d0: 6e 63 6c 75 64 65 20 22 6b 65 79 5f 72 65 63 6f nclude "key_reco
02e0: 72 64 73 2e 73 63 6d 22 29 0a 28 69 6e 63 6c 75 rds.scm").(inclu
02f0: 64 65 20 22 64 62 5f 72 65 63 6f 72 64 73 2e 73 de "db_records.s
0300: 63 6d 22 29 0a 28 69 6e 63 6c 75 64 65 20 22 72 cm").(include "r
0310: 75 6e 5f 72 65 63 6f 72 64 73 2e 73 63 6d 22 29 un_records.scm")
0320: 0a 28 69 6e 63 6c 75 64 65 20 22 74 65 73 74 5f .(include "test_
0330: 72 65 63 6f 72 64 73 2e 73 63 6d 22 29 0a 0a 3b records.scm")..;
0340: 3b 20 72 75 6e 73 3a 67 65 74 2d 72 75 6e 73 2d ; runs:get-runs-
0350: 62 79 2d 70 61 74 74 0a 3b 3b 20 67 65 74 20 72 by-patt.;; get r
0360: 75 6e 73 20 62 79 20 6c 69 73 74 20 6f 66 20 63 uns by list of c
0370: 72 69 74 65 72 69 61 0a 3b 3b 20 72 65 67 69 73 riteria.;; regis
0380: 74 65 72 20 61 20 74 65 73 74 20 72 75 6e 20 77 ter a test run w
0390: 69 74 68 20 74 68 65 20 64 62 0a 3b 3b 0a 3b 3b ith the db.;;.;;
03a0: 20 55 73 65 3a 20 28 64 62 2d 67 65 74 2d 76 61 Use: (db-get-va
03b0: 6c 75 65 2d 62 79 2d 68 65 61 64 65 72 20 28 64 lue-by-header (d
03c0: 62 3a 67 65 74 2d 68 65 61 64 65 72 20 72 75 6e b:get-header run
03d0: 69 6e 66 6f 29 28 64 62 3a 67 65 74 2d 72 6f 77 info)(db:get-row
03e0: 20 72 75 6e 69 6e 66 6f 29 29 0a 3b 3b 20 20 74 runinfo)).;; t
03f0: 6f 20 65 78 74 72 61 63 74 20 69 6e 66 6f 20 66 o extract info f
0400: 72 6f 6d 20 74 68 65 20 73 74 72 75 63 74 75 72 rom the structur
0410: 65 20 72 65 74 75 72 6e 65 64 0a 3b 3b 0a 28 64 e returned.;;.(d
0420: 65 66 69 6e 65 20 28 72 75 6e 73 3a 67 65 74 2d efine (runs:get-
0430: 72 75 6e 73 2d 62 79 2d 70 61 74 74 20 64 62 20 runs-by-patt db
0440: 6b 65 79 73 20 72 75 6e 6e 61 6d 65 70 61 74 74 keys runnamepatt
0450: 29 20 3b 3b 20 74 65 73 74 2d 6e 61 6d 65 29 0a ) ;; test-name).
0460: 20 20 28 6c 65 74 2a 20 28 28 6b 65 79 76 61 6c (let* ((keyval
0470: 6c 73 74 20 28 6b 65 79 73 2d 3e 76 61 6c 6c 69 lst (keys->valli
0480: 73 74 20 6b 65 79 73 29 29 0a 09 20 28 74 6d 70 st keys)).. (tmp
0490: 20 20 20 20 20 20 28 72 75 6e 73 3a 67 65 74 2d (runs:get-
04a0: 73 74 64 2d 72 75 6e 2d 66 69 65 6c 64 73 20 6b std-run-fields k
04b0: 65 79 73 20 27 28 22 69 64 22 20 22 72 75 6e 6e eys '("id" "runn
04c0: 61 6d 65 22 20 22 73 74 61 74 65 22 20 22 73 74 ame" "state" "st
04d0: 61 74 75 73 22 20 22 6f 77 6e 65 72 22 20 22 65 atus" "owner" "e
04e0: 76 65 6e 74 5f 74 69 6d 65 22 29 29 29 0a 09 20 vent_time")))..
04f0: 28 6b 65 79 73 74 72 20 20 20 28 63 61 72 20 74 (keystr (car t
0500: 6d 70 29 29 0a 09 20 28 68 65 61 64 65 72 20 20 mp)).. (header
0510: 20 28 63 61 64 72 20 74 6d 70 29 29 0a 09 20 28 (cadr tmp)).. (
0520: 72 65 73 20 20 20 20 20 27 28 29 29 0a 09 20 28 res '()).. (
0530: 6b 65 79 2d 70 61 74 74 20 22 22 29 0a 09 20 28 key-patt "").. (
0540: 72 75 6e 77 69 6c 64 74 79 70 65 20 28 69 66 20 runwildtype (if
0550: 28 73 75 62 73 74 72 69 6e 67 2d 69 6e 64 65 78 (substring-index
0560: 20 22 25 22 20 72 75 6e 6e 61 6d 65 70 61 74 74 "%" runnamepatt
0570: 29 20 22 6c 69 6b 65 22 20 22 67 6c 6f 62 22 29 ) "like" "glob")
0580: 29 0a 09 20 28 71 72 79 2d 73 74 72 20 20 23 66 ).. (qry-str #f
0590: 29 29 0a 20 20 20 20 28 66 6f 72 2d 65 61 63 68 )). (for-each
05a0: 20 28 6c 61 6d 62 64 61 20 28 6b 65 79 76 61 6c (lambda (keyval
05b0: 29 0a 09 09 28 6c 65 74 2a 20 28 28 6b 65 79 20 )...(let* ((key
05c0: 20 20 20 28 76 65 63 74 6f 72 2d 72 65 66 20 6b (vector-ref k
05d0: 65 79 76 61 6c 20 30 29 29 0a 09 09 20 20 20 20 eyval 0))...
05e0: 20 20 20 28 66 75 6c 6b 65 79 20 28 63 6f 6e 63 (fulkey (conc
05f0: 20 22 3a 22 20 6b 65 79 29 29 0a 09 09 20 20 20 ":" key))...
0600: 20 20 20 20 28 70 61 74 74 20 20 20 28 61 72 67 (patt (arg
0610: 73 3a 67 65 74 2d 61 72 67 20 66 75 6c 6b 65 79 s:get-arg fulkey
0620: 29 29 0a 09 09 20 20 20 20 20 20 20 28 77 69 6c ))... (wil
0630: 64 74 79 70 65 20 28 69 66 20 28 73 75 62 73 74 dtype (if (subst
0640: 72 69 6e 67 2d 69 6e 64 65 78 20 22 25 22 20 70 ring-index "%" p
0650: 61 74 74 29 20 22 6c 69 6b 65 22 20 22 67 6c 6f att) "like" "glo
0660: 62 22 29 29 29 0a 09 09 20 20 28 69 66 20 70 61 b")))... (if pa
0670: 74 74 0a 09 09 20 20 20 20 20 20 28 73 65 74 21 tt... (set!
0680: 20 6b 65 79 2d 70 61 74 74 20 28 63 6f 6e 63 20 key-patt (conc
0690: 6b 65 79 2d 70 61 74 74 20 22 20 41 4e 44 20 22 key-patt " AND "
06a0: 20 6b 65 79 20 22 20 22 20 77 69 6c 64 74 79 70 key " " wildtyp
06b0: 65 20 22 20 27 22 20 70 61 74 74 20 22 27 22 29 e " '" patt "'")
06c0: 29 0a 09 09 20 20 20 20 20 20 28 62 65 67 69 6e )... (begin
06d0: 0a 09 09 09 28 64 65 62 75 67 3a 70 72 69 6e 74 ....(debug:print
06e0: 20 30 20 22 45 52 52 4f 52 3a 20 73 65 61 72 63 0 "ERROR: searc
06f0: 68 69 6e 67 20 66 6f 72 20 72 75 6e 73 20 77 69 hing for runs wi
0700: 74 68 20 6e 6f 20 70 61 74 74 65 72 6e 20 73 65 th no pattern se
0710: 74 20 66 6f 72 20 22 20 66 75 6c 6b 65 79 29 0a t for " fulkey).
0720: 09 09 09 28 65 78 69 74 20 36 29 29 29 29 29 0a ...(exit 6))))).
0730: 09 20 20 20 20 20 20 6b 65 79 73 29 0a 20 20 20 . keys).
0740: 20 28 73 65 74 21 20 71 72 79 2d 73 74 72 20 28 (set! qry-str (
0750: 63 6f 6e 63 20 22 53 45 4c 45 43 54 20 22 20 6b conc "SELECT " k
0760: 65 79 73 74 72 20 22 20 46 52 4f 4d 20 72 75 6e eystr " FROM run
0770: 73 20 57 48 45 52 45 20 72 75 6e 6e 61 6d 65 20 s WHERE runname
0780: 22 20 72 75 6e 77 69 6c 64 74 79 70 65 20 22 20 " runwildtype "
0790: 3f 20 22 20 6b 65 79 2d 70 61 74 74 20 22 3b 22 ? " key-patt ";"
07a0: 29 29 0a 20 20 20 20 28 64 65 62 75 67 3a 70 72 )). (debug:pr
07b0: 69 6e 74 2d 69 6e 66 6f 20 34 20 22 72 75 6e 73 int-info 4 "runs
07c0: 3a 67 65 74 2d 72 75 6e 73 2d 62 79 2d 70 61 74 :get-runs-by-pat
07d0: 74 20 71 72 79 3d 22 20 71 72 79 2d 73 74 72 20 t qry=" qry-str
07e0: 22 20 22 20 72 75 6e 6e 61 6d 65 70 61 74 74 29 " " runnamepatt)
07f0: 0a 20 20 20 20 28 73 71 6c 69 74 65 33 3a 66 6f . (sqlite3:fo
0800: 72 2d 65 61 63 68 2d 72 6f 77 20 0a 20 20 20 20 r-each-row .
0810: 20 28 6c 61 6d 62 64 61 20 28 61 20 2e 20 72 29 (lambda (a . r)
0820: 0a 20 20 20 20 20 20 20 28 73 65 74 21 20 72 65 . (set! re
0830: 73 20 28 63 6f 6e 73 20 28 6c 69 73 74 2d 3e 76 s (cons (list->v
0840: 65 63 74 6f 72 20 28 63 6f 6e 73 20 61 20 72 29 ector (cons a r)
0850: 29 20 72 65 73 29 29 29 0a 20 20 20 20 20 64 62 ) res))). db
0860: 20 0a 20 20 20 20 20 71 72 79 2d 73 74 72 0a 20 . qry-str.
0870: 20 20 20 20 72 75 6e 6e 61 6d 65 70 61 74 74 29 runnamepatt)
0880: 0a 20 20 20 20 28 76 65 63 74 6f 72 20 68 65 61 . (vector hea
0890: 64 65 72 20 72 65 73 29 29 29 0a 0a 28 64 65 66 der res)))..(def
08a0: 69 6e 65 20 28 72 75 6e 73 3a 74 65 73 74 2d 67 ine (runs:test-g
08b0: 65 74 2d 66 75 6c 6c 2d 70 61 74 68 20 74 65 73 et-full-path tes
08c0: 74 29 0a 20 20 28 6c 65 74 2a 20 28 28 74 65 73 t). (let* ((tes
08d0: 74 6e 61 6d 65 20 28 64 62 3a 74 65 73 74 2d 67 tname (db:test-g
08e0: 65 74 2d 74 65 73 74 6e 61 6d 65 20 20 20 74 65 et-testname te
08f0: 73 74 29 29 0a 09 20 28 69 74 65 6d 70 61 74 68 st)).. (itempath
0900: 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 69 74 (db:test-get-it
0910: 65 6d 2d 70 61 74 68 20 74 65 73 74 29 29 29 0a em-path test))).
0920: 20 20 20 20 28 63 6f 6e 63 20 74 65 73 74 6e 61 (conc testna
0930: 6d 65 20 28 69 66 20 28 65 71 75 61 6c 3f 20 69 me (if (equal? i
0940: 74 65 6d 70 61 74 68 20 22 22 29 20 22 22 20 28 tempath "") "" (
0950: 63 6f 6e 63 20 22 28 22 20 69 74 65 6d 70 61 74 conc "(" itempat
0960: 68 20 22 29 22 29 29 29 29 29 0a 0a 28 64 65 66 h ")")))))..(def
0970: 69 6e 65 20 28 64 62 3a 67 65 74 2d 72 75 6e 2d ine (db:get-run-
0980: 6b 65 79 2d 76 61 6c 20 64 62 20 72 75 6e 2d 69 key-val db run-i
0990: 64 20 6b 65 79 29 0a 20 20 28 6c 65 74 20 28 28 d key). (let ((
09a0: 72 65 73 20 23 66 29 29 0a 20 20 20 20 28 73 71 res #f)). (sq
09b0: 6c 69 74 65 33 3a 66 6f 72 2d 65 61 63 68 2d 72 lite3:for-each-r
09c0: 6f 77 0a 20 20 20 20 20 28 6c 61 6d 62 64 61 20 ow. (lambda
09d0: 28 76 61 6c 29 0a 20 20 20 20 20 20 20 28 73 65 (val). (se
09e0: 74 21 20 72 65 73 20 76 61 6c 29 29 0a 20 20 20 t! res val)).
09f0: 20 20 64 62 20 0a 20 20 20 20 20 28 63 6f 6e 63 db . (conc
0a00: 20 22 53 45 4c 45 43 54 20 22 20 28 6b 65 79 3a "SELECT " (key:
0a10: 67 65 74 2d 66 69 65 6c 64 6e 61 6d 65 20 6b 65 get-fieldname ke
0a20: 79 29 20 22 20 46 52 4f 4d 20 72 75 6e 73 20 57 y) " FROM runs W
0a30: 48 45 52 45 20 69 64 3d 3f 3b 22 29 0a 20 20 20 HERE id=?;").
0a40: 20 20 72 75 6e 2d 69 64 29 0a 20 20 20 20 72 65 run-id). re
0a50: 73 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 64 62 s))..(define (db
0a60: 3a 67 65 74 2d 72 75 6e 2d 6e 61 6d 65 2d 66 72 :get-run-name-fr
0a70: 6f 6d 2d 69 64 20 64 62 20 72 75 6e 2d 69 64 29 om-id db run-id)
0a80: 0a 20 20 28 6c 65 74 20 28 28 72 65 73 20 23 66 . (let ((res #f
0a90: 29 29 0a 20 20 20 20 28 73 71 6c 69 74 65 33 3a )). (sqlite3:
0aa0: 66 6f 72 2d 65 61 63 68 2d 72 6f 77 0a 20 20 20 for-each-row.
0ab0: 20 20 28 6c 61 6d 62 64 61 20 28 72 75 6e 6e 61 (lambda (runna
0ac0: 6d 65 29 0a 20 20 20 20 20 20 20 28 73 65 74 21 me). (set!
0ad0: 20 72 65 73 20 72 75 6e 6e 61 6d 65 29 29 0a 20 res runname)).
0ae0: 20 20 20 20 64 62 0a 20 20 20 20 20 22 53 45 4c db. "SEL
0af0: 45 43 54 20 72 75 6e 6e 61 6d 65 20 46 52 4f 4d ECT runname FROM
0b00: 20 72 75 6e 73 20 57 48 45 52 45 20 69 64 3d 3f runs WHERE id=?
0b10: 3b 22 0a 20 20 20 20 20 72 75 6e 2d 69 64 29 0a ;". run-id).
0b20: 20 20 20 20 72 65 73 29 29 0a 0a 28 64 65 66 69 res))..(defi
0b30: 6e 65 20 28 73 65 74 2d 6d 65 67 61 74 65 73 74 ne (set-megatest
0b40: 2d 65 6e 76 2d 76 61 72 73 20 72 75 6e 2d 69 64 -env-vars run-id
0b50: 29 0a 20 20 28 6c 65 74 20 28 28 6b 65 79 73 20 ). (let ((keys
0b60: 28 63 64 62 3a 72 65 6d 6f 74 65 2d 72 75 6e 20 (cdb:remote-run
0b70: 64 62 3a 67 65 74 2d 6b 65 79 73 20 23 66 29 29 db:get-keys #f))
0b80: 0a 09 28 76 61 6c 73 20 28 68 61 73 68 2d 74 61 ..(vals (hash-ta
0b90: 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 ble-ref/default
0ba0: 2a 65 6e 76 2d 76 61 72 73 2d 62 79 2d 72 75 6e *env-vars-by-run
0bb0: 2d 69 64 2a 20 72 75 6e 2d 69 64 20 23 66 29 29 -id* run-id #f))
0bc0: 29 0a 20 20 20 20 3b 3b 20 67 65 74 20 74 68 65 ). ;; get the
0bd0: 20 69 6e 66 6f 20 66 72 6f 6d 20 74 68 65 20 64 info from the d
0be0: 62 20 61 6e 64 20 70 75 74 20 69 74 20 69 6e 20 b and put it in
0bf0: 74 68 65 20 63 61 63 68 65 0a 20 20 20 20 28 69 the cache. (i
0c00: 66 20 28 6e 6f 74 20 76 61 6c 73 29 0a 09 28 6c f (not vals)..(l
0c10: 65 74 20 28 28 68 74 20 28 6d 61 6b 65 2d 68 61 et ((ht (make-ha
0c20: 73 68 2d 74 61 62 6c 65 29 29 29 0a 09 20 20 28 sh-table))).. (
0c30: 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 hash-table-set!
0c40: 2a 65 6e 76 2d 76 61 72 73 2d 62 79 2d 72 75 6e *env-vars-by-run
0c50: 2d 69 64 2a 20 72 75 6e 2d 69 64 20 68 74 29 0a -id* run-id ht).
0c60: 09 20 20 28 73 65 74 21 20 76 61 6c 73 20 68 74 . (set! vals ht
0c70: 29 0a 09 20 20 28 66 6f 72 2d 65 61 63 68 0a 09 ).. (for-each..
0c80: 20 20 20 28 6c 61 6d 62 64 61 20 28 6b 65 79 29 (lambda (key)
0c90: 0a 09 20 20 20 20 20 28 68 61 73 68 2d 74 61 62 .. (hash-tab
0ca0: 6c 65 2d 73 65 74 21 20 76 61 6c 73 20 6b 65 79 le-set! vals key
0cb0: 20 28 63 64 62 3a 72 65 6d 6f 74 65 2d 72 75 6e (cdb:remote-run
0cc0: 20 64 62 3a 67 65 74 2d 72 75 6e 2d 6b 65 79 2d db:get-run-key-
0cd0: 76 61 6c 20 23 66 20 72 75 6e 2d 69 64 20 6b 65 val #f run-id ke
0ce0: 79 29 29 29 0a 09 20 20 20 6b 65 79 73 29 29 29 y))).. keys)))
0cf0: 0a 20 20 20 20 3b 3b 20 66 72 6f 6d 20 74 68 65 . ;; from the
0d00: 20 63 61 63 68 65 64 20 64 61 74 61 20 73 65 74 cached data set
0d10: 20 74 68 65 20 76 61 72 73 0a 20 20 20 20 28 68 the vars. (h
0d20: 61 73 68 2d 74 61 62 6c 65 2d 66 6f 72 2d 65 61 ash-table-for-ea
0d30: 63 68 0a 20 20 20 20 20 76 61 6c 73 0a 20 20 20 ch. vals.
0d40: 20 20 28 6c 61 6d 62 64 61 20 28 6b 65 79 20 76 (lambda (key v
0d50: 61 6c 29 0a 20 20 20 20 20 20 20 28 64 65 62 75 al). (debu
0d60: 67 3a 70 72 69 6e 74 20 32 20 22 73 65 74 65 6e g:print 2 "seten
0d70: 76 20 22 20 28 6b 65 79 3a 67 65 74 2d 66 69 65 v " (key:get-fie
0d80: 6c 64 6e 61 6d 65 20 6b 65 79 29 20 22 20 22 20 ldname key) " "
0d90: 76 61 6c 29 0a 20 20 20 20 20 20 20 28 73 65 74 val). (set
0da0: 65 6e 76 20 28 6b 65 79 3a 67 65 74 2d 66 69 65 env (key:get-fie
0db0: 6c 64 6e 61 6d 65 20 6b 65 79 29 20 76 61 6c 29 ldname key) val)
0dc0: 29 29 0a 20 20 20 20 28 61 6c 69 73 74 2d 3e 65 )). (alist->e
0dd0: 6e 76 2d 76 61 72 73 20 28 68 61 73 68 2d 74 61 nv-vars (hash-ta
0de0: 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 ble-ref/default
0df0: 2a 63 6f 6e 66 69 67 64 61 74 2a 20 22 65 6e 76 *configdat* "env
0e00: 2d 6f 76 65 72 72 69 64 65 22 20 27 28 29 29 29 -override" '()))
0e10: 0a 20 20 20 20 3b 3b 20 4c 65 74 73 20 75 73 65 . ;; Lets use
0e20: 20 74 68 69 73 20 61 73 20 61 6e 20 6f 70 70 6f this as an oppo
0e30: 72 74 75 6e 69 74 79 20 74 6f 20 70 75 74 20 4d rtunity to put M
0e40: 54 5f 52 55 4e 4e 41 4d 45 20 69 6e 20 74 68 65 T_RUNNAME in the
0e50: 20 65 6e 76 69 72 6f 6e 6d 65 6e 74 0a 20 20 20 environment.
0e60: 20 28 73 65 74 65 6e 76 20 22 4d 54 5f 52 55 4e (setenv "MT_RUN
0e70: 4e 41 4d 45 22 20 28 63 64 62 3a 72 65 6d 6f 74 NAME" (cdb:remot
0e80: 65 2d 72 75 6e 20 64 62 3a 67 65 74 2d 72 75 6e e-run db:get-run
0e90: 2d 6e 61 6d 65 2d 66 72 6f 6d 2d 69 64 20 23 66 -name-from-id #f
0ea0: 20 72 75 6e 2d 69 64 29 29 0a 20 20 20 20 28 73 run-id)). (s
0eb0: 65 74 65 6e 76 20 22 4d 54 5f 52 55 4e 5f 41 52 etenv "MT_RUN_AR
0ec0: 45 41 5f 48 4f 4d 45 22 20 2a 74 6f 70 70 61 74 EA_HOME" *toppat
0ed0: 68 2a 29 0a 20 20 20 20 29 29 0a 0a 28 64 65 66 h*). ))..(def
0ee0: 69 6e 65 20 28 73 65 74 2d 69 74 65 6d 2d 65 6e ine (set-item-en
0ef0: 76 2d 76 61 72 73 20 69 74 65 6d 64 61 74 29 0a v-vars itemdat).
0f00: 20 20 28 66 6f 72 2d 65 61 63 68 20 28 6c 61 6d (for-each (lam
0f10: 62 64 61 20 28 69 74 65 6d 29 0a 09 20 20 20 20 bda (item)..
0f20: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 32 (debug:print 2
0f30: 20 22 73 65 74 65 6e 76 20 22 20 28 63 61 72 20 "setenv " (car
0f40: 69 74 65 6d 29 20 22 20 22 20 28 63 61 64 72 20 item) " " (cadr
0f50: 69 74 65 6d 29 29 0a 09 20 20 20 20 20 20 28 73 item)).. (s
0f60: 65 74 65 6e 76 20 28 63 61 72 20 69 74 65 6d 29 etenv (car item)
0f70: 20 28 63 61 64 72 20 69 74 65 6d 29 29 29 0a 09 (cadr item)))..
0f80: 20 20 20 20 69 74 65 6d 64 61 74 29 29 0a 0a 28 itemdat))..(
0f90: 64 65 66 69 6e 65 20 2a 6c 61 73 74 2d 6e 75 6d define *last-num
0fa0: 2d 72 75 6e 6e 69 6e 67 2d 74 65 73 74 73 2a 20 -running-tests*
0fb0: 30 29 0a 28 64 65 66 69 6e 65 20 2a 72 75 6e 73 0).(define *runs
0fc0: 3a 63 61 6e 2d 72 75 6e 2d 6d 6f 72 65 2d 74 65 :can-run-more-te
0fd0: 73 74 73 2d 64 65 6c 61 79 2a 20 30 29 0a 28 64 sts-delay* 0).(d
0fe0: 65 66 69 6e 65 20 28 72 75 6e 73 3a 73 68 72 69 efine (runs:shri
0ff0: 6e 6b 2d 63 61 6e 2d 72 75 6e 2d 6d 6f 72 65 2d nk-can-run-more-
1000: 74 65 73 74 73 2d 64 65 6c 61 79 29 0a 20 20 28 tests-delay). (
1010: 73 65 74 21 20 2a 72 75 6e 73 3a 63 61 6e 2d 72 set! *runs:can-r
1020: 75 6e 2d 6d 6f 72 65 2d 74 65 73 74 73 2d 64 65 un-more-tests-de
1030: 6c 61 79 2a 20 30 29 29 20 3b 3b 20 28 2f 20 2a lay* 0)) ;; (/ *
1040: 72 75 6e 73 3a 63 61 6e 2d 72 75 6e 2d 6d 6f 72 runs:can-run-mor
1050: 65 2d 74 65 73 74 73 2d 64 65 6c 61 79 2a 20 32 e-tests-delay* 2
1060: 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 72 75 )))..(define (ru
1070: 6e 73 3a 63 61 6e 2d 72 75 6e 2d 6d 6f 72 65 2d ns:can-run-more-
1080: 74 65 73 74 73 20 74 65 73 74 2d 72 65 63 6f 72 tests test-recor
1090: 64 29 0a 20 20 28 74 68 72 65 61 64 2d 73 6c 65 d). (thread-sle
10a0: 65 70 21 20 2a 72 75 6e 73 3a 63 61 6e 2d 72 75 ep! *runs:can-ru
10b0: 6e 2d 6d 6f 72 65 2d 74 65 73 74 73 2d 64 65 6c n-more-tests-del
10c0: 61 79 2a 29 0a 20 20 28 6c 65 74 2a 20 28 28 74 ay*). (let* ((t
10d0: 63 6f 6e 66 69 67 20 20 20 20 20 20 20 20 20 20 config
10e0: 20 20 20 20 20 20 20 28 74 65 73 74 73 3a 74 65 (tests:te
10f0: 73 74 71 75 65 75 65 2d 67 65 74 2d 74 65 73 74 stqueue-get-test
1100: 63 6f 6e 66 69 67 20 74 65 73 74 2d 72 65 63 6f config test-reco
1110: 72 64 29 29 0a 09 20 28 6a 6f 62 67 72 6f 75 70 rd)).. (jobgroup
1120: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1130: 28 63 6f 6e 66 69 67 2d 6c 6f 6f 6b 75 70 20 74 (config-lookup t
1140: 63 6f 6e 66 69 67 20 22 72 65 71 75 69 72 65 6d config "requirem
1150: 65 6e 74 73 22 20 22 6a 6f 62 67 72 6f 75 70 22 ents" "jobgroup"
1160: 29 29 0a 09 20 3b 3b 20 48 65 75 72 69 73 74 69 )).. ;; Heuristi
1170: 63 20 66 69 78 2e 20 54 68 65 73 65 20 61 72 65 c fix. These are
1180: 20 67 65 74 74 69 6e 67 20 63 61 6c 6c 65 64 20 getting called
1190: 74 6f 6f 20 72 61 70 69 64 6c 79 20 77 68 65 6e too rapidly when
11a0: 20 6a 6f 62 73 20 61 72 65 20 72 75 6e 6e 69 6e jobs are runnin
11b0: 67 20 6f 72 20 73 74 75 63 6b 0a 09 20 3b 3b 20 g or stuck.. ;;
11c0: 73 6f 20 77 65 20 61 72 65 20 67 6f 69 6e 67 20 so we are going
11d0: 74 6f 20 69 6e 63 72 65 6d 65 6e 74 20 61 20 67 to increment a g
11e0: 6c 6f 62 61 6c 20 64 65 6c 61 79 20 62 79 20 30 lobal delay by 0
11f0: 2e 31 20 73 65 63 6f 6e 64 73 20 75 70 20 74 6f .1 seconds up to
1200: 20 31 30 20 73 65 63 6f 6e 64 73 0a 09 20 3b 3b 10 seconds.. ;;
1210: 20 65 76 65 72 79 20 74 69 6d 65 20 72 75 6e 73 every time runs
1220: 3a 63 61 6e 2d 72 75 6e 2d 6d 6f 72 65 2d 74 65 :can-run-more-te
1230: 73 74 73 20 69 73 20 63 61 6c 6c 65 64 2e 0a 09 sts is called...
1240: 20 3b 3b 20 77 68 65 6e 20 61 20 74 65 73 74 20 ;; when a test
1250: 69 73 20 6c 61 75 6e 63 68 65 64 20 6f 72 20 6f is launched or o
1260: 74 68 65 72 20 61 63 74 69 76 69 74 79 20 6f 63 ther activity oc
1270: 63 75 72 73 20 64 69 76 69 64 65 20 74 68 65 20 curs divide the
1280: 64 65 6c 61 79 20 62 79 20 32 0a 09 20 28 6e 75 delay by 2.. (nu
1290: 6d 2d 72 75 6e 6e 69 6e 67 20 20 20 20 20 20 20 m-running
12a0: 20 20 20 20 20 20 28 63 64 62 3a 72 65 6d 6f 74 (cdb:remot
12b0: 65 2d 72 75 6e 20 64 62 3a 67 65 74 2d 63 6f 75 e-run db:get-cou
12c0: 6e 74 2d 74 65 73 74 73 2d 72 75 6e 6e 69 6e 67 nt-tests-running
12d0: 20 23 66 29 29 0a 09 20 28 6e 75 6d 2d 72 75 6e #f)).. (num-run
12e0: 6e 69 6e 67 2d 69 6e 2d 6a 6f 62 67 72 6f 75 70 ning-in-jobgroup
12f0: 20 28 63 64 62 3a 72 65 6d 6f 74 65 2d 72 75 6e (cdb:remote-run
1300: 20 64 62 3a 67 65 74 2d 63 6f 75 6e 74 2d 74 65 db:get-count-te
1310: 73 74 73 2d 72 75 6e 6e 69 6e 67 2d 69 6e 2d 6a sts-running-in-j
1320: 6f 62 67 72 6f 75 70 20 23 66 20 6a 6f 62 67 72 obgroup #f jobgr
1330: 6f 75 70 29 29 0a 09 20 28 6d 61 78 2d 63 6f 6e oup)).. (max-con
1340: 63 75 72 72 65 6e 74 2d 6a 6f 62 73 20 20 20 20 current-jobs
1350: 20 28 6c 65 74 20 28 28 6d 63 6a 20 28 63 6f 6e (let ((mcj (con
1360: 66 69 67 2d 6c 6f 6f 6b 75 70 20 2a 63 6f 6e 66 fig-lookup *conf
1370: 69 67 64 61 74 2a 20 22 73 65 74 75 70 22 20 20 igdat* "setup"
1380: 20 20 20 22 6d 61 78 5f 63 6f 6e 63 75 72 72 65 "max_concurre
1390: 6e 74 5f 6a 6f 62 73 22 29 29 29 0a 09 09 09 09 nt_jobs"))).....
13a0: 20 20 20 20 28 69 66 20 28 61 6e 64 20 6d 63 6a (if (and mcj
13b0: 20 28 73 74 72 69 6e 67 2d 3e 6e 75 6d 62 65 72 (string->number
13c0: 20 6d 63 6a 29 29 0a 09 09 09 09 09 28 73 74 72 mcj))......(str
13d0: 69 6e 67 2d 3e 6e 75 6d 62 65 72 20 6d 63 6a 29 ing->number mcj)
13e0: 0a 09 09 09 09 09 31 29 29 29 0a 09 20 28 6a 6f ......1))).. (jo
13f0: 62 2d 67 72 6f 75 70 2d 6c 69 6d 69 74 20 20 20 b-group-limit
1400: 20 20 20 20 20 20 28 63 6f 6e 66 69 67 2d 6c 6f (config-lo
1410: 6f 6b 75 70 20 2a 63 6f 6e 66 69 67 64 61 74 2a okup *configdat*
1420: 20 22 6a 6f 62 67 72 6f 75 70 73 22 20 6a 6f 62 "jobgroups" job
1430: 67 72 6f 75 70 29 29 29 0a 20 20 20 20 28 69 66 group))). (if
1440: 20 28 61 6e 64 20 28 3e 20 28 2b 20 6e 75 6d 2d (and (> (+ num-
1450: 72 75 6e 6e 69 6e 67 20 6e 75 6d 2d 72 75 6e 6e running num-runn
1460: 69 6e 67 2d 69 6e 2d 6a 6f 62 67 72 6f 75 70 29 ing-in-jobgroup)
1470: 20 30 29 0a 09 20 20 20 20 20 28 3c 20 2a 72 75 0).. (< *ru
1480: 6e 73 3a 63 61 6e 2d 72 75 6e 2d 6d 6f 72 65 2d ns:can-run-more-
1490: 74 65 73 74 73 2d 64 65 6c 61 79 2a 20 31 29 29 tests-delay* 1))
14a0: 0a 09 28 62 65 67 69 6e 0a 09 20 20 28 73 65 74 ..(begin.. (set
14b0: 21 20 2a 72 75 6e 73 3a 63 61 6e 2d 72 75 6e 2d ! *runs:can-run-
14c0: 6d 6f 72 65 2d 74 65 73 74 73 2d 64 65 6c 61 79 more-tests-delay
14d0: 2a 20 28 2b 20 2a 72 75 6e 73 3a 63 61 6e 2d 72 * (+ *runs:can-r
14e0: 75 6e 2d 6d 6f 72 65 2d 74 65 73 74 73 2d 64 65 un-more-tests-de
14f0: 6c 61 79 2a 20 30 2e 30 30 39 29 29 0a 09 20 20 lay* 0.009))..
1500: 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 (debug:print-inf
1510: 6f 20 31 34 20 22 63 61 6e 2d 72 75 6e 2d 6d 6f o 14 "can-run-mo
1520: 72 65 2d 74 65 73 74 73 2d 64 65 6c 61 79 3a 20 re-tests-delay:
1530: 22 20 2a 72 75 6e 73 3a 63 61 6e 2d 72 75 6e 2d " *runs:can-run-
1540: 6d 6f 72 65 2d 74 65 73 74 73 2d 64 65 6c 61 79 more-tests-delay
1550: 2a 29 29 29 0a 20 20 20 20 28 69 66 20 28 6e 6f *))). (if (no
1560: 74 20 28 65 71 3f 20 2a 6c 61 73 74 2d 6e 75 6d t (eq? *last-num
1570: 2d 72 75 6e 6e 69 6e 67 2d 74 65 73 74 73 2a 20 -running-tests*
1580: 6e 75 6d 2d 72 75 6e 6e 69 6e 67 29 29 0a 09 28 num-running))..(
1590: 62 65 67 69 6e 0a 09 20 20 28 64 65 62 75 67 3a begin.. (debug:
15a0: 70 72 69 6e 74 20 32 20 22 6d 61 78 2d 63 6f 6e print 2 "max-con
15b0: 63 75 72 72 65 6e 74 2d 6a 6f 62 73 3a 20 22 20 current-jobs: "
15c0: 6d 61 78 2d 63 6f 6e 63 75 72 72 65 6e 74 2d 6a max-concurrent-j
15d0: 6f 62 73 20 22 2c 20 6e 75 6d 2d 72 75 6e 6e 69 obs ", num-runni
15e0: 6e 67 3a 20 22 20 6e 75 6d 2d 72 75 6e 6e 69 6e ng: " num-runnin
15f0: 67 29 0a 09 20 20 28 73 65 74 21 20 2a 6c 61 73 g).. (set! *las
1600: 74 2d 6e 75 6d 2d 72 75 6e 6e 69 6e 67 2d 74 65 t-num-running-te
1610: 73 74 73 2a 20 6e 75 6d 2d 72 75 6e 6e 69 6e 67 sts* num-running
1620: 29 29 29 0a 20 20 20 20 28 69 66 20 28 6e 6f 74 ))). (if (not
1630: 20 28 65 71 3f 20 30 20 2a 67 6c 6f 62 61 6c 65 (eq? 0 *globale
1640: 78 69 74 73 74 61 74 75 73 2a 29 29 0a 09 28 6c xitstatus*))..(l
1650: 69 73 74 20 23 66 20 6e 75 6d 2d 72 75 6e 6e 69 ist #f num-runni
1660: 6e 67 20 6e 75 6d 2d 72 75 6e 6e 69 6e 67 2d 69 ng num-running-i
1670: 6e 2d 6a 6f 62 67 72 6f 75 70 20 6d 61 78 2d 63 n-jobgroup max-c
1680: 6f 6e 63 75 72 72 65 6e 74 2d 6a 6f 62 73 20 6a oncurrent-jobs j
1690: 6f 62 2d 67 72 6f 75 70 2d 6c 69 6d 69 74 29 0a ob-group-limit).
16a0: 09 28 6c 65 74 20 28 28 63 61 6e 2d 6e 6f 74 2d .(let ((can-not-
16b0: 72 75 6e 2d 6d 6f 72 65 20 28 63 6f 6e 64 0a 09 run-more (cond..
16c0: 09 09 09 20 3b 3b 20 69 66 20 6d 61 78 2d 63 6f ... ;; if max-co
16d0: 6e 63 75 72 72 65 6e 74 2d 6a 6f 62 73 20 69 73 ncurrent-jobs is
16e0: 20 73 65 74 20 61 6e 64 20 74 68 65 20 6e 75 6d set and the num
16f0: 62 65 72 20 72 75 6e 6e 69 6e 67 20 69 73 20 67 ber running is g
1700: 72 65 61 74 65 72 20 0a 09 09 09 09 20 3b 3b 20 reater ..... ;;
1710: 74 68 61 6e 20 69 74 20 74 68 61 6e 20 63 61 6e than it than can
1720: 6e 6f 74 20 72 75 6e 20 6d 6f 72 65 20 6a 6f 62 not run more job
1730: 73 0a 09 09 09 09 20 28 28 61 6e 64 20 6d 61 78 s..... ((and max
1740: 2d 63 6f 6e 63 75 72 72 65 6e 74 2d 6a 6f 62 73 -concurrent-jobs
1750: 20 28 3e 3d 20 6e 75 6d 2d 72 75 6e 6e 69 6e 67 (>= num-running
1760: 20 6d 61 78 2d 63 6f 6e 63 75 72 72 65 6e 74 2d max-concurrent-
1770: 6a 6f 62 73 29 29 0a 09 09 09 09 20 20 28 64 65 jobs))..... (de
1780: 62 75 67 3a 70 72 69 6e 74 20 30 20 22 57 41 52 bug:print 0 "WAR
1790: 4e 49 4e 47 3a 20 4d 61 78 20 72 75 6e 6e 69 6e NING: Max runnin
17a0: 67 20 6a 6f 62 73 20 65 78 63 65 65 64 65 64 2c g jobs exceeded,
17b0: 20 63 75 72 72 65 6e 74 20 6e 75 6d 62 65 72 20 current number
17c0: 72 75 6e 6e 69 6e 67 3a 20 22 20 6e 75 6d 2d 72 running: " num-r
17d0: 75 6e 6e 69 6e 67 20 0a 09 09 09 09 09 20 20 20 unning ......
17e0: 20 20 20 20 22 2c 20 6d 61 78 5f 63 6f 6e 63 75 ", max_concu
17f0: 72 72 65 6e 74 5f 6a 6f 62 73 3a 20 22 20 6d 61 rrent_jobs: " ma
1800: 78 2d 63 6f 6e 63 75 72 72 65 6e 74 2d 6a 6f 62 x-concurrent-job
1810: 73 29 0a 09 09 09 09 20 20 23 74 29 0a 09 09 09 s)..... #t)....
1820: 09 20 3b 3b 20 69 66 20 6a 6f 62 2d 67 72 6f 75 . ;; if job-grou
1830: 70 2d 6c 69 6d 69 74 20 69 73 20 73 65 74 20 61 p-limit is set a
1840: 6e 64 20 6e 75 6d 62 65 72 20 6f 66 20 6a 6f 62 nd number of job
1850: 73 20 69 6e 20 74 68 65 20 67 72 6f 75 70 20 69 s in the group i
1860: 73 20 67 72 65 61 74 65 72 0a 09 09 09 09 20 3b s greater..... ;
1870: 3b 20 74 68 61 6e 20 74 68 65 20 6c 69 6d 69 74 ; than the limit
1880: 20 74 68 65 6e 20 63 61 6e 6e 6f 74 20 72 75 6e then cannot run
1890: 20 6d 6f 72 65 20 6a 6f 62 73 20 6f 66 20 74 68 more jobs of th
18a0: 69 73 20 6b 69 6e 64 0a 09 09 09 09 20 28 28 61 is kind..... ((a
18b0: 6e 64 20 6a 6f 62 2d 67 72 6f 75 70 2d 6c 69 6d nd job-group-lim
18c0: 69 74 0a 09 09 09 09 20 20 20 20 20 20 20 28 3e it..... (>
18d0: 3d 20 6e 75 6d 2d 72 75 6e 6e 69 6e 67 2d 69 6e = num-running-in
18e0: 2d 6a 6f 62 67 72 6f 75 70 20 6a 6f 62 2d 67 72 -jobgroup job-gr
18f0: 6f 75 70 2d 6c 69 6d 69 74 29 29 0a 09 09 09 09 oup-limit)).....
1900: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 31 (debug:print 1
1910: 20 22 57 41 52 4e 49 4e 47 3a 20 6e 75 6d 62 65 "WARNING: numbe
1920: 72 20 6f 66 20 6a 6f 62 73 20 22 20 6e 75 6d 2d r of jobs " num-
1930: 72 75 6e 6e 69 6e 67 2d 69 6e 2d 6a 6f 62 67 72 running-in-jobgr
1940: 6f 75 70 20 0a 09 09 09 09 09 20 20 20 20 20 20 oup ......
1950: 20 22 20 69 6e 20 22 20 6a 6f 62 67 72 6f 75 70 " in " jobgroup
1960: 20 22 20 65 78 63 65 65 64 65 64 2c 20 77 69 6c " exceeded, wil
1970: 6c 20 6e 6f 74 20 72 75 6e 20 22 20 28 74 65 73 l not run " (tes
1980: 74 73 3a 74 65 73 74 71 75 65 75 65 2d 67 65 74 ts:testqueue-get
1990: 2d 74 65 73 74 6e 61 6d 65 20 74 65 73 74 2d 72 -testname test-r
19a0: 65 63 6f 72 64 29 29 0a 09 09 09 09 20 20 23 74 ecord))..... #t
19b0: 29 0a 09 09 09 09 20 28 65 6c 73 65 20 23 66 29 )..... (else #f)
19c0: 29 29 29 0a 09 20 20 28 6c 69 73 74 20 28 6e 6f ))).. (list (no
19d0: 74 20 63 61 6e 2d 6e 6f 74 2d 72 75 6e 2d 6d 6f t can-not-run-mo
19e0: 72 65 29 20 6e 75 6d 2d 72 75 6e 6e 69 6e 67 20 re) num-running
19f0: 6e 75 6d 2d 72 75 6e 6e 69 6e 67 2d 69 6e 2d 6a num-running-in-j
1a00: 6f 62 67 72 6f 75 70 20 6d 61 78 2d 63 6f 6e 63 obgroup max-conc
1a10: 75 72 72 65 6e 74 2d 6a 6f 62 73 20 6a 6f 62 2d urrent-jobs job-
1a20: 67 72 6f 75 70 2d 6c 69 6d 69 74 29 29 29 29 29 group-limit)))))
1a30: 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ..;;============
1a40: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1a50: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1a60: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1a70: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 4e 65 ==========.;; Ne
1a80: 77 20 6d 65 74 68 6f 64 6f 6c 6f 67 79 2e 20 54 w methodology. T
1a90: 68 65 73 65 20 72 6f 75 74 69 6e 65 73 20 77 69 hese routines wi
1aa0: 6c 6c 20 72 65 70 6c 61 63 65 20 74 68 65 20 61 ll replace the a
1ab0: 62 6f 76 65 20 69 6e 20 74 69 6d 65 2e 20 46 6f bove in time. Fo
1ac0: 72 0a 3b 3b 20 6e 6f 77 20 74 68 65 20 63 6f 64 r.;; now the cod
1ad0: 65 20 69 73 20 64 75 70 6c 69 63 61 74 65 64 2e e is duplicated.
1ae0: 20 54 68 69 73 20 73 74 75 66 66 20 69 73 20 69 This stuff is i
1af0: 6e 69 74 69 61 6c 6c 79 20 75 73 65 64 20 69 6e nitially used in
1b00: 20 74 68 65 20 6d 6f 6e 69 74 6f 72 0a 3b 3b 20 the monitor.;;
1b10: 62 61 73 65 64 20 63 6f 64 65 2e 0a 3b 3b 3d 3d based code..;;==
1b20: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1b30: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1b40: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1b50: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1b60: 3d 3d 3d 3d 0a 0a 0a 3b 3b 20 54 68 69 73 20 69 ====...;; This i
1b70: 73 20 61 20 64 75 70 6c 69 63 61 74 65 20 6f 66 s a duplicate of
1b80: 20 72 75 6e 2d 74 65 73 74 73 20 28 77 68 69 63 run-tests (whic
1b90: 68 20 68 61 73 20 62 65 65 6e 20 64 65 70 72 65 h has been depre
1ba0: 63 61 74 65 64 29 2e 20 55 73 65 20 74 68 69 73 cated). Use this
1bb0: 20 6f 6e 65 20 69 6e 73 74 65 61 64 20 6f 66 20 one instead of
1bc0: 72 75 6e 20 74 65 73 74 73 2e 0a 3b 3b 20 6b 65 run tests..;; ke
1bd0: 79 76 61 6c 73 2e 0a 3b 3b 0a 3b 3b 20 20 74 65 yvals..;;.;; te
1be0: 73 74 2d 6e 61 6d 65 73 3a 20 43 6f 6d 6d 61 20 st-names: Comma
1bf0: 73 65 70 61 72 61 74 65 64 20 70 61 74 74 65 72 separated patter
1c00: 6e 73 20 73 61 6d 65 20 61 73 20 74 65 73 74 2d ns same as test-
1c10: 70 61 74 74 73 20 62 75 74 20 75 73 65 64 20 69 patts but used i
1c20: 6e 20 73 65 6c 65 63 74 69 6f 6e 20 0a 3b 3b 20 n selection .;;
1c30: 20 20 20 20 20 20 20 20 20 20 20 20 20 6f 66 20 of
1c40: 74 65 73 74 73 20 74 6f 20 72 75 6e 2e 20 54 68 tests to run. Th
1c50: 65 20 69 74 65 6d 20 70 6f 72 74 69 6f 6e 73 20 e item portions
1c60: 61 72 65 20 6e 6f 74 20 72 65 73 70 65 63 74 65 are not respecte
1c70: 64 2e 0a 3b 3b 20 20 20 20 20 20 20 20 20 20 20 d..;;
1c80: 20 20 20 46 49 58 4d 45 3a 20 65 72 72 6f 72 20 FIXME: error
1c90: 6f 75 74 20 69 66 20 2f 70 61 74 74 20 73 70 65 out if /patt spe
1ca0: 63 69 66 69 65 64 0a 3b 3b 20 20 20 20 20 20 20 cified.;;
1cb0: 20 20 20 20 20 0a 28 64 65 66 69 6e 65 20 28 72 .(define (r
1cc0: 75 6e 73 3a 72 75 6e 2d 74 65 73 74 73 20 74 61 uns:run-tests ta
1cd0: 72 67 65 74 20 72 75 6e 6e 61 6d 65 20 74 65 73 rget runname tes
1ce0: 74 2d 6e 61 6d 65 73 20 74 65 73 74 2d 70 61 74 t-names test-pat
1cf0: 74 73 20 75 73 65 72 20 66 6c 61 67 73 29 0a 20 ts user flags).
1d00: 20 28 63 6f 6d 6d 6f 6e 3a 63 6c 65 61 72 2d 63 (common:clear-c
1d10: 61 63 68 65 73 29 20 3b 3b 20 63 6c 65 61 72 20 aches) ;; clear
1d20: 61 6c 6c 20 63 61 63 68 65 73 0a 20 20 28 6c 65 all caches. (le
1d30: 74 2a 20 28 28 64 62 20 20 20 20 20 20 20 20 20 t* ((db
1d40: 20 23 66 29 0a 09 20 28 6b 65 79 73 20 20 20 20 #f).. (keys
1d50: 20 20 20 20 28 63 64 62 3a 72 65 6d 6f 74 65 2d (cdb:remote-
1d60: 72 75 6e 20 64 62 3a 67 65 74 2d 6b 65 79 73 20 run db:get-keys
1d70: 23 66 29 29 0a 09 20 28 6b 65 79 76 61 6c 6c 73 #f)).. (keyvalls
1d80: 74 20 20 20 28 6b 65 79 73 3a 74 61 72 67 65 74 t (keys:target
1d90: 2d 3e 6b 65 79 76 61 6c 20 6b 65 79 73 20 74 61 ->keyval keys ta
1da0: 72 67 65 74 29 29 0a 09 20 28 72 75 6e 2d 69 64 rget)).. (run-id
1db0: 20 20 20 20 20 20 28 63 64 62 3a 72 65 6d 6f 74 (cdb:remot
1dc0: 65 2d 72 75 6e 20 64 62 3a 72 65 67 69 73 74 65 e-run db:registe
1dd0: 72 2d 72 75 6e 20 23 66 20 6b 65 79 73 20 6b 65 r-run #f keys ke
1de0: 79 76 61 6c 6c 73 74 20 72 75 6e 6e 61 6d 65 20 yvallst runname
1df0: 22 6e 65 77 22 20 22 6e 2f 61 22 20 75 73 65 72 "new" "n/a" user
1e00: 29 29 20 20 3b 3b 20 20 74 65 73 74 2d 6e 61 6d )) ;; test-nam
1e10: 65 29 29 29 0a 09 20 28 6b 65 79 76 61 6c 73 20 e))).. (keyvals
1e20: 20 20 20 20 28 69 66 20 72 75 6e 2d 69 64 20 28 (if run-id (
1e30: 63 64 62 3a 72 65 6d 6f 74 65 2d 72 75 6e 20 64 cdb:remote-run d
1e40: 62 3a 67 65 74 2d 6b 65 79 2d 76 61 6c 73 20 23 b:get-key-vals #
1e50: 66 20 72 75 6e 2d 69 64 29 20 23 66 29 29 0a 09 f run-id) #f))..
1e60: 20 28 64 65 66 65 72 72 65 64 20 20 20 20 27 28 (deferred '(
1e70: 29 29 20 3b 3b 20 64 65 6c 61 79 20 72 75 6e 6e )) ;; delay runn
1e80: 69 6e 67 20 74 68 65 73 65 20 73 69 6e 63 65 20 ing these since
1e90: 74 68 65 79 20 68 61 76 65 20 61 20 77 61 69 74 they have a wait
1ea0: 6f 6e 20 63 6c 61 75 73 65 0a 09 20 3b 3b 20 6b on clause.. ;; k
1eb0: 65 65 70 67 6f 69 6e 67 20 69 73 20 74 68 65 20 eepgoing is the
1ec0: 64 65 66 61 63 74 6f 20 6d 6f 64 61 6c 69 74 79 defacto modality
1ed0: 20 6e 6f 77 2c 20 77 69 6c 6c 20 61 64 64 20 68 now, will add h
1ee0: 69 74 2d 6e 2d 72 75 6e 20 61 20 62 69 74 20 6c it-n-run a bit l
1ef0: 61 74 65 72 0a 09 20 3b 3b 20 28 6b 65 65 70 67 ater.. ;; (keepg
1f00: 6f 69 6e 67 20 20 20 28 68 61 73 68 2d 74 61 62 oing (hash-tab
1f10: 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 66 le-ref/default f
1f20: 6c 61 67 73 20 22 2d 6b 65 65 70 67 6f 69 6e 67 lags "-keepgoing
1f30: 22 20 23 66 29 29 0a 09 20 28 72 75 6e 63 6f 6e " #f)).. (runcon
1f40: 66 69 67 66 20 20 20 28 63 6f 6e 63 20 20 2a 74 figf (conc *t
1f50: 6f 70 70 61 74 68 2a 20 22 2f 72 75 6e 63 6f 6e oppath* "/runcon
1f60: 66 69 67 73 2e 63 6f 6e 66 69 67 22 29 29 0a 09 figs.config"))..
1f70: 20 28 72 65 71 75 69 72 65 64 2d 74 65 73 74 73 (required-tests
1f80: 20 27 28 29 29 0a 09 20 28 74 65 73 74 2d 72 65 '()).. (test-re
1f90: 63 6f 72 64 73 20 28 6d 61 6b 65 2d 68 61 73 68 cords (make-hash
1fa0: 2d 74 61 62 6c 65 29 29 29 0a 0a 20 20 20 20 28 -table))).. (
1fb0: 73 65 74 2d 6d 65 67 61 74 65 73 74 2d 65 6e 76 set-megatest-env
1fc0: 2d 76 61 72 73 20 72 75 6e 2d 69 64 29 20 3b 3b -vars run-id) ;;
1fd0: 20 74 68 65 73 65 20 6d 61 79 20 62 65 20 6e 65 these may be ne
1fe0: 65 64 65 64 20 62 79 20 74 68 65 20 6c 61 75 6e eded by the laun
1ff0: 63 68 69 6e 67 20 70 72 6f 63 65 73 73 0a 0a 20 ching process..
2000: 20 20 20 28 69 66 20 28 66 69 6c 65 2d 65 78 69 (if (file-exi
2010: 73 74 73 3f 20 72 75 6e 63 6f 6e 66 69 67 66 29 sts? runconfigf)
2020: 0a 09 28 73 65 74 75 70 2d 65 6e 76 2d 64 65 66 ..(setup-env-def
2030: 61 75 6c 74 73 20 72 75 6e 63 6f 6e 66 69 67 66 aults runconfigf
2040: 20 72 75 6e 2d 69 64 20 2a 61 6c 72 65 61 64 79 run-id *already
2050: 2d 73 65 65 6e 2d 72 75 6e 63 6f 6e 66 69 67 2d -seen-runconfig-
2060: 69 6e 66 6f 2a 20 6b 65 79 73 20 6b 65 79 76 61 info* keys keyva
2070: 6c 73 20 22 70 72 65 2d 6c 61 75 6e 63 68 2d 65 ls "pre-launch-e
2080: 6e 76 2d 76 61 72 73 22 29 0a 09 28 64 65 62 75 nv-vars")..(debu
2090: 67 3a 70 72 69 6e 74 20 30 20 22 57 41 52 4e 49 g:print 0 "WARNI
20a0: 4e 47 3a 20 59 6f 75 20 64 6f 20 6e 6f 74 20 68 NG: You do not h
20b0: 61 76 65 20 61 20 72 75 6e 20 63 6f 6e 66 69 67 ave a run config
20c0: 20 66 69 6c 65 3a 20 22 20 72 75 6e 63 6f 6e 66 file: " runconf
20d0: 69 67 66 29 29 0a 20 20 20 20 0a 20 20 20 20 3b igf)). . ;
20e0: 3b 20 6c 6f 6f 6b 20 75 70 20 61 6c 6c 20 74 65 ; look up all te
20f0: 73 74 73 20 6d 61 74 63 68 69 6e 67 20 74 68 65 sts matching the
2100: 20 63 6f 6d 6d 61 20 73 65 70 61 72 61 74 65 64 comma separated
2110: 20 6c 69 73 74 20 6f 66 20 67 6c 6f 62 73 20 69 list of globs i
2120: 6e 0a 20 20 20 20 3b 3b 20 74 65 73 74 2d 70 61 n. ;; test-pa
2130: 74 74 73 20 28 75 73 69 6e 67 20 25 20 61 73 20 tts (using % as
2140: 77 69 6c 64 63 61 72 64 29 0a 0a 20 20 20 20 28 wildcard).. (
2150: 73 65 74 21 20 74 65 73 74 2d 6e 61 6d 65 73 20 set! test-names
2160: 28 74 65 73 74 73 3a 67 65 74 2d 76 61 6c 69 64 (tests:get-valid
2170: 2d 74 65 73 74 73 20 2a 74 6f 70 70 61 74 68 2a -tests *toppath*
2180: 20 74 65 73 74 2d 6e 61 6d 65 73 29 29 0a 20 20 test-names)).
2190: 20 20 28 73 65 74 21 20 74 65 73 74 2d 6e 61 6d (set! test-nam
21a0: 65 73 20 28 64 65 6c 65 74 65 2d 64 75 70 6c 69 es (delete-dupli
21b0: 63 61 74 65 73 20 74 65 73 74 2d 6e 61 6d 65 73 cates test-names
21c0: 29 29 0a 0a 20 20 20 20 28 64 65 62 75 67 3a 70 )).. (debug:p
21d0: 72 69 6e 74 2d 69 6e 66 6f 20 30 20 22 74 65 73 rint-info 0 "tes
21e0: 74 20 6e 61 6d 65 73 20 22 20 74 65 73 74 2d 6e t names " test-n
21f0: 61 6d 65 73 29 0a 0a 20 20 20 20 3b 3b 20 6f 6e ames).. ;; on
2200: 20 74 68 65 20 66 69 72 73 74 20 70 61 73 73 20 the first pass
2210: 6f 72 20 63 61 6c 6c 20 74 6f 20 72 75 6e 2d 74 or call to run-t
2220: 65 73 74 73 20 73 65 74 20 46 41 49 4c 53 20 74 ests set FAILS t
2230: 6f 20 4e 4f 54 5f 53 54 41 52 54 45 44 20 69 66 o NOT_STARTED if
2240: 0a 20 20 20 20 3b 3b 20 2d 6b 65 65 70 67 6f 69 . ;; -keepgoi
2250: 6e 67 20 69 73 20 73 70 65 63 69 66 69 65 64 0a ng is specified.
2260: 20 20 20 20 28 69 66 20 28 65 71 3f 20 2a 70 61 (if (eq? *pa
2270: 73 73 6e 75 6d 2a 20 30 29 0a 09 28 62 65 67 69 ssnum* 0)..(begi
2280: 6e 0a 09 20 20 3b 3b 20 68 61 76 65 20 74 6f 20 n.. ;; have to
2290: 64 65 6c 65 74 65 20 74 65 73 74 20 72 65 63 6f delete test reco
22a0: 72 64 73 20 77 68 65 72 65 20 4e 4f 54 5f 53 54 rds where NOT_ST
22b0: 41 52 54 45 44 20 73 69 6e 63 65 20 74 68 65 79 ARTED since they
22c0: 20 63 61 6e 20 63 61 75 73 65 20 2d 6b 65 65 70 can cause -keep
22d0: 67 6f 69 6e 67 20 74 6f 20 0a 09 20 20 3b 3b 20 going to .. ;;
22e0: 67 65 74 20 73 74 75 63 6b 20 64 75 65 20 74 6f get stuck due to
22f0: 20 62 65 63 6f 6d 69 6e 67 20 69 6e 61 63 63 65 becoming inacce
2300: 73 73 69 62 6c 65 20 66 72 6f 6d 20 61 20 66 61 ssible from a fa
2310: 69 6c 65 64 20 74 65 73 74 2e 20 49 2e 65 2e 20 iled test. I.e.
2320: 69 66 20 74 65 73 74 20 42 20 64 65 70 65 6e 64 if test B depend
2330: 73 20 0a 09 20 20 3b 3b 20 6f 6e 20 74 65 73 74 s .. ;; on test
2340: 20 41 20 62 75 74 20 74 65 73 74 20 42 20 72 65 A but test B re
2350: 61 63 68 65 64 20 74 68 65 20 70 6f 69 6e 74 20 ached the point
2360: 6f 6e 20 62 65 69 6e 67 20 72 65 67 69 73 74 65 on being registe
2370: 72 65 64 20 61 73 20 4e 4f 54 5f 53 54 41 52 54 red as NOT_START
2380: 45 44 20 61 6e 64 20 74 65 73 74 0a 09 20 20 3b ED and test.. ;
2390: 3b 20 41 20 66 61 69 6c 65 64 20 66 6f 72 20 73 ; A failed for s
23a0: 6f 6d 65 20 72 65 61 73 6f 6e 20 74 68 65 6e 20 ome reason then
23b0: 6f 6e 20 72 65 2d 72 75 6e 20 75 73 69 6e 67 20 on re-run using
23c0: 2d 6b 65 65 70 67 6f 69 6e 67 20 74 68 65 20 72 -keepgoing the r
23d0: 75 6e 20 63 61 6e 20 6e 65 76 65 72 20 63 6f 6d un can never com
23e0: 70 6c 65 74 65 2e 0a 09 20 20 28 63 64 62 3a 64 plete... (cdb:d
23f0: 65 6c 65 74 65 2d 74 65 73 74 73 2d 69 6e 2d 73 elete-tests-in-s
2400: 74 61 74 65 20 2a 72 75 6e 72 65 6d 6f 74 65 2a tate *runremote*
2410: 20 72 75 6e 2d 69 64 20 22 4e 4f 54 5f 53 54 41 run-id "NOT_STA
2420: 52 54 45 44 22 29 0a 09 20 20 28 63 64 62 3a 72 RTED").. (cdb:r
2430: 65 6d 6f 74 65 2d 72 75 6e 20 64 62 3a 73 65 74 emote-run db:set
2440: 2d 74 65 73 74 73 2d 73 74 61 74 65 2d 73 74 61 -tests-state-sta
2450: 74 75 73 20 23 66 20 72 75 6e 2d 69 64 20 74 65 tus #f run-id te
2460: 73 74 2d 6e 61 6d 65 73 20 23 66 20 22 46 41 49 st-names #f "FAI
2470: 4c 22 20 22 4e 4f 54 5f 53 54 41 52 54 45 44 22 L" "NOT_STARTED"
2480: 20 22 46 41 49 4c 22 29 29 29 0a 0a 20 20 20 20 "FAIL")))..
2490: 3b 3b 20 66 72 6f 6d 20 68 65 72 65 20 6f 6e 20 ;; from here on
24a0: 6f 75 74 20 74 68 65 20 64 62 20 77 69 6c 6c 20 out the db will
24b0: 62 65 20 6f 70 65 6e 65 64 20 61 6e 64 20 63 6c be opened and cl
24c0: 6f 73 65 64 20 6f 6e 20 65 76 65 72 79 20 63 61 osed on every ca
24d0: 6c 6c 20 72 75 6e 73 3a 72 75 6e 2d 74 65 73 74 ll runs:run-test
24e0: 73 2d 71 75 65 75 65 0a 20 20 20 20 3b 3b 20 28 s-queue. ;; (
24f0: 73 71 6c 69 74 65 33 3a 66 69 6e 61 6c 69 7a 65 sqlite3:finalize
2500: 21 20 64 62 29 20 0a 20 20 20 20 3b 3b 20 6e 6f ! db) . ;; no
2510: 77 20 61 64 64 20 6e 6f 6e 2d 64 69 72 65 63 74 w add non-direct
2520: 6c 79 20 72 65 66 65 72 65 6e 63 65 64 20 64 65 ly referenced de
2530: 70 65 6e 64 65 6e 63 69 65 73 20 28 69 2e 65 2e pendencies (i.e.
2540: 20 77 61 69 74 6f 6e 29 0a 20 20 20 20 28 69 66 waiton). (if
2550: 20 28 6e 6f 74 20 28 6e 75 6c 6c 3f 20 74 65 73 (not (null? tes
2560: 74 2d 6e 61 6d 65 73 29 29 0a 09 28 6c 65 74 20 t-names))..(let
2570: 6c 6f 6f 70 20 28 28 68 65 64 20 28 63 61 72 20 loop ((hed (car
2580: 74 65 73 74 2d 6e 61 6d 65 73 29 29 0a 09 09 20 test-names))...
2590: 20 20 28 74 61 6c 20 28 63 64 72 20 74 65 73 74 (tal (cdr test
25a0: 2d 6e 61 6d 65 73 29 29 29 20 20 20 20 20 20 20 -names)))
25b0: 20 20 3b 3b 20 27 72 65 74 75 72 6e 2d 70 72 6f ;; 'return-pro
25c0: 63 73 20 74 65 6c 6c 73 20 74 68 65 20 63 6f 6e cs tells the con
25d0: 66 69 67 20 72 65 61 64 65 72 20 74 6f 20 70 72 fig reader to pr
25e0: 65 70 20 72 75 6e 6e 69 6e 67 20 73 79 73 74 65 ep running syste
25f0: 6d 20 62 75 74 20 72 65 74 75 72 6e 20 61 20 70 m but return a p
2600: 72 6f 63 0a 09 20 20 28 64 65 62 75 67 3a 70 72 roc.. (debug:pr
2610: 69 6e 74 2d 69 6e 66 6f 20 34 20 22 68 65 64 3d int-info 4 "hed=
2620: 22 20 68 65 64 20 22 20 61 74 20 74 6f 70 20 6f " hed " at top o
2630: 66 20 6c 6f 6f 70 22 29 0a 09 20 20 28 6c 65 74 f loop").. (let
2640: 2a 20 28 28 63 6f 6e 66 69 67 20 20 28 74 65 73 * ((config (tes
2650: 74 73 3a 67 65 74 2d 74 65 73 74 63 6f 6e 66 69 ts:get-testconfi
2660: 67 20 68 65 64 20 27 72 65 74 75 72 6e 2d 70 72 g hed 'return-pr
2670: 6f 63 73 29 29 0a 09 09 20 28 77 61 69 74 6f 6e ocs))... (waiton
2680: 73 20 28 6c 65 74 20 28 28 69 6e 73 74 72 20 28 s (let ((instr (
2690: 69 66 20 63 6f 6e 66 69 67 20 0a 09 09 09 09 09 if config ......
26a0: 20 20 20 28 63 6f 6e 66 69 67 2d 6c 6f 6f 6b 75 (config-looku
26b0: 70 20 63 6f 6e 66 69 67 20 22 72 65 71 75 69 72 p config "requir
26c0: 65 6d 65 6e 74 73 22 20 22 77 61 69 74 6f 6e 22 ements" "waiton"
26d0: 29 0a 09 09 09 09 09 20 20 20 28 62 65 67 69 6e )...... (begin
26e0: 20 3b 3b 20 4e 6f 20 63 6f 6e 66 69 67 20 6d 65 ;; No config me
26f0: 61 6e 73 20 74 68 69 73 20 69 73 20 61 20 6e 6f ans this is a no
2700: 6e 2d 65 78 69 73 74 61 6e 74 20 74 65 73 74 0a n-existant test.
2710: 09 09 09 09 09 20 20 20 20 20 28 64 65 62 75 67 ..... (debug
2720: 3a 70 72 69 6e 74 20 30 20 22 45 52 52 4f 52 3a :print 0 "ERROR:
2730: 20 6e 6f 6e 2d 65 78 69 73 74 65 6e 74 20 72 65 non-existent re
2740: 71 75 69 72 65 64 20 74 65 73 74 20 5c 22 22 20 quired test \""
2750: 68 65 64 20 22 5c 22 22 29 0a 09 09 09 09 09 20 hed "\"")......
2760: 20 20 20 20 28 69 66 20 64 62 20 28 73 71 6c 69 (if db (sqli
2770: 74 65 33 3a 66 69 6e 61 6c 69 7a 65 21 20 64 62 te3:finalize! db
2780: 29 29 0a 09 09 09 09 09 20 20 20 20 20 28 65 78 ))...... (ex
2790: 69 74 20 31 29 29 29 29 29 0a 09 09 09 20 20 20 it 1)))))....
27a0: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e (debug:print-in
27b0: 66 6f 20 38 20 22 77 61 69 74 6f 6e 73 20 73 74 fo 8 "waitons st
27c0: 72 69 6e 67 20 69 73 20 22 20 69 6e 73 74 72 29 ring is " instr)
27d0: 0a 09 09 09 20 20 20 20 28 73 74 72 69 6e 67 2d .... (string-
27e0: 73 70 6c 69 74 20 28 63 6f 6e 64 0a 09 09 09 09 split (cond.....
27f0: 09 20 20 20 28 28 70 72 6f 63 65 64 75 72 65 3f . ((procedure?
2800: 20 69 6e 73 74 72 29 0a 09 09 09 09 09 20 20 20 instr)......
2810: 20 28 6c 65 74 20 28 28 72 65 73 20 28 69 6e 73 (let ((res (ins
2820: 74 72 29 29 29 0a 09 09 09 09 09 20 20 20 20 20 tr)))......
2830: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e (debug:print-in
2840: 66 6f 20 38 20 22 77 61 69 74 6f 6e 20 70 72 6f fo 8 "waiton pro
2850: 63 65 64 75 72 65 20 72 65 73 75 6c 74 73 20 69 cedure results i
2860: 6e 20 73 74 72 69 6e 67 20 22 20 72 65 73 20 22 n string " res "
2870: 20 66 6f 72 20 74 65 73 74 20 22 20 68 65 64 29 for test " hed)
2880: 0a 09 09 09 09 09 20 20 20 20 20 20 72 65 73 29 ...... res)
2890: 29 0a 09 09 09 09 09 20 20 20 28 28 73 74 72 69 )...... ((stri
28a0: 6e 67 3f 20 69 6e 73 74 72 29 20 20 20 20 20 69 ng? instr) i
28b0: 6e 73 74 72 29 0a 09 09 09 09 09 20 20 20 28 65 nstr)...... (e
28c0: 6c 73 65 20 0a 09 09 09 09 09 20 20 20 20 3b 3b lse ...... ;;
28d0: 20 4e 4f 54 45 3a 20 54 68 69 73 20 69 73 20 61 NOTE: This is a
28e0: 63 74 75 61 6c 6c 79 20 74 68 65 20 63 61 73 65 ctually the case
28f0: 20 6f 66 20 2a 6e 6f 2a 20 77 61 69 74 6f 6e 73 of *no* waitons
2900: 21 20 3b 3b 20 28 64 65 62 75 67 3a 70 72 69 6e ! ;; (debug:prin
2910: 74 20 30 20 22 45 52 52 4f 52 3a 20 73 6f 6d 65 t 0 "ERROR: some
2920: 74 68 69 6e 67 20 77 65 6e 74 20 77 72 6f 6e 67 thing went wrong
2930: 20 69 6e 20 70 72 6f 63 65 73 73 69 6e 67 20 77 in processing w
2940: 61 69 74 6f 6e 73 20 66 6f 72 20 74 65 73 74 20 aitons for test
2950: 22 20 68 65 64 29 0a 09 09 09 09 09 20 20 20 20 " hed)......
2960: 22 22 29 29 29 29 29 29 0a 09 20 20 20 20 28 64 "")))))).. (d
2970: 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 ebug:print-info
2980: 38 20 22 77 61 69 74 6f 6e 73 3a 20 22 20 77 61 8 "waitons: " wa
2990: 69 74 6f 6e 73 29 0a 09 20 20 20 20 3b 3b 20 63 itons).. ;; c
29a0: 68 65 63 6b 20 66 6f 72 20 68 65 64 20 69 6e 20 heck for hed in
29b0: 77 61 69 74 6f 6e 73 20 3d 3e 20 74 68 69 73 20 waitons => this
29c0: 77 6f 75 6c 64 20 62 65 20 63 69 72 63 75 6c 61 would be circula
29d0: 72 2c 20 72 65 6d 6f 76 65 20 69 74 20 61 6e 64 r, remove it and
29e0: 20 69 73 73 75 65 20 61 6e 0a 09 20 20 20 20 3b issue an.. ;
29f0: 3b 20 65 72 72 6f 72 0a 09 20 20 20 20 28 69 66 ; error.. (if
2a00: 20 28 6d 65 6d 62 65 72 20 68 65 64 20 77 61 69 (member hed wai
2a10: 74 6f 6e 73 29 0a 09 09 28 62 65 67 69 6e 0a 09 tons)...(begin..
2a20: 09 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 . (debug:print
2a30: 30 20 22 45 52 52 4f 52 3a 20 74 65 73 74 20 22 0 "ERROR: test "
2a40: 20 68 65 64 20 22 20 68 61 73 20 6c 69 73 74 65 hed " has liste
2a50: 64 20 69 74 73 65 6c 66 20 61 73 20 61 20 77 61 d itself as a wa
2a60: 69 74 6f 6e 2c 20 70 6c 65 61 73 65 20 63 6f 72 iton, please cor
2a70: 72 65 63 74 20 74 68 69 73 21 22 29 0a 09 09 20 rect this!")...
2a80: 20 28 73 65 74 21 20 77 61 69 74 6f 6e 73 20 28 (set! waitons (
2a90: 66 69 6c 74 65 72 20 28 6c 61 6d 62 64 61 20 28 filter (lambda (
2aa0: 78 29 28 6e 6f 74 20 28 65 71 75 61 6c 3f 20 78 x)(not (equal? x
2ab0: 20 68 65 64 29 29 29 20 77 61 69 74 6f 6e 73 29 hed))) waitons)
2ac0: 29 29 29 0a 09 20 20 20 20 0a 09 20 20 20 20 3b ))).. .. ;
2ad0: 3b 20 28 69 74 65 6d 73 20 20 20 28 69 74 65 6d ; (items (item
2ae0: 73 3a 67 65 74 2d 69 74 65 6d 73 2d 66 72 6f 6d s:get-items-from
2af0: 2d 63 6f 6e 66 69 67 20 63 6f 6e 66 69 67 29 29 -config config))
2b00: 29 0a 09 20 20 20 20 28 69 66 20 28 6e 6f 74 20 ).. (if (not
2b10: 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f (hash-table-ref/
2b20: 64 65 66 61 75 6c 74 20 74 65 73 74 2d 72 65 63 default test-rec
2b30: 6f 72 64 73 20 68 65 64 20 23 66 29 29 0a 09 09 ords hed #f))...
2b40: 28 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 (hash-table-set!
2b50: 20 74 65 73 74 2d 72 65 63 6f 72 64 73 0a 09 09 test-records...
2b60: 09 09 20 68 65 64 20 28 76 65 63 74 6f 72 20 68 .. hed (vector h
2b70: 65 64 20 20 20 20 20 3b 3b 20 30 0a 09 09 09 09 ed ;; 0.....
2b80: 09 20 20 20 20 20 63 6f 6e 66 69 67 20 20 3b 3b . config ;;
2b90: 20 31 0a 09 09 09 09 09 20 20 20 20 20 77 61 69 1...... wai
2ba0: 74 6f 6e 73 20 3b 3b 20 32 0a 09 09 09 09 09 20 tons ;; 2......
2bb0: 20 20 20 20 28 63 6f 6e 66 69 67 2d 6c 6f 6f 6b (config-look
2bc0: 75 70 20 63 6f 6e 66 69 67 20 22 72 65 71 75 69 up config "requi
2bd0: 72 65 6d 65 6e 74 73 22 20 22 70 72 69 6f 72 69 rements" "priori
2be0: 74 79 22 29 20 20 20 20 20 3b 3b 20 70 72 69 6f ty") ;; prio
2bf0: 72 69 74 79 20 33 0a 09 09 09 09 09 20 20 20 20 rity 3......
2c00: 20 28 6c 65 74 20 28 28 69 74 65 6d 73 20 20 20 (let ((items
2c10: 20 20 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 (hash-table-r
2c20: 65 66 2f 64 65 66 61 75 6c 74 20 63 6f 6e 66 69 ef/default confi
2c30: 67 20 22 69 74 65 6d 73 22 20 23 66 29 29 20 3b g "items" #f)) ;
2c40: 3b 20 69 74 65 6d 73 20 34 0a 09 09 09 09 09 09 ; items 4.......
2c50: 20 20 20 28 69 74 65 6d 73 74 61 62 6c 65 20 28 (itemstable (
2c60: 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 hash-table-ref/d
2c70: 65 66 61 75 6c 74 20 63 6f 6e 66 69 67 20 22 69 efault config "i
2c80: 74 65 6d 73 74 61 62 6c 65 22 20 23 66 29 29 29 temstable" #f)))
2c90: 20 0a 09 09 09 09 09 20 20 20 20 20 20 20 3b 3b ...... ;;
2ca0: 20 69 66 20 65 69 74 68 65 72 20 69 74 65 6d 73 if either items
2cb0: 20 6f 72 20 69 74 65 6d 73 20 74 61 62 6c 65 20 or items table
2cc0: 69 73 20 61 20 70 72 6f 63 20 72 65 74 75 72 6e is a proc return
2cd0: 20 69 74 20 73 6f 20 74 65 73 74 20 72 75 6e 6e it so test runn
2ce0: 69 6e 67 0a 09 09 09 09 09 20 20 20 20 20 20 20 ing......
2cf0: 3b 3b 20 70 72 6f 63 65 73 73 20 63 61 6e 20 6b ;; process can k
2d00: 6e 6f 77 20 74 6f 20 63 61 6c 6c 20 69 74 65 6d now to call item
2d10: 73 3a 67 65 74 2d 69 74 65 6d 73 2d 66 72 6f 6d s:get-items-from
2d20: 2d 63 6f 6e 66 69 67 0a 09 09 09 09 09 20 20 20 -config......
2d30: 20 20 20 20 3b 3b 20 69 66 20 65 69 74 68 65 72 ;; if either
2d40: 20 69 73 20 61 20 6c 69 73 74 20 61 6e 64 20 6e is a list and n
2d50: 6f 6e 65 20 69 73 20 61 20 70 72 6f 63 20 67 6f one is a proc go
2d60: 20 61 68 65 61 64 20 61 6e 64 20 63 61 6c 6c 20 ahead and call
2d70: 67 65 74 2d 69 74 65 6d 73 0a 09 09 09 09 09 20 get-items......
2d80: 20 20 20 20 20 20 3b 3b 20 6f 74 68 65 72 77 69 ;; otherwi
2d90: 73 65 20 72 65 74 75 72 6e 20 23 66 20 2d 20 74 se return #f - t
2da0: 68 69 73 20 69 73 20 6e 6f 74 20 61 6e 20 69 74 his is not an it
2db0: 65 72 61 74 65 64 20 74 65 73 74 0a 09 09 09 09 erated test.....
2dc0: 09 20 20 20 20 20 20 20 28 63 6f 6e 64 0a 09 09 . (cond...
2dd0: 09 09 09 09 28 28 70 72 6f 63 65 64 75 72 65 3f ....((procedure?
2de0: 20 69 74 65 6d 73 29 20 20 20 20 20 20 0a 09 09 items) ...
2df0: 09 09 09 09 20 28 64 65 62 75 67 3a 70 72 69 6e .... (debug:prin
2e00: 74 2d 69 6e 66 6f 20 34 20 22 69 74 65 6d 73 20 t-info 4 "items
2e10: 69 73 20 61 20 70 72 6f 63 65 64 75 72 65 2c 20 is a procedure,
2e20: 77 69 6c 6c 20 63 61 6c 63 20 6c 61 74 65 72 22 will calc later"
2e30: 29 0a 09 09 09 09 09 09 20 69 74 65 6d 73 29 20 )....... items)
2e40: 20 20 20 20 20 20 20 20 20 20 20 3b 3b 20 63 61 ;; ca
2e50: 6c 63 20 6c 61 74 65 72 0a 09 09 09 09 09 09 28 lc later.......(
2e60: 28 70 72 6f 63 65 64 75 72 65 3f 20 69 74 65 6d (procedure? item
2e70: 73 74 61 62 6c 65 29 0a 09 09 09 09 09 09 20 28 stable)....... (
2e80: 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f debug:print-info
2e90: 20 34 20 22 69 74 65 6d 73 74 61 62 6c 65 20 69 4 "itemstable i
2ea0: 73 20 61 20 70 72 6f 63 65 64 75 72 65 2c 20 77 s a procedure, w
2eb0: 69 6c 6c 20 63 61 6c 63 20 6c 61 74 65 72 22 29 ill calc later")
2ec0: 0a 09 09 09 09 09 09 20 69 74 65 6d 73 74 61 62 ....... itemstab
2ed0: 6c 65 29 20 20 20 20 20 20 20 3b 3b 20 63 61 6c le) ;; cal
2ee0: 63 20 6c 61 74 65 72 0a 09 09 09 09 09 09 28 28 c later.......((
2ef0: 66 69 6c 74 65 72 20 28 6c 61 6d 62 64 61 20 28 filter (lambda (
2f00: 78 29 0a 09 09 09 09 09 09 09 20 20 20 28 6c 65 x)........ (le
2f10: 74 20 28 28 76 61 6c 20 28 63 61 72 20 78 29 29 t ((val (car x))
2f20: 29 0a 09 09 09 09 09 09 09 20 20 20 20 20 28 69 )........ (i
2f30: 66 20 28 70 72 6f 63 65 64 75 72 65 3f 20 76 61 f (procedure? va
2f40: 6c 29 20 76 61 6c 20 23 66 29 29 29 0a 09 09 09 l) val #f)))....
2f50: 09 09 09 09 20 28 61 70 70 65 6e 64 20 28 69 66 .... (append (if
2f60: 20 28 6c 69 73 74 3f 20 69 74 65 6d 73 29 20 69 (list? items) i
2f70: 74 65 6d 73 20 27 28 29 29 0a 09 09 09 09 09 09 tems '()).......
2f80: 09 09 20 28 69 66 20 28 6c 69 73 74 3f 20 69 74 .. (if (list? it
2f90: 65 6d 73 74 61 62 6c 65 29 20 69 74 65 6d 73 74 emstable) itemst
2fa0: 61 62 6c 65 20 27 28 29 29 29 29 0a 09 09 09 09 able '()))).....
2fb0: 09 09 20 27 68 61 76 65 2d 70 72 6f 63 65 64 75 .. 'have-procedu
2fc0: 72 65 29 0a 09 09 09 09 09 09 28 28 6f 72 20 28 re).......((or (
2fd0: 6c 69 73 74 3f 20 69 74 65 6d 73 29 28 6c 69 73 list? items)(lis
2fe0: 74 3f 20 69 74 65 6d 73 74 61 62 6c 65 29 29 20 t? itemstable))
2ff0: 3b 3b 20 63 61 6c 63 20 6e 6f 77 0a 09 09 09 09 ;; calc now.....
3000: 09 09 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d .. (debug:print-
3010: 69 6e 66 6f 20 34 20 22 69 74 65 6d 73 20 61 6e info 4 "items an
3020: 64 20 69 74 65 6d 73 74 61 62 6c 65 20 61 72 65 d itemstable are
3030: 20 6c 69 73 74 73 2c 20 63 61 6c 63 20 6e 6f 77 lists, calc now
3040: 5c 6e 22 0a 09 09 09 09 09 09 09 20 20 20 20 20 \n"........
3050: 20 22 20 20 20 20 69 74 65 6d 73 3a 20 22 20 69 " items: " i
3060: 74 65 6d 73 20 22 20 69 74 65 6d 73 74 61 62 6c tems " itemstabl
3070: 65 3a 20 22 20 69 74 65 6d 73 74 61 62 6c 65 29 e: " itemstable)
3080: 0a 09 09 09 09 09 09 20 28 69 74 65 6d 73 3a 67 ....... (items:g
3090: 65 74 2d 69 74 65 6d 73 2d 66 72 6f 6d 2d 63 6f et-items-from-co
30a0: 6e 66 69 67 20 63 6f 6e 66 69 67 29 29 0a 09 09 nfig config))...
30b0: 09 09 09 09 28 65 6c 73 65 20 23 66 29 29 29 20 ....(else #f)))
30c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
30d0: 20 20 20 20 20 20 20 20 20 20 3b 3b 20 6e 6f 74 ;; not
30e0: 20 69 74 65 72 61 74 65 64 0a 09 09 09 09 09 20 iterated......
30f0: 20 20 20 20 23 66 20 20 20 20 20 20 3b 3b 20 69 #f ;; i
3100: 74 65 6d 73 64 61 74 20 35 0a 09 09 09 09 09 20 temsdat 5......
3110: 20 20 20 20 23 66 20 20 20 20 20 20 3b 3b 20 73 #f ;; s
3120: 70 61 72 65 20 2d 20 75 73 65 64 20 66 6f 72 20 pare - used for
3130: 69 74 65 6d 2d 70 61 74 68 0a 09 09 09 09 09 20 item-path......
3140: 20 20 20 20 29 29 29 0a 09 20 20 20 20 28 66 6f ))).. (fo
3150: 72 2d 65 61 63 68 20 0a 09 20 20 20 20 20 28 6c r-each .. (l
3160: 61 6d 62 64 61 20 28 77 61 69 74 6f 6e 29 0a 09 ambda (waiton)..
3170: 20 20 20 20 20 20 20 28 69 66 20 28 61 6e 64 20 (if (and
3180: 77 61 69 74 6f 6e 20 28 6e 6f 74 20 28 6d 65 6d waiton (not (mem
3190: 62 65 72 20 77 61 69 74 6f 6e 20 74 65 73 74 2d ber waiton test-
31a0: 6e 61 6d 65 73 29 29 29 0a 09 09 20 20 20 28 62 names)))... (b
31b0: 65 67 69 6e 0a 09 09 20 20 20 20 20 28 73 65 74 egin... (set
31c0: 21 20 72 65 71 75 69 72 65 64 2d 74 65 73 74 73 ! required-tests
31d0: 20 28 63 6f 6e 73 20 77 61 69 74 6f 6e 20 72 65 (cons waiton re
31e0: 71 75 69 72 65 64 2d 74 65 73 74 73 29 29 0a 09 quired-tests))..
31f0: 09 20 20 20 20 20 28 73 65 74 21 20 74 65 73 74 . (set! test
3200: 2d 6e 61 6d 65 73 20 28 63 6f 6e 73 20 77 61 69 -names (cons wai
3210: 74 6f 6e 20 74 65 73 74 2d 6e 61 6d 65 73 29 29 ton test-names))
3220: 29 29 29 20 3b 3b 20 77 61 73 20 61 6e 20 61 70 ))) ;; was an ap
3230: 70 65 6e 64 2c 20 6e 6f 77 20 61 20 63 6f 6e 73 pend, now a cons
3240: 0a 09 20 20 20 20 20 77 61 69 74 6f 6e 73 29 0a .. waitons).
3250: 09 20 20 20 20 28 6c 65 74 20 28 28 72 65 6d 74 . (let ((remt
3260: 65 73 74 73 20 28 64 65 6c 65 74 65 2d 64 75 70 ests (delete-dup
3270: 6c 69 63 61 74 65 73 20 28 61 70 70 65 6e 64 20 licates (append
3280: 77 61 69 74 6f 6e 73 20 74 61 6c 29 29 29 29 0a waitons tal)))).
3290: 09 20 20 20 20 20 20 28 69 66 20 28 6e 6f 74 20 . (if (not
32a0: 28 6e 75 6c 6c 3f 20 72 65 6d 74 65 73 74 73 29 (null? remtests)
32b0: 29 0a 09 09 20 20 28 6c 6f 6f 70 20 28 63 61 72 )... (loop (car
32c0: 20 72 65 6d 74 65 73 74 73 29 28 63 64 72 20 72 remtests)(cdr r
32d0: 65 6d 74 65 73 74 73 29 29 29 29 29 29 29 0a 0a emtests)))))))..
32e0: 20 20 20 20 28 69 66 20 28 6e 6f 74 20 28 6e 75 (if (not (nu
32f0: 6c 6c 3f 20 72 65 71 75 69 72 65 64 2d 74 65 73 ll? required-tes
3300: 74 73 29 29 0a 09 28 64 65 62 75 67 3a 70 72 69 ts))..(debug:pri
3310: 6e 74 2d 69 6e 66 6f 20 31 20 22 41 64 64 69 6e nt-info 1 "Addin
3320: 67 20 22 20 72 65 71 75 69 72 65 64 2d 74 65 73 g " required-tes
3330: 74 73 20 22 20 74 6f 20 74 68 65 20 72 75 6e 20 ts " to the run
3340: 71 75 65 75 65 22 29 29 0a 20 20 20 20 3b 3b 20 queue")). ;;
3350: 4e 4f 54 45 3a 20 74 68 65 73 65 20 61 72 65 20 NOTE: these are
3360: 61 6c 6c 20 70 61 72 65 6e 74 20 74 65 73 74 73 all parent tests
3370: 2c 20 69 74 65 6d 73 20 61 72 65 20 6e 6f 74 20 , items are not
3380: 65 78 70 61 6e 64 65 64 20 79 65 74 2e 0a 20 20 expanded yet..
3390: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 (debug:print-i
33a0: 6e 66 6f 20 34 20 22 74 65 73 74 2d 72 65 63 6f nfo 4 "test-reco
33b0: 72 64 73 3d 22 20 28 68 61 73 68 2d 74 61 62 6c rds=" (hash-tabl
33c0: 65 2d 3e 61 6c 69 73 74 20 74 65 73 74 2d 72 65 e->alist test-re
33d0: 63 6f 72 64 73 29 29 0a 20 20 20 20 28 72 75 6e cords)). (run
33e0: 73 3a 72 75 6e 2d 74 65 73 74 73 2d 71 75 65 75 s:run-tests-queu
33f0: 65 20 72 75 6e 2d 69 64 20 72 75 6e 6e 61 6d 65 e run-id runname
3400: 20 74 65 73 74 2d 72 65 63 6f 72 64 73 20 6b 65 test-records ke
3410: 79 76 61 6c 6c 73 74 20 66 6c 61 67 73 20 74 65 yvallst flags te
3420: 73 74 2d 70 61 74 74 73 29 0a 20 20 20 20 28 64 st-patts). (d
3430: 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 ebug:print-info
3440: 34 20 22 41 6c 6c 20 64 6f 6e 65 20 62 79 20 68 4 "All done by h
3450: 65 72 65 22 29 29 29 0a 0a 28 64 65 66 69 6e 65 ere")))..(define
3460: 20 28 72 75 6e 73 3a 63 61 6c 63 2d 66 61 69 6c (runs:calc-fail
3470: 73 20 70 72 65 72 65 71 73 2d 6e 6f 74 2d 6d 65 s prereqs-not-me
3480: 74 29 0a 20 20 28 66 69 6c 74 65 72 20 28 6c 61 t). (filter (la
3490: 6d 62 64 61 20 28 74 65 73 74 29 0a 09 20 20 20 mbda (test)..
34a0: 20 28 61 6e 64 20 28 76 65 63 74 6f 72 3f 20 74 (and (vector? t
34b0: 65 73 74 29 20 3b 3b 20 6e 6f 74 20 28 73 74 72 est) ;; not (str
34c0: 69 6e 67 3f 20 74 65 73 74 29 29 0a 09 09 20 28 ing? test))... (
34d0: 65 71 75 61 6c 3f 20 28 64 62 3a 74 65 73 74 2d equal? (db:test-
34e0: 67 65 74 2d 73 74 61 74 65 20 74 65 73 74 29 20 get-state test)
34f0: 22 43 4f 4d 50 4c 45 54 45 44 22 29 0a 09 09 20 "COMPLETED")...
3500: 28 6e 6f 74 20 28 6d 65 6d 62 65 72 20 28 64 62 (not (member (db
3510: 3a 74 65 73 74 2d 67 65 74 2d 73 74 61 74 75 73 :test-get-status
3520: 20 74 65 73 74 29 0a 09 09 09 20 20 20 20 20 20 test)....
3530: 27 28 22 50 41 53 53 22 20 22 57 41 52 4e 22 20 '("PASS" "WARN"
3540: 22 43 48 45 43 4b 22 20 22 57 41 49 56 45 44 22 "CHECK" "WAIVED"
3550: 20 22 53 4b 49 50 22 29 29 29 29 29 0a 09 20 20 "SKIP")))))..
3560: 70 72 65 72 65 71 73 2d 6e 6f 74 2d 6d 65 74 29 prereqs-not-met)
3570: 29 0a 0a 28 64 65 66 69 6e 65 20 28 72 75 6e 73 )..(define (runs
3580: 3a 63 61 6c 63 2d 6e 6f 74 2d 63 6f 6d 70 6c 65 :calc-not-comple
3590: 74 65 64 20 70 72 65 72 65 71 73 2d 6e 6f 74 2d ted prereqs-not-
35a0: 6d 65 74 29 0a 20 20 28 66 69 6c 74 65 72 0a 20 met). (filter.
35b0: 20 20 28 6c 61 6d 62 64 61 20 28 74 29 0a 20 20 (lambda (t).
35c0: 20 20 20 28 6f 72 20 28 6e 6f 74 20 28 76 65 63 (or (not (vec
35d0: 74 6f 72 3f 20 74 29 29 0a 09 20 28 6e 6f 74 20 tor? t)).. (not
35e0: 28 65 71 75 61 6c 3f 20 22 43 4f 4d 50 4c 45 54 (equal? "COMPLET
35f0: 45 44 22 20 28 64 62 3a 74 65 73 74 2d 67 65 74 ED" (db:test-get
3600: 2d 73 74 61 74 65 20 74 29 29 29 29 29 0a 20 20 -state t))))).
3610: 20 70 72 65 72 65 71 73 2d 6e 6f 74 2d 6d 65 74 prereqs-not-met
3620: 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 72 75 6e ))..(define (run
3630: 73 3a 70 72 65 74 74 79 2d 73 74 72 69 6e 67 20 s:pretty-string
3640: 6c 73 74 29 0a 20 20 28 6d 61 70 20 28 6c 61 6d lst). (map (lam
3650: 62 64 61 20 28 74 29 0a 09 20 28 69 66 20 28 6e bda (t).. (if (n
3660: 6f 74 20 28 76 65 63 74 6f 72 3f 20 74 29 29 0a ot (vector? t)).
3670: 09 20 20 20 20 20 28 63 6f 6e 63 20 74 29 0a 09 . (conc t)..
3680: 20 20 20 20 20 28 63 6f 6e 63 20 28 64 62 3a 74 (conc (db:t
3690: 65 73 74 2d 67 65 74 2d 74 65 73 74 6e 61 6d 65 est-get-testname
36a0: 20 74 29 20 22 3a 22 20 28 64 62 3a 74 65 73 74 t) ":" (db:test
36b0: 2d 67 65 74 2d 73 74 61 74 65 20 74 29 20 22 2f -get-state t) "/
36c0: 22 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 73 " (db:test-get-s
36d0: 74 61 74 75 73 20 74 29 29 29 29 0a 20 20 20 20 tatus t)))).
36e0: 20 20 20 6c 73 74 29 29 0a 0a 28 64 65 66 69 6e lst))..(defin
36f0: 65 20 28 72 75 6e 73 3a 6d 61 6b 65 2d 66 75 6c e (runs:make-ful
3700: 6c 2d 74 65 73 74 2d 6e 61 6d 65 20 74 65 73 74 l-test-name test
3710: 6e 61 6d 65 20 69 74 65 6d 70 61 74 68 29 0a 20 name itempath).
3720: 20 28 69 66 20 28 65 71 75 61 6c 3f 20 69 74 65 (if (equal? ite
3730: 6d 70 61 74 68 20 22 22 29 20 74 65 73 74 6e 61 mpath "") testna
3740: 6d 65 20 28 63 6f 6e 63 20 74 65 73 74 6e 61 6d me (conc testnam
3750: 65 20 22 2f 22 20 69 74 65 6d 70 61 74 68 29 29 e "/" itempath))
3760: 29 0a 0a 3b 3b 20 74 65 73 74 2d 72 65 63 6f 72 )..;; test-recor
3770: 64 73 20 69 73 20 61 20 68 61 73 68 20 74 61 62 ds is a hash tab
3780: 6c 65 20 74 65 73 74 6e 61 6d 65 3a 69 74 65 6d le testname:item
3790: 5f 70 61 74 68 20 3d 3e 20 76 65 63 74 6f 72 20 _path => vector
37a0: 3c 20 74 65 73 74 6e 61 6d 65 20 74 65 73 74 63 < testname testc
37b0: 6f 6e 66 69 67 20 77 61 69 74 6f 6e 73 20 70 72 onfig waitons pr
37c0: 69 6f 72 69 74 79 20 69 74 65 6d 73 2d 69 6e 66 iority items-inf
37d0: 6f 20 2e 2e 2e 20 3e 0a 28 64 65 66 69 6e 65 20 o ... >.(define
37e0: 28 72 75 6e 73 3a 72 75 6e 2d 74 65 73 74 73 2d (runs:run-tests-
37f0: 71 75 65 75 65 20 72 75 6e 2d 69 64 20 72 75 6e queue run-id run
3800: 6e 61 6d 65 20 74 65 73 74 2d 72 65 63 6f 72 64 name test-record
3810: 73 20 6b 65 79 76 61 6c 6c 73 74 20 66 6c 61 67 s keyvallst flag
3820: 73 20 74 65 73 74 2d 70 61 74 74 73 29 0a 20 20 s test-patts).
3830: 20 20 3b 3b 20 41 74 20 74 68 69 73 20 70 6f 69 ;; At this poi
3840: 6e 74 20 74 68 65 20 6c 69 73 74 20 6f 66 20 70 nt the list of p
3850: 61 72 65 6e 74 20 74 65 73 74 73 20 69 73 20 65 arent tests is e
3860: 78 70 61 6e 64 65 64 20 0a 20 20 20 20 3b 3b 20 xpanded . ;;
3870: 4e 42 2f 2f 20 53 68 6f 75 6c 64 20 65 78 70 61 NB// Should expa
3880: 6e 64 20 69 74 65 6d 73 20 68 65 72 65 20 61 6e nd items here an
3890: 64 20 74 68 65 6e 20 69 6e 73 65 72 74 20 69 6e d then insert in
38a0: 74 6f 20 74 68 65 20 72 75 6e 20 71 75 65 75 65 to the run queue
38b0: 2e 0a 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 .. (debug:print
38c0: 20 35 20 22 74 65 73 74 2d 72 65 63 6f 72 64 73 5 "test-records
38d0: 3a 20 22 20 74 65 73 74 2d 72 65 63 6f 72 64 73 : " test-records
38e0: 20 22 2c 20 6b 65 79 76 61 6c 6c 73 74 3a 20 22 ", keyvallst: "
38f0: 20 6b 65 79 76 61 6c 6c 73 74 20 22 20 66 6c 61 keyvallst " fla
3900: 67 73 3a 20 22 20 28 68 61 73 68 2d 74 61 62 6c gs: " (hash-tabl
3910: 65 2d 3e 61 6c 69 73 74 20 66 6c 61 67 73 29 29 e->alist flags))
3920: 0a 20 20 28 6c 65 74 20 28 28 73 6f 72 74 65 64 . (let ((sorted
3930: 2d 74 65 73 74 2d 6e 61 6d 65 73 20 28 74 65 73 -test-names (tes
3940: 74 73 3a 73 6f 72 74 2d 62 79 2d 70 72 69 6f 72 ts:sort-by-prior
3950: 69 74 79 2d 61 6e 64 2d 77 61 69 74 6f 6e 20 74 ity-and-waiton t
3960: 65 73 74 2d 72 65 63 6f 72 64 73 29 29 0a 09 28 est-records))..(
3970: 74 65 73 74 2d 72 65 67 69 73 74 65 72 79 20 20 test-registery
3980: 20 20 28 6d 61 6b 65 2d 68 61 73 68 2d 74 61 62 (make-hash-tab
3990: 6c 65 29 29 0a 09 28 72 65 67 69 73 74 65 72 79 le))..(registery
39a0: 2d 6d 75 74 65 78 20 20 20 28 6d 61 6b 65 2d 6d -mutex (make-m
39b0: 75 74 65 78 29 29 0a 09 28 6e 75 6d 2d 72 65 74 utex))..(num-ret
39c0: 72 69 65 73 20 20 20 20 20 20 20 20 30 29 0a 09 ries 0)..
39d0: 28 6d 61 78 2d 72 65 74 72 69 65 73 20 20 20 20 (max-retries
39e0: 20 20 20 28 63 6f 6e 66 69 67 2d 6c 6f 6f 6b 75 (config-looku
39f0: 70 20 2a 63 6f 6e 66 69 67 64 61 74 2a 20 22 73 p *configdat* "s
3a00: 65 74 75 70 22 20 22 6d 61 78 72 65 74 72 69 65 etup" "maxretrie
3a10: 73 22 29 29 29 0a 20 20 20 20 28 73 65 74 21 20 s"))). (set!
3a20: 6d 61 78 2d 72 65 74 72 69 65 73 20 28 69 66 20 max-retries (if
3a30: 28 61 6e 64 20 6d 61 78 2d 72 65 74 72 69 65 73 (and max-retries
3a40: 20 28 73 74 72 69 6e 67 2d 3e 6e 75 6d 62 65 72 (string->number
3a50: 20 6d 61 78 2d 72 65 74 72 69 65 73 29 29 28 73 max-retries))(s
3a60: 74 72 69 6e 67 2d 3e 6e 75 6d 62 65 72 20 6d 61 tring->number ma
3a70: 78 2d 72 65 74 72 69 65 73 29 20 31 30 30 29 29 x-retries) 100))
3a80: 0a 20 20 20 20 28 69 66 20 28 6e 6f 74 20 28 6e . (if (not (n
3a90: 75 6c 6c 3f 20 73 6f 72 74 65 64 2d 74 65 73 74 ull? sorted-test
3aa0: 2d 6e 61 6d 65 73 29 29 0a 09 28 6c 65 74 20 6c -names))..(let l
3ab0: 6f 6f 70 20 28 28 68 65 64 20 20 20 20 20 20 20 oop ((hed
3ac0: 20 20 28 63 61 72 20 73 6f 72 74 65 64 2d 74 65 (car sorted-te
3ad0: 73 74 2d 6e 61 6d 65 73 29 29 0a 09 09 20 20 20 st-names))...
3ae0: 28 74 61 6c 20 20 20 20 20 20 20 20 20 28 63 64 (tal (cd
3af0: 72 20 73 6f 72 74 65 64 2d 74 65 73 74 2d 6e 61 r sorted-test-na
3b00: 6d 65 73 29 29 0a 09 09 20 20 20 28 72 65 72 75 mes))... (reru
3b10: 6e 73 20 20 20 20 20 20 27 28 29 29 29 0a 09 20 ns '()))..
3b20: 20 28 69 66 20 28 6e 6f 74 20 28 6e 75 6c 6c 3f (if (not (null?
3b30: 20 72 65 72 75 6e 73 29 29 28 64 65 62 75 67 3a reruns))(debug:
3b40: 70 72 69 6e 74 2d 69 6e 66 6f 20 34 20 22 72 65 print-info 4 "re
3b50: 72 75 6e 73 3d 22 20 72 65 72 75 6e 73 29 29 0a runs=" reruns)).
3b60: 09 20 20 3b 3b 20 28 70 72 69 6e 74 20 22 54 6f . ;; (print "To
3b70: 70 20 6f 66 20 6c 6f 6f 70 2c 20 68 65 64 3d 22 p of loop, hed="
3b80: 20 68 65 64 20 22 2c 20 74 61 6c 3d 22 20 74 61 hed ", tal=" ta
3b90: 6c 20 22 20 2c 72 65 72 75 6e 73 3d 22 20 72 65 l " ,reruns=" re
3ba0: 72 75 6e 73 29 0a 09 20 20 28 6c 65 74 2a 20 28 runs).. (let* (
3bb0: 28 74 65 73 74 2d 72 65 63 6f 72 64 20 28 68 61 (test-record (ha
3bc0: 73 68 2d 74 61 62 6c 65 2d 72 65 66 20 74 65 73 sh-table-ref tes
3bd0: 74 2d 72 65 63 6f 72 64 73 20 68 65 64 29 29 0a t-records hed)).
3be0: 09 09 20 28 74 65 73 74 2d 6e 61 6d 65 20 20 20 .. (test-name
3bf0: 28 74 65 73 74 73 3a 74 65 73 74 71 75 65 75 65 (tests:testqueue
3c00: 2d 67 65 74 2d 74 65 73 74 6e 61 6d 65 20 74 65 -get-testname te
3c10: 73 74 2d 72 65 63 6f 72 64 29 29 0a 09 09 20 28 st-record))... (
3c20: 74 63 6f 6e 66 69 67 20 20 20 20 20 28 74 65 73 tconfig (tes
3c30: 74 73 3a 74 65 73 74 71 75 65 75 65 2d 67 65 74 ts:testqueue-get
3c40: 2d 74 65 73 74 63 6f 6e 66 69 67 20 74 65 73 74 -testconfig test
3c50: 2d 72 65 63 6f 72 64 29 29 0a 09 09 20 28 74 65 -record))... (te
3c60: 73 74 6d 6f 64 65 20 20 20 20 28 6c 65 74 20 28 stmode (let (
3c70: 28 6d 20 28 63 6f 6e 66 69 67 2d 6c 6f 6f 6b 75 (m (config-looku
3c80: 70 20 74 63 6f 6e 66 69 67 20 22 72 65 71 75 69 p tconfig "requi
3c90: 72 65 6d 65 6e 74 73 22 20 22 6d 6f 64 65 22 29 rements" "mode")
3ca0: 29 29 0a 09 09 09 09 28 69 66 20 6d 20 28 73 74 )).....(if m (st
3cb0: 72 69 6e 67 2d 3e 73 79 6d 62 6f 6c 20 6d 29 20 ring->symbol m)
3cc0: 27 6e 6f 72 6d 61 6c 29 29 29 0a 09 09 20 28 77 'normal)))... (w
3cd0: 61 69 74 6f 6e 73 20 20 20 20 20 28 74 65 73 74 aitons (test
3ce0: 73 3a 74 65 73 74 71 75 65 75 65 2d 67 65 74 2d s:testqueue-get-
3cf0: 77 61 69 74 6f 6e 73 20 20 20 20 74 65 73 74 2d waitons test-
3d00: 72 65 63 6f 72 64 29 29 0a 09 09 20 28 70 72 69 record))... (pri
3d10: 6f 72 69 74 79 20 20 20 20 28 74 65 73 74 73 3a ority (tests:
3d20: 74 65 73 74 71 75 65 75 65 2d 67 65 74 2d 70 72 testqueue-get-pr
3d30: 69 6f 72 69 74 79 20 20 20 74 65 73 74 2d 72 65 iority test-re
3d40: 63 6f 72 64 29 29 0a 09 09 20 28 69 74 65 6d 64 cord))... (itemd
3d50: 61 74 20 20 20 20 20 28 74 65 73 74 73 3a 74 65 at (tests:te
3d60: 73 74 71 75 65 75 65 2d 67 65 74 2d 69 74 65 6d stqueue-get-item
3d70: 64 61 74 20 20 20 20 74 65 73 74 2d 72 65 63 6f dat test-reco
3d80: 72 64 29 29 20 3b 3b 20 69 74 65 6d 64 61 74 20 rd)) ;; itemdat
3d90: 63 61 6e 20 62 65 20 61 20 73 74 72 69 6e 67 2c can be a string,
3da0: 20 6c 69 73 74 20 6f 72 20 23 66 0a 09 09 20 28 list or #f... (
3db0: 69 74 65 6d 73 20 20 20 20 20 20 20 28 74 65 73 items (tes
3dc0: 74 73 3a 74 65 73 74 71 75 65 75 65 2d 67 65 74 ts:testqueue-get
3dd0: 2d 69 74 65 6d 73 20 20 20 20 20 20 74 65 73 74 -items test
3de0: 2d 72 65 63 6f 72 64 29 29 0a 09 09 20 28 69 74 -record))... (it
3df0: 65 6d 2d 70 61 74 68 20 20 20 28 69 74 65 6d 2d em-path (item-
3e00: 6c 69 73 74 2d 3e 70 61 74 68 20 69 74 65 6d 64 list->path itemd
3e10: 61 74 29 29 0a 09 09 20 28 6e 65 77 74 61 6c 20 at))... (newtal
3e20: 20 20 20 20 20 28 61 70 70 65 6e 64 20 74 61 6c (append tal
3e30: 20 28 6c 69 73 74 20 68 65 64 29 29 29 29 0a 09 (list hed))))..
3e40: 20 20 20 20 0a 09 20 20 20 20 28 64 65 62 75 67 .. (debug
3e50: 3a 70 72 69 6e 74 20 36 0a 09 09 09 20 22 74 65 :print 6.... "te
3e60: 73 74 2d 6e 61 6d 65 3a 20 22 20 74 65 73 74 2d st-name: " test-
3e70: 6e 61 6d 65 0a 09 09 09 20 22 5c 6e 20 20 68 65 name.... "\n he
3e80: 64 3a 20 20 20 20 20 20 20 20 20 22 20 68 65 64 d: " hed
3e90: 0a 09 09 09 20 22 5c 6e 20 20 69 74 65 6d 64 61 .... "\n itemda
3ea0: 74 3a 20 20 20 20 20 22 20 69 74 65 6d 64 61 74 t: " itemdat
3eb0: 0a 09 09 09 20 22 5c 6e 20 20 69 74 65 6d 73 3a .... "\n items:
3ec0: 20 20 20 20 20 20 20 22 20 69 74 65 6d 73 0a 09 " items..
3ed0: 09 09 20 22 5c 6e 20 20 69 74 65 6d 2d 70 61 74 .. "\n item-pat
3ee0: 68 3a 20 20 20 22 20 69 74 65 6d 2d 70 61 74 68 h: " item-path
3ef0: 0a 09 09 09 20 22 5c 6e 20 20 77 61 69 74 6f 6e .... "\n waiton
3f00: 73 3a 20 20 20 20 20 22 20 77 61 69 74 6f 6e 73 s: " waitons
3f10: 0a 09 09 09 20 22 5c 6e 20 20 6e 75 6d 2d 72 65 .... "\n num-re
3f20: 74 72 69 65 73 3a 20 22 20 6e 75 6d 2d 72 65 74 tries: " num-ret
3f30: 72 69 65 73 0a 09 09 09 20 22 5c 6e 20 20 74 61 ries.... "\n ta
3f40: 6c 3a 20 20 20 20 20 20 20 20 20 22 20 74 61 6c l: " tal
3f50: 0a 09 09 09 20 22 5c 6e 20 20 72 65 72 75 6e 73 .... "\n reruns
3f60: 3a 20 20 20 20 20 20 22 20 72 65 72 75 6e 73 29 : " reruns)
3f70: 0a 0a 09 20 20 20 20 3b 3b 20 63 68 65 63 6b 20 ... ;; check
3f80: 66 6f 72 20 68 65 64 20 69 6e 20 77 61 69 74 6f for hed in waito
3f90: 6e 73 20 3d 3e 20 74 68 69 73 20 77 6f 75 6c 64 ns => this would
3fa0: 20 62 65 20 63 69 72 63 75 6c 61 72 2c 20 72 65 be circular, re
3fb0: 6d 6f 76 65 20 69 74 20 61 6e 64 20 69 73 73 75 move it and issu
3fc0: 65 20 61 6e 0a 09 20 20 20 20 3b 3b 20 65 72 72 e an.. ;; err
3fd0: 6f 72 0a 09 20 20 20 20 28 69 66 20 28 6d 65 6d or.. (if (mem
3fe0: 62 65 72 20 74 65 73 74 2d 6e 61 6d 65 20 77 61 ber test-name wa
3ff0: 69 74 6f 6e 73 29 0a 09 09 28 62 65 67 69 6e 0a itons)...(begin.
4000: 09 09 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 .. (debug:print
4010: 20 30 20 22 45 52 52 4f 52 3a 20 74 65 73 74 20 0 "ERROR: test
4020: 22 20 74 65 73 74 2d 6e 61 6d 65 20 22 20 68 61 " test-name " ha
4030: 73 20 6c 69 73 74 65 64 20 69 74 73 65 6c 66 20 s listed itself
4040: 61 73 20 61 20 77 61 69 74 6f 6e 2c 20 70 6c 65 as a waiton, ple
4050: 61 73 65 20 63 6f 72 72 65 63 74 20 74 68 69 73 ase correct this
4060: 21 22 29 0a 09 09 20 20 28 73 65 74 21 20 77 61 !")... (set! wa
4070: 69 74 6f 6e 20 28 66 69 6c 74 65 72 20 28 6c 61 iton (filter (la
4080: 6d 62 64 61 20 28 78 29 28 6e 6f 74 20 28 65 71 mbda (x)(not (eq
4090: 75 61 6c 3f 20 78 20 68 65 64 29 29 29 20 77 61 ual? x hed))) wa
40a0: 69 74 6f 6e 73 29 29 29 29 0a 0a 09 20 20 20 20 itons))))...
40b0: 28 63 6f 6e 64 20 3b 3b 20 4f 55 54 45 52 20 43 (cond ;; OUTER C
40c0: 4f 4e 44 0a 09 20 20 20 20 20 28 28 6e 6f 74 20 OND.. ((not
40d0: 69 74 65 6d 73 29 20 3b 3b 20 77 68 65 6e 20 66 items) ;; when f
40e0: 61 6c 73 65 20 74 68 65 20 74 65 73 74 20 69 73 alse the test is
40f0: 20 6f 6b 20 74 6f 20 62 65 20 68 61 6e 64 65 64 ok to be handed
4100: 20 6f 66 66 20 74 6f 20 6c 61 75 6e 63 68 20 28 off to launch (
4110: 62 75 74 20 6e 6f 74 20 62 65 66 6f 72 65 29 0a but not before).
4120: 09 20 20 20 20 20 20 28 6c 65 74 2a 20 28 28 72 . (let* ((r
4130: 75 6e 2d 6c 69 6d 69 74 73 2d 69 6e 66 6f 20 20 un-limits-info
4140: 20 20 20 20 20 20 20 28 72 75 6e 73 3a 63 61 6e (runs:can
4150: 2d 72 75 6e 2d 6d 6f 72 65 2d 74 65 73 74 73 20 -run-more-tests
4160: 74 65 73 74 2d 72 65 63 6f 72 64 29 29 20 3b 3b test-record)) ;;
4170: 20 6c 6f 6f 6b 20 61 74 20 74 68 65 20 74 65 73 look at the tes
4180: 74 20 6a 6f 62 67 72 6f 75 70 20 61 6e 64 20 74 t jobgroup and t
4190: 6f 74 20 6a 6f 62 73 20 72 75 6e 6e 69 6e 67 0a ot jobs running.
41a0: 09 09 20 20 20 20 20 28 68 61 76 65 2d 72 65 73 .. (have-res
41b0: 6f 75 72 63 65 73 20 20 20 20 20 20 20 20 20 20 ources
41c0: 28 63 61 72 20 72 75 6e 2d 6c 69 6d 69 74 73 2d (car run-limits-
41d0: 69 6e 66 6f 29 29 0a 09 09 20 20 20 20 20 28 6e info))... (n
41e0: 75 6d 2d 72 75 6e 6e 69 6e 67 20 20 20 20 20 20 um-running
41f0: 20 20 20 20 20 20 20 28 6c 69 73 74 2d 72 65 66 (list-ref
4200: 20 72 75 6e 2d 6c 69 6d 69 74 73 2d 69 6e 66 6f run-limits-info
4210: 20 31 29 29 0a 09 09 20 20 20 20 20 28 6e 75 6d 1))... (num
4220: 2d 72 75 6e 6e 69 6e 67 2d 69 6e 2d 6a 6f 62 67 -running-in-jobg
4230: 72 6f 75 70 20 28 6c 69 73 74 2d 72 65 66 20 72 roup (list-ref r
4240: 75 6e 2d 6c 69 6d 69 74 73 2d 69 6e 66 6f 20 32 un-limits-info 2
4250: 29 29 0a 09 09 20 20 20 20 20 28 6d 61 78 2d 63 ))... (max-c
4260: 6f 6e 63 75 72 72 65 6e 74 2d 6a 6f 62 73 20 20 oncurrent-jobs
4270: 20 20 20 28 6c 69 73 74 2d 72 65 66 20 72 75 6e (list-ref run
4280: 2d 6c 69 6d 69 74 73 2d 69 6e 66 6f 20 33 29 29 -limits-info 3))
4290: 0a 09 09 20 20 20 20 20 28 6a 6f 62 2d 67 72 6f ... (job-gro
42a0: 75 70 2d 6c 69 6d 69 74 20 20 20 20 20 20 20 20 up-limit
42b0: 20 28 6c 69 73 74 2d 72 65 66 20 72 75 6e 2d 6c (list-ref run-l
42c0: 69 6d 69 74 73 2d 69 6e 66 6f 20 34 29 29 0a 09 imits-info 4))..
42d0: 09 20 20 20 20 20 28 70 72 65 72 65 71 73 2d 6e . (prereqs-n
42e0: 6f 74 2d 6d 65 74 20 20 20 20 20 20 20 20 20 28 ot-met (
42f0: 63 64 62 3a 72 65 6d 6f 74 65 2d 72 75 6e 20 64 cdb:remote-run d
4300: 62 3a 67 65 74 2d 70 72 65 72 65 71 73 2d 6e 6f b:get-prereqs-no
4310: 74 2d 6d 65 74 20 23 66 20 72 75 6e 2d 69 64 20 t-met #f run-id
4320: 77 61 69 74 6f 6e 73 20 69 74 65 6d 2d 70 61 74 waitons item-pat
4330: 68 20 6d 6f 64 65 3a 20 74 65 73 74 6d 6f 64 65 h mode: testmode
4340: 29 29 0a 09 09 20 20 20 20 20 28 66 61 69 6c 73 ))... (fails
4350: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
4360: 20 20 20 28 72 75 6e 73 3a 63 61 6c 63 2d 66 61 (runs:calc-fa
4370: 69 6c 73 20 70 72 65 72 65 71 73 2d 6e 6f 74 2d ils prereqs-not-
4380: 6d 65 74 29 29 0a 09 09 20 20 20 20 20 28 6e 6f met))... (no
4390: 6e 2d 63 6f 6d 70 6c 65 74 65 64 20 20 20 20 20 n-completed
43a0: 20 20 20 20 20 20 28 72 75 6e 73 3a 63 61 6c 63 (runs:calc
43b0: 2d 6e 6f 74 2d 63 6f 6d 70 6c 65 74 65 64 20 70 -not-completed p
43c0: 72 65 72 65 71 73 2d 6e 6f 74 2d 6d 65 74 29 29 rereqs-not-met))
43d0: 29 0a 09 09 28 64 65 62 75 67 3a 70 72 69 6e 74 )...(debug:print
43e0: 2d 69 6e 66 6f 20 38 20 22 68 61 76 65 2d 72 65 -info 8 "have-re
43f0: 73 6f 75 72 63 65 73 3a 20 22 20 68 61 76 65 2d sources: " have-
4400: 72 65 73 6f 75 72 63 65 73 20 22 20 70 72 65 72 resources " prer
4410: 65 71 73 2d 6e 6f 74 2d 6d 65 74 3a 20 22 20 0a eqs-not-met: " .
4420: 09 09 09 20 20 20 20 20 28 73 74 72 69 6e 67 2d ... (string-
4430: 69 6e 74 65 72 73 70 65 72 73 65 20 0a 09 09 09 intersperse ....
4440: 20 20 20 20 20 20 28 6d 61 70 20 28 6c 61 6d 62 (map (lamb
4450: 64 61 20 28 74 29 0a 09 09 09 09 20 20 20 20 20 da (t).....
4460: 28 69 66 20 28 76 65 63 74 6f 72 3f 20 74 29 0a (if (vector? t).
4470: 09 09 09 09 09 20 28 63 6f 6e 63 20 28 64 62 3a ..... (conc (db:
4480: 74 65 73 74 2d 67 65 74 2d 73 74 61 74 65 20 74 test-get-state t
4490: 29 20 22 2f 22 20 28 64 62 3a 74 65 73 74 2d 67 ) "/" (db:test-g
44a0: 65 74 2d 73 74 61 74 75 73 20 74 29 29 0a 09 09 et-status t))...
44b0: 09 09 09 20 28 63 6f 6e 63 20 22 20 57 41 52 4e ... (conc " WARN
44c0: 49 4e 47 3a 20 74 20 69 73 20 6e 6f 74 20 61 20 ING: t is not a
44d0: 76 65 63 74 6f 72 3d 22 20 74 20 29 29 29 0a 09 vector=" t )))..
44e0: 09 09 09 20 20 20 70 72 65 72 65 71 73 2d 6e 6f ... prereqs-no
44f0: 74 2d 6d 65 74 29 20 22 2c 20 22 29 20 22 20 66 t-met) ", ") " f
4500: 61 69 6c 73 3a 20 22 20 66 61 69 6c 73 29 0a 09 ails: " fails)..
4510: 09 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e .(debug:print-in
4520: 66 6f 20 34 20 22 68 65 64 3d 22 20 68 65 64 20 fo 4 "hed=" hed
4530: 22 5c 6e 20 20 74 65 73 74 2d 72 65 63 6f 72 64 "\n test-record
4540: 3d 22 20 74 65 73 74 2d 72 65 63 6f 72 64 20 22 =" test-record "
4550: 5c 6e 20 20 74 65 73 74 2d 6e 61 6d 65 3a 20 22 \n test-name: "
4560: 20 74 65 73 74 2d 6e 61 6d 65 20 22 5c 6e 20 20 test-name "\n
4570: 69 74 65 6d 2d 70 61 74 68 3a 20 22 20 69 74 65 item-path: " ite
4580: 6d 2d 70 61 74 68 20 22 5c 6e 20 20 74 65 73 74 m-path "\n test
4590: 2d 70 61 74 74 73 3a 20 22 20 74 65 73 74 2d 70 -patts: " test-p
45a0: 61 74 74 73 29 0a 0a 09 09 3b 3b 20 44 6f 6e 27 atts)....;; Don'
45b0: 74 20 6b 6e 6f 77 20 61 74 20 74 68 69 73 20 74 t know at this t
45c0: 69 6d 65 20 69 66 20 74 68 65 20 74 65 73 74 20 ime if the test
45d0: 68 61 76 65 20 62 65 65 6e 20 6c 61 75 6e 63 68 have been launch
45e0: 65 64 20 61 74 20 73 6f 6d 65 20 74 69 6d 65 20 ed at some time
45f0: 69 6e 20 74 68 65 20 70 61 73 74 0a 09 09 3b 3b in the past...;;
4600: 20 69 2e 65 2e 20 69 73 20 74 68 69 73 20 61 20 i.e. is this a
4610: 72 65 2d 6c 61 75 6e 63 68 3f 0a 09 09 28 64 65 re-launch?...(de
4620: 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 34 bug:print-info 4
4630: 20 22 72 75 6e 2d 6c 69 6d 69 74 73 2d 69 6e 66 "run-limits-inf
4640: 6f 20 3d 20 22 20 72 75 6e 2d 6c 69 6d 69 74 73 o = " run-limits
4650: 2d 69 6e 66 6f 29 0a 09 09 28 63 6f 6e 64 20 3b -info)...(cond ;
4660: 3b 20 49 4e 4e 45 52 20 43 4f 4e 44 20 23 31 20 ; INNER COND #1
4670: 66 6f 72 20 61 20 6c 61 75 6e 63 68 61 62 6c 65 for a launchable
4680: 20 74 65 73 74 0a 09 09 20 3b 3b 20 43 68 65 63 test... ;; Chec
4690: 6b 20 69 74 65 6d 20 70 61 74 68 20 61 67 61 69 k item path agai
46a0: 6e 73 74 20 69 74 65 6d 2d 70 61 74 74 73 0a 09 nst item-patts..
46b0: 09 20 28 28 6e 6f 74 20 28 74 65 73 74 73 3a 6d . ((not (tests:m
46c0: 61 74 63 68 20 74 65 73 74 2d 70 61 74 74 73 20 atch test-patts
46d0: 28 74 65 73 74 73 3a 74 65 73 74 71 75 65 75 65 (tests:testqueue
46e0: 2d 67 65 74 2d 74 65 73 74 6e 61 6d 65 20 74 65 -get-testname te
46f0: 73 74 2d 72 65 63 6f 72 64 29 20 69 74 65 6d 2d st-record) item-
4700: 70 61 74 68 29 29 20 3b 3b 20 54 68 69 73 20 74 path)) ;; This t
4710: 65 73 74 2f 69 74 65 6d 70 61 74 68 20 69 73 20 est/itempath is
4720: 6e 6f 74 20 74 6f 20 62 65 20 72 75 6e 0a 09 09 not to be run...
4730: 20 20 3b 3b 20 65 6c 73 65 20 74 68 65 20 72 75 ;; else the ru
4740: 6e 20 69 73 20 73 74 75 63 6b 2c 20 74 65 6d 70 n is stuck, temp
4750: 6f 72 61 72 69 6c 79 20 6f 72 20 70 65 72 6d 61 orarily or perma
4760: 6e 65 6e 74 6c 79 0a 09 09 20 20 3b 3b 20 62 75 nently... ;; bu
4770: 74 20 73 68 6f 75 6c 64 20 63 68 65 63 6b 20 69 t should check i
4780: 66 20 69 74 20 69 73 20 64 75 65 20 74 6f 20 6c f it is due to l
4790: 61 63 6b 20 6f 66 20 72 65 73 6f 75 72 63 65 73 ack of resources
47a0: 20 76 73 2e 20 70 72 65 72 65 71 75 69 73 69 74 vs. prerequisit
47b0: 65 73 0a 09 09 20 20 28 64 65 62 75 67 3a 70 72 es... (debug:pr
47c0: 69 6e 74 2d 69 6e 66 6f 20 31 20 22 53 6b 69 70 int-info 1 "Skip
47d0: 70 69 6e 67 20 22 20 28 74 65 73 74 73 3a 74 65 ping " (tests:te
47e0: 73 74 71 75 65 75 65 2d 67 65 74 2d 74 65 73 74 stqueue-get-test
47f0: 6e 61 6d 65 20 74 65 73 74 2d 72 65 63 6f 72 64 name test-record
4800: 29 20 22 20 22 20 69 74 65 6d 2d 70 61 74 68 20 ) " " item-path
4810: 22 20 61 73 20 69 74 20 64 6f 65 73 6e 27 74 20 " as it doesn't
4820: 6d 61 74 63 68 20 22 20 74 65 73 74 2d 70 61 74 match " test-pat
4830: 74 73 29 0a 09 09 20 20 3b 3b 20 28 74 68 72 65 ts)... ;; (thre
4840: 61 64 2d 73 6c 65 65 70 21 20 2a 67 6c 6f 62 61 ad-sleep! *globa
4850: 6c 2d 64 65 6c 74 61 2a 29 0a 09 09 20 20 28 69 l-delta*)... (i
4860: 66 20 28 6e 6f 74 20 28 6e 75 6c 6c 3f 20 74 61 f (not (null? ta
4870: 6c 29 29 0a 09 09 20 20 20 20 20 20 28 6c 6f 6f l))... (loo
4880: 70 20 28 63 61 72 20 74 61 6c 29 28 63 64 72 20 p (car tal)(cdr
4890: 74 61 6c 29 20 72 65 72 75 6e 73 29 29 29 0a 09 tal) reruns)))..
48a0: 09 20 3b 3b 20 52 65 67 69 73 74 65 72 79 20 68 . ;; Registery h
48b0: 61 73 20 62 65 65 6e 20 73 74 61 72 74 65 64 20 as been started
48c0: 66 6f 72 20 74 68 69 73 20 74 65 73 74 20 62 75 for this test bu
48d0: 74 20 68 61 73 20 6e 6f 74 20 79 65 74 20 63 6f t has not yet co
48e0: 6d 70 6c 65 74 65 64 0a 09 09 20 3b 3b 20 74 68 mpleted... ;; th
48f0: 69 73 20 73 68 6f 75 6c 64 20 62 65 20 72 61 72 is should be rar
4900: 65 2c 20 74 68 65 20 63 61 73 65 20 77 68 65 72 e, the case wher
4910: 65 20 74 68 65 72 65 20 61 72 65 20 6f 6e 6c 79 e there are only
4920: 20 61 20 63 6f 75 70 6c 65 20 6f 66 20 74 65 73 a couple of tes
4930: 74 73 20 61 6e 64 20 74 68 65 20 64 62 20 69 73 ts and the db is
4940: 20 73 6c 6f 77 0a 09 09 20 3b 3b 20 64 65 6c 61 slow... ;; dela
4950: 79 20 61 20 73 68 6f 72 74 20 77 68 69 6c 65 20 y a short while
4960: 61 6e 64 20 63 6f 6e 74 69 6e 75 65 0a 09 09 20 and continue...
4970: 3b 3b 20 28 28 65 71 3f 20 28 68 61 73 68 2d 74 ;; ((eq? (hash-t
4980: 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 able-ref/default
4990: 20 74 65 73 74 2d 72 65 67 69 73 74 65 72 79 20 test-registery
49a0: 28 72 75 6e 73 3a 6d 61 6b 65 2d 66 75 6c 6c 2d (runs:make-full-
49b0: 74 65 73 74 2d 6e 61 6d 65 20 74 65 73 74 2d 6e test-name test-n
49c0: 61 6d 65 20 69 74 65 6d 2d 70 61 74 68 29 20 23 ame item-path) #
49d0: 66 29 20 27 73 74 61 72 74 29 0a 09 09 20 3b 3b f) 'start)... ;;
49e0: 20 20 28 74 68 72 65 61 64 2d 73 6c 65 65 70 21 (thread-sleep!
49f0: 20 30 2e 30 31 29 0a 09 09 20 3b 3b 20 20 28 6c 0.01)... ;; (l
4a00: 6f 6f 70 20 28 63 61 72 20 6e 65 77 74 61 6c 29 oop (car newtal)
4a10: 28 63 64 72 20 6e 65 77 74 61 6c 29 20 72 65 72 (cdr newtal) rer
4a20: 75 6e 73 29 29 0a 09 09 20 3b 3b 20 63 6f 75 6e uns))... ;; coun
4a30: 74 20 6e 75 6d 62 65 72 20 6f 66 20 27 64 6f 6e t number of 'don
4a40: 65 2c 20 69 66 20 6d 6f 72 65 20 74 68 61 6e 20 e, if more than
4a50: 31 30 30 20 74 68 65 6e 20 73 6b 69 70 20 6f 6e 100 then skip on
4a60: 20 74 68 72 6f 75 67 68 2e 0a 09 09 20 28 3b 3b through.... (;;
4a70: 20 28 61 6e 64 20 28 3c 20 28 6c 65 6e 67 74 68 (and (< (length
4a80: 20 28 66 69 6c 74 65 72 20 28 6c 61 6d 62 64 61 (filter (lambda
4a90: 20 28 78 29 28 65 71 3f 20 78 20 27 64 6f 6e 65 (x)(eq? x 'done
4aa0: 29 29 28 68 61 73 68 2d 74 61 62 6c 65 2d 76 61 ))(hash-table-va
4ab0: 6c 75 65 73 20 74 65 73 74 2d 72 65 67 69 73 74 lues test-regist
4ac0: 65 72 79 29 29 29 20 31 30 30 29 20 3b 3b 20 77 ery))) 100) ;; w
4ad0: 68 79 20 67 65 74 20 6d 6f 72 65 20 74 68 61 6e hy get more than
4ae0: 20 32 30 30 20 61 68 65 61 64 3f 0a 09 09 20 20 200 ahead?...
4af0: 28 6e 6f 74 20 28 68 61 73 68 2d 74 61 62 6c 65 (not (hash-table
4b00: 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 74 65 73 -ref/default tes
4b10: 74 2d 72 65 67 69 73 74 65 72 79 20 28 72 75 6e t-registery (run
4b20: 73 3a 6d 61 6b 65 2d 66 75 6c 6c 2d 74 65 73 74 s:make-full-test
4b30: 2d 6e 61 6d 65 20 74 65 73 74 2d 6e 61 6d 65 20 -name test-name
4b40: 69 74 65 6d 2d 70 61 74 68 29 20 23 66 29 29 20 item-path) #f))
4b50: 3b 3b 20 29 20 3b 3b 20 74 6f 6f 20 6d 61 6e 79 ;; ) ;; too many
4b60: 20 63 68 61 6e 67 65 73 20 72 65 71 75 69 72 65 changes require
4b70: 64 2e 20 49 6d 70 6c 65 6d 65 6e 74 20 6c 61 74 d. Implement lat
4b80: 65 72 2e 0a 09 09 20 20 28 64 65 62 75 67 3a 70 er.... (debug:p
4b90: 72 69 6e 74 2d 69 6e 66 6f 20 34 20 22 50 72 65 rint-info 4 "Pre
4ba0: 2d 72 65 67 69 73 74 65 72 69 6e 67 20 74 65 73 -registering tes
4bb0: 74 20 22 20 74 65 73 74 2d 6e 61 6d 65 20 22 2f t " test-name "/
4bc0: 22 20 69 74 65 6d 2d 70 61 74 68 20 22 20 74 6f " item-path " to
4bd0: 20 63 72 65 61 74 65 20 70 6c 61 63 65 68 6f 6c create placehol
4be0: 64 65 72 22 20 29 0a 09 09 20 20 3b 3b 20 4e 45 der" )... ;; NE
4bf0: 45 44 20 54 4f 20 54 48 52 45 41 44 49 46 59 20 ED TO THREADIFY
4c00: 54 48 49 53 0a 09 09 20 20 28 6c 65 74 20 28 28 THIS... (let ((
4c10: 74 68 20 28 6d 61 6b 65 2d 74 68 72 65 61 64 20 th (make-thread
4c20: 28 6c 61 6d 62 64 61 20 28 29 0a 09 09 20 20 20 (lambda ()...
4c30: 20 20 20 20 20 09 09 20 20 20 28 6d 75 74 65 78 .. (mutex
4c40: 2d 6c 6f 63 6b 21 20 72 65 67 69 73 74 65 72 79 -lock! registery
4c50: 2d 6d 75 74 65 78 29 0a 09 09 20 20 20 20 20 20 -mutex)...
4c60: 20 20 09 09 20 20 20 28 68 61 73 68 2d 74 61 62 .. (hash-tab
4c70: 6c 65 2d 73 65 74 21 20 74 65 73 74 2d 72 65 67 le-set! test-reg
4c80: 69 73 74 65 72 79 20 28 72 75 6e 73 3a 6d 61 6b istery (runs:mak
4c90: 65 2d 66 75 6c 6c 2d 74 65 73 74 2d 6e 61 6d 65 e-full-test-name
4ca0: 20 74 65 73 74 2d 6e 61 6d 65 20 69 74 65 6d 2d test-name item-
4cb0: 70 61 74 68 29 20 27 73 74 61 72 74 29 0a 09 09 path) 'start)...
4cc0: 20 20 20 20 20 20 20 20 09 09 20 20 20 28 6d 75 .. (mu
4cd0: 74 65 78 2d 75 6e 6c 6f 63 6b 21 20 72 65 67 69 tex-unlock! regi
4ce0: 73 74 65 72 79 2d 6d 75 74 65 78 29 0a 09 09 09 stery-mutex)....
4cf0: 09 09 20 20 20 3b 3b 20 49 66 20 68 61 76 65 6e .. ;; If haven
4d00: 27 74 20 64 6f 6e 65 20 69 74 20 62 65 66 6f 72 't done it befor
4d10: 65 20 72 65 67 69 73 74 65 72 20 61 20 74 6f 70 e register a top
4d20: 20 6c 65 76 65 6c 20 74 65 73 74 20 69 66 20 74 level test if t
4d30: 68 69 73 20 69 73 20 61 6e 20 69 74 65 6d 69 7a his is an itemiz
4d40: 65 64 20 74 65 73 74 0a 09 09 09 09 09 20 20 20 ed test......
4d50: 28 69 66 20 28 6e 6f 74 20 28 65 71 3f 20 28 68 (if (not (eq? (h
4d60: 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 ash-table-ref/de
4d70: 66 61 75 6c 74 20 74 65 73 74 2d 72 65 67 69 73 fault test-regis
4d80: 74 65 72 79 20 28 72 75 6e 73 3a 6d 61 6b 65 2d tery (runs:make-
4d90: 66 75 6c 6c 2d 74 65 73 74 2d 6e 61 6d 65 20 74 full-test-name t
4da0: 65 73 74 2d 6e 61 6d 65 20 22 22 29 20 23 66 29 est-name "") #f)
4db0: 20 27 64 6f 6e 65 29 29 0a 09 09 09 09 09 20 20 'done))......
4dc0: 20 20 20 20 20 28 63 64 62 3a 74 65 73 74 73 2d (cdb:tests-
4dd0: 72 65 67 69 73 74 65 72 2d 74 65 73 74 20 2a 72 register-test *r
4de0: 75 6e 72 65 6d 6f 74 65 2a 20 72 75 6e 2d 69 64 unremote* run-id
4df0: 20 74 65 73 74 2d 6e 61 6d 65 20 22 22 29 29 0a test-name "")).
4e00: 09 09 09 09 09 20 20 20 28 63 64 62 3a 74 65 73 ..... (cdb:tes
4e10: 74 73 2d 72 65 67 69 73 74 65 72 2d 74 65 73 74 ts-register-test
4e20: 20 2a 72 75 6e 72 65 6d 6f 74 65 2a 20 72 75 6e *runremote* run
4e30: 2d 69 64 20 74 65 73 74 2d 6e 61 6d 65 20 69 74 -id test-name it
4e40: 65 6d 2d 70 61 74 68 29 0a 09 09 20 20 20 20 20 em-path)...
4e50: 20 20 20 09 09 20 20 20 28 6d 75 74 65 78 2d 6c .. (mutex-l
4e60: 6f 63 6b 21 20 72 65 67 69 73 74 65 72 79 2d 6d ock! registery-m
4e70: 75 74 65 78 29 0a 09 09 09 09 09 20 20 20 28 68 utex)...... (h
4e80: 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 74 ash-table-set! t
4e90: 65 73 74 2d 72 65 67 69 73 74 65 72 79 20 28 72 est-registery (r
4ea0: 75 6e 73 3a 6d 61 6b 65 2d 66 75 6c 6c 2d 74 65 uns:make-full-te
4eb0: 73 74 2d 6e 61 6d 65 20 74 65 73 74 2d 6e 61 6d st-name test-nam
4ec0: 65 20 69 74 65 6d 2d 70 61 74 68 29 20 27 64 6f e item-path) 'do
4ed0: 6e 65 29 0a 09 09 20 20 20 20 20 20 20 20 09 09 ne)... ..
4ee0: 20 20 20 28 6d 75 74 65 78 2d 75 6e 6c 6f 63 6b (mutex-unlock
4ef0: 21 20 72 65 67 69 73 74 65 72 79 2d 6d 75 74 65 ! registery-mute
4f00: 78 29 29 0a 09 09 20 20 20 20 20 20 20 20 09 09 x))... ..
4f10: 20 28 63 6f 6e 63 20 74 65 73 74 2d 6e 61 6d 65 (conc test-name
4f20: 20 22 2f 22 20 69 74 65 6d 2d 70 61 74 68 29 29 "/" item-path))
4f30: 29 29 0a 09 09 20 20 20 20 28 74 68 72 65 61 64 ))... (thread
4f40: 2d 73 74 61 72 74 21 20 74 68 29 29 0a 09 09 20 -start! th))...
4f50: 20 28 74 68 72 65 61 64 2d 73 6c 65 65 70 21 20 (thread-sleep!
4f60: 2a 67 6c 6f 62 61 6c 2d 64 65 6c 74 61 2a 29 0a *global-delta*).
4f70: 09 09 20 20 28 72 75 6e 73 3a 73 68 72 69 6e 6b .. (runs:shrink
4f80: 2d 63 61 6e 2d 72 75 6e 2d 6d 6f 72 65 2d 74 65 -can-run-more-te
4f90: 73 74 73 2d 64 65 6c 61 79 29 20 20 20 3b 3b 20 sts-delay) ;;
4fa0: 44 45 4c 41 59 20 54 57 45 41 4b 45 52 20 28 73 DELAY TWEAKER (s
4fb0: 74 69 6c 6c 20 6e 65 65 64 65 64 3f 29 0a 09 09 till needed?)...
4fc0: 20 20 28 6c 6f 6f 70 20 28 63 61 72 20 6e 65 77 (loop (car new
4fd0: 74 61 6c 29 28 63 64 72 20 6e 65 77 74 61 6c 29 tal)(cdr newtal)
4fe0: 20 72 65 72 75 6e 73 29 29 0a 09 09 20 3b 3b 20 reruns))... ;;
4ff0: 41 74 20 74 68 69 73 20 70 6f 69 6e 74 20 2a 61 At this point *a
5000: 6c 6c 2a 20 74 65 73 74 20 72 65 67 69 73 74 72 ll* test registr
5010: 61 74 69 6f 6e 73 20 6d 75 73 74 20 62 65 20 63 ations must be c
5020: 6f 6d 70 6c 65 74 65 64 2e 0a 09 09 20 28 28 6e ompleted.... ((n
5030: 6f 74 20 28 6e 75 6c 6c 3f 20 28 66 69 6c 74 65 ot (null? (filte
5040: 72 20 28 6c 61 6d 62 64 61 20 28 78 29 28 65 71 r (lambda (x)(eq
5050: 3f 20 27 73 74 61 72 74 20 78 29 29 28 68 61 73 ? 'start x))(has
5060: 68 2d 74 61 62 6c 65 2d 76 61 6c 75 65 73 20 74 h-table-values t
5070: 65 73 74 2d 72 65 67 69 73 74 65 72 79 29 29 29 est-registery)))
5080: 29 0a 09 09 20 20 28 64 65 62 75 67 3a 70 72 69 )... (debug:pri
5090: 6e 74 2d 69 6e 66 6f 20 30 20 22 57 61 69 74 69 nt-info 0 "Waiti
50a0: 6e 67 20 6f 6e 20 74 65 73 74 20 72 65 67 69 73 ng on test regis
50b0: 74 72 61 74 69 6f 6e 73 3a 20 22 20 28 73 74 72 trations: " (str
50c0: 69 6e 67 2d 69 6e 74 65 72 73 70 65 72 73 65 20 ing-intersperse
50d0: 0a 09 09 09 09 09 09 09 09 09 20 28 66 69 6c 74 .......... (filt
50e0: 65 72 20 28 6c 61 6d 62 64 61 20 28 78 29 0a 09 er (lambda (x)..
50f0: 09 09 09 09 09 09 09 09 09 20 20 20 28 65 71 3f ......... (eq?
5100: 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 (hash-table-ref
5110: 2f 64 65 66 61 75 6c 74 20 74 65 73 74 2d 72 65 /default test-re
5120: 67 69 73 74 65 72 79 20 78 20 23 66 29 20 27 73 gistery x #f) 's
5130: 74 61 72 74 29 29 0a 09 09 09 09 09 09 09 09 09 tart))..........
5140: 09 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 6b 65 . (hash-table-ke
5150: 79 73 20 74 65 73 74 2d 72 65 67 69 73 74 65 72 ys test-register
5160: 79 29 29 0a 09 09 09 09 09 09 09 09 09 20 22 2c y)).......... ",
5170: 20 22 29 29 0a 09 09 20 20 28 74 68 72 65 61 64 "))... (thread
5180: 2d 73 6c 65 65 70 21 20 30 2e 31 29 0a 09 09 20 -sleep! 0.1)...
5190: 20 28 6c 6f 6f 70 20 68 65 64 20 74 61 6c 20 72 (loop hed tal r
51a0: 65 72 75 6e 73 29 29 0a 09 09 20 28 28 6e 6f 74 eruns))... ((not
51b0: 20 68 61 76 65 2d 72 65 73 6f 75 72 63 65 73 29 have-resources)
51c0: 20 3b 3b 20 73 69 6d 70 6c 79 20 74 72 79 20 61 ;; simply try a
51d0: 67 61 69 6e 20 61 66 74 65 72 20 77 61 69 74 69 gain after waiti
51e0: 6e 67 20 61 20 73 65 63 6f 6e 64 0a 09 09 20 20 ng a second...
51f0: 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 (debug:print-inf
5200: 6f 20 31 20 22 6e 6f 20 72 65 73 6f 75 72 63 65 o 1 "no resource
5210: 73 20 74 6f 20 72 75 6e 20 6e 65 77 20 74 65 73 s to run new tes
5220: 74 73 2c 20 77 61 69 74 69 6e 67 20 2e 2e 2e 22 ts, waiting ..."
5230: 29 0a 09 09 20 20 3b 3b 20 48 61 76 65 20 67 6f )... ;; Have go
5240: 6e 65 20 62 61 63 6b 20 61 6e 64 20 66 6f 72 74 ne back and fort
5250: 68 20 6f 6e 20 74 68 69 73 20 62 75 74 20 64 62 h on this but db
5260: 20 73 74 61 72 76 61 74 69 6f 6e 20 69 73 20 61 starvation is a
5270: 6e 20 69 73 73 75 65 2e 0a 09 09 20 20 3b 3b 20 n issue.... ;;
5280: 77 61 69 74 20 6f 6e 65 20 73 65 63 6f 6e 64 20 wait one second
5290: 62 65 66 6f 72 65 20 6c 6f 6f 6b 69 6e 67 20 61 before looking a
52a0: 67 61 69 6e 20 74 6f 20 72 75 6e 20 6a 6f 62 73 gain to run jobs
52b0: 2e 0a 09 09 20 20 28 74 68 72 65 61 64 2d 73 6c .... (thread-sl
52c0: 65 65 70 21 20 31 29 20 3b 3b 20 28 2b 20 32 20 eep! 1) ;; (+ 2
52d0: 2a 67 6c 6f 62 61 6c 2d 64 65 6c 74 61 2a 29 29 *global-delta*))
52e0: 0a 09 09 20 20 3b 3b 20 63 6f 75 6c 64 20 68 61 ... ;; could ha
52f0: 76 65 20 64 6f 6e 65 20 68 65 64 20 74 61 6c 20 ve done hed tal
5300: 68 65 72 65 20 62 75 74 20 64 6f 69 6e 67 20 63 here but doing c
5310: 61 72 2f 63 64 72 20 6f 66 20 6e 65 77 74 61 6c ar/cdr of newtal
5320: 20 74 6f 20 72 6f 74 61 74 65 20 74 65 73 74 73 to rotate tests
5330: 0a 09 09 20 20 28 6c 6f 6f 70 20 28 63 61 72 20 ... (loop (car
5340: 6e 65 77 74 61 6c 29 28 63 64 72 20 6e 65 77 74 newtal)(cdr newt
5350: 61 6c 29 20 72 65 72 75 6e 73 29 29 0a 09 09 20 al) reruns))...
5360: 28 28 61 6e 64 20 68 61 76 65 2d 72 65 73 6f 75 ((and have-resou
5370: 72 63 65 73 0a 09 09 20 20 20 20 20 20 20 28 6f rces... (o
5380: 72 20 28 6e 75 6c 6c 3f 20 70 72 65 72 65 71 73 r (null? prereqs
5390: 2d 6e 6f 74 2d 6d 65 74 29 0a 09 09 09 20 20 20 -not-met)....
53a0: 28 61 6e 64 20 28 65 71 3f 20 74 65 73 74 6d 6f (and (eq? testmo
53b0: 64 65 20 27 74 6f 70 6c 65 76 65 6c 29 0a 09 09 de 'toplevel)...
53c0: 09 09 28 6e 75 6c 6c 3f 20 6e 6f 6e 2d 63 6f 6d ..(null? non-com
53d0: 70 6c 65 74 65 64 29 29 29 29 0a 09 09 20 20 28 pleted))))... (
53e0: 72 75 6e 3a 74 65 73 74 20 72 75 6e 2d 69 64 20 run:test run-id
53f0: 72 75 6e 6e 61 6d 65 20 6b 65 79 76 61 6c 6c 73 runname keyvalls
5400: 74 20 74 65 73 74 2d 72 65 63 6f 72 64 20 66 6c t test-record fl
5410: 61 67 73 20 23 66 29 0a 09 09 20 20 28 68 61 73 ags #f)... (has
5420: 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 74 65 73 h-table-set! tes
5430: 74 2d 72 65 67 69 73 74 65 72 79 20 28 72 75 6e t-registery (run
5440: 73 3a 6d 61 6b 65 2d 66 75 6c 6c 2d 74 65 73 74 s:make-full-test
5450: 2d 6e 61 6d 65 20 74 65 73 74 2d 6e 61 6d 65 20 -name test-name
5460: 69 74 65 6d 2d 70 61 74 68 29 20 27 72 75 6e 6e item-path) 'runn
5470: 69 6e 67 29 0a 09 09 20 20 28 72 75 6e 73 3a 73 ing)... (runs:s
5480: 68 72 69 6e 6b 2d 63 61 6e 2d 72 75 6e 2d 6d 6f hrink-can-run-mo
5490: 72 65 2d 74 65 73 74 73 2d 64 65 6c 61 79 29 20 re-tests-delay)
54a0: 20 3b 3b 20 44 45 4c 41 59 20 54 57 45 41 4b 45 ;; DELAY TWEAKE
54b0: 52 20 28 73 74 69 6c 6c 20 6e 65 65 64 65 64 3f R (still needed?
54c0: 29 0a 09 09 20 20 3b 3b 20 28 74 68 72 65 61 64 )... ;; (thread
54d0: 2d 73 6c 65 65 70 21 20 2a 67 6c 6f 62 61 6c 2d -sleep! *global-
54e0: 64 65 6c 74 61 2a 29 0a 09 09 20 20 28 69 66 20 delta*)... (if
54f0: 28 6e 6f 74 20 28 6e 75 6c 6c 3f 20 74 61 6c 29 (not (null? tal)
5500: 29 0a 09 09 20 20 20 20 20 20 28 6c 6f 6f 70 20 )... (loop
5510: 28 63 61 72 20 74 61 6c 29 28 63 64 72 20 74 61 (car tal)(cdr ta
5520: 6c 29 20 72 65 72 75 6e 73 29 29 29 0a 09 09 20 l) reruns)))...
5530: 28 65 6c 73 65 20 3b 3b 20 6d 75 73 74 20 62 65 (else ;; must be
5540: 20 77 65 20 68 61 76 65 20 75 6e 6d 65 74 20 70 we have unmet p
5550: 72 65 72 65 71 75 69 73 69 74 65 73 0a 09 09 20 rerequisites...
5560: 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 (debug:print
5570: 34 20 22 46 41 49 4c 53 3a 20 22 20 66 61 69 6c 4 "FAILS: " fail
5580: 73 29 0a 09 09 20 20 20 20 3b 3b 20 49 66 20 6f s)... ;; If o
5590: 6e 65 20 6f 72 20 6d 6f 72 65 20 6f 66 20 74 68 ne or more of th
55a0: 65 20 70 72 65 72 65 71 73 2d 6e 6f 74 2d 6d 65 e prereqs-not-me
55b0: 74 20 61 72 65 20 46 41 49 4c 20 74 68 65 6e 20 t are FAIL then
55c0: 77 65 20 63 61 6e 20 69 73 73 75 65 0a 09 09 20 we can issue...
55d0: 20 20 20 3b 3b 20 61 20 6d 65 73 73 61 67 65 20 ;; a message
55e0: 61 6e 64 20 64 72 6f 70 20 68 65 64 20 66 72 6f and drop hed fro
55f0: 6d 20 74 68 65 20 69 74 65 6d 73 20 74 6f 20 62 m the items to b
5600: 65 20 70 72 6f 63 65 73 73 65 64 2e 0a 09 09 20 e processed....
5610: 20 20 20 28 69 66 20 28 6e 75 6c 6c 3f 20 66 61 (if (null? fa
5620: 69 6c 73 29 0a 09 09 09 28 62 65 67 69 6e 0a 09 ils)....(begin..
5630: 09 09 20 20 3b 3b 20 63 6f 75 6c 64 6e 27 74 20 .. ;; couldn't
5640: 72 75 6e 2c 20 74 61 6b 65 20 61 20 62 72 65 61 run, take a brea
5650: 74 68 65 72 0a 09 09 09 20 20 28 64 65 62 75 67 ther.... (debug
5660: 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 34 20 22 53 :print-info 4 "S
5670: 68 6f 75 6c 64 6e 27 74 20 72 65 61 6c 6c 79 20 houldn't really
5680: 67 65 74 20 68 65 72 65 2c 20 72 61 63 65 20 63 get here, race c
5690: 6f 6e 64 69 74 69 6f 6e 3f 20 55 6e 61 62 6c 65 ondition? Unable
56a0: 20 74 6f 20 6c 61 75 6e 63 68 20 6d 6f 72 65 20 to launch more
56b0: 74 65 73 74 73 20 61 74 20 74 68 69 73 20 6d 6f tests at this mo
56c0: 6d 65 6e 74 2c 20 6b 69 6c 6c 69 6e 67 20 74 69 ment, killing ti
56d0: 6d 65 20 2e 2e 2e 22 29 0a 09 09 09 20 20 3b 3b me ...").... ;;
56e0: 20 28 74 68 72 65 61 64 2d 73 6c 65 65 70 21 20 (thread-sleep!
56f0: 28 2b 20 30 2e 30 31 20 2a 67 6c 6f 62 61 6c 2d (+ 0.01 *global-
5700: 64 65 6c 74 61 2a 29 29 20 3b 3b 20 6c 6f 6e 67 delta*)) ;; long
5710: 20 73 6c 65 65 70 20 68 65 72 65 20 2d 20 6e 6f sleep here - no
5720: 20 72 65 73 6f 75 72 63 65 73 2c 20 6d 61 79 20 resources, may
5730: 61 73 20 77 65 6c 6c 20 62 65 20 70 61 74 69 65 as well be patie
5740: 6e 74 0a 09 09 09 20 20 3b 3b 20 77 65 20 6d 61 nt.... ;; we ma
5750: 64 65 20 6e 65 77 20 74 61 6c 20 62 79 20 73 74 de new tal by st
5760: 69 63 6b 69 6e 67 20 68 65 64 20 61 74 20 74 68 icking hed at th
5770: 65 20 62 61 63 6b 20 6f 66 20 74 68 65 20 6c 69 e back of the li
5780: 73 74 0a 09 09 09 20 20 28 6c 6f 6f 70 20 28 63 st.... (loop (c
5790: 61 72 20 6e 65 77 74 61 6c 29 28 63 64 72 20 6e ar newtal)(cdr n
57a0: 65 77 74 61 6c 29 20 72 65 72 75 6e 73 29 29 0a ewtal) reruns)).
57b0: 09 09 09 3b 3b 20 74 68 65 20 77 61 69 74 6f 6e ...;; the waiton
57c0: 20 69 73 20 46 41 49 4c 20 73 6f 20 6e 6f 20 70 is FAIL so no p
57d0: 6f 69 6e 74 20 69 6e 20 74 72 79 69 6e 67 20 74 oint in trying t
57e0: 6f 20 72 75 6e 20 68 65 64 20 65 76 65 72 20 61 o run hed ever a
57f0: 67 61 69 6e 0a 09 09 09 28 69 66 20 28 6e 6f 74 gain....(if (not
5800: 20 28 6e 75 6c 6c 3f 20 74 61 6c 29 29 0a 09 09 (null? tal))...
5810: 09 20 20 20 20 28 69 66 20 28 76 65 63 74 6f 72 . (if (vector
5820: 3f 20 68 65 64 29 0a 09 09 09 09 28 62 65 67 69 ? hed).....(begi
5830: 6e 20 0a 09 09 09 09 20 20 28 64 65 62 75 67 3a n ..... (debug:
5840: 70 72 69 6e 74 20 31 20 22 57 41 52 4e 3a 20 44 print 1 "WARN: D
5850: 72 6f 70 70 69 6e 67 20 74 65 73 74 20 22 20 28 ropping test " (
5860: 64 62 3a 74 65 73 74 2d 67 65 74 2d 74 65 73 74 db:test-get-test
5870: 6e 61 6d 65 20 68 65 64 29 20 22 2f 22 20 28 64 name hed) "/" (d
5880: 62 3a 74 65 73 74 2d 67 65 74 2d 69 74 65 6d 2d b:test-get-item-
5890: 70 61 74 68 20 68 65 64 29 0a 09 09 09 09 09 20 path hed)......
58a0: 20 20 20 20 20 20 22 20 66 72 6f 6d 20 74 68 65 " from the
58b0: 20 6c 61 75 6e 63 68 20 6c 69 73 74 20 61 73 20 launch list as
58c0: 69 74 20 68 61 73 20 70 72 65 72 65 71 75 69 73 it has prerequis
58d0: 74 65 73 20 74 68 61 74 20 61 72 65 20 46 41 49 tes that are FAI
58e0: 4c 22 29 0a 09 09 09 09 20 20 28 72 75 6e 73 3a L")..... (runs:
58f0: 73 68 72 69 6e 6b 2d 63 61 6e 2d 72 75 6e 2d 6d shrink-can-run-m
5900: 6f 72 65 2d 74 65 73 74 73 2d 64 65 6c 61 79 29 ore-tests-delay)
5910: 20 3b 3b 20 44 45 4c 41 59 20 54 57 45 41 4b 45 ;; DELAY TWEAKE
5920: 52 20 28 73 74 69 6c 6c 20 6e 65 65 64 65 64 3f R (still needed?
5930: 29 0a 09 09 09 09 20 20 3b 3b 20 28 74 68 72 65 )..... ;; (thre
5940: 61 64 2d 73 6c 65 65 70 21 20 2a 67 6c 6f 62 61 ad-sleep! *globa
5950: 6c 2d 64 65 6c 74 61 2a 29 0a 09 09 09 09 20 20 l-delta*).....
5960: 28 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 (hash-table-set!
5970: 20 74 65 73 74 2d 72 65 67 69 73 74 65 72 79 20 test-registery
5980: 28 72 75 6e 73 3a 6d 61 6b 65 2d 66 75 6c 6c 2d (runs:make-full-
5990: 74 65 73 74 2d 6e 61 6d 65 20 74 65 73 74 2d 6e test-name test-n
59a0: 61 6d 65 20 69 74 65 6d 2d 70 61 74 68 29 20 27 ame item-path) '
59b0: 72 65 6d 6f 76 65 64 29 0a 09 09 09 09 20 20 28 removed)..... (
59c0: 6c 6f 6f 70 20 28 63 61 72 20 74 61 6c 29 28 63 loop (car tal)(c
59d0: 64 72 20 74 61 6c 29 20 28 63 6f 6e 73 20 68 65 dr tal) (cons he
59e0: 64 20 72 65 72 75 6e 73 29 29 29 0a 09 09 09 09 d reruns))).....
59f0: 28 62 65 67 69 6e 0a 09 09 09 09 20 20 28 64 65 (begin..... (de
5a00: 62 75 67 3a 70 72 69 6e 74 20 31 20 22 57 41 52 bug:print 1 "WAR
5a10: 4e 3a 20 54 65 73 74 20 6e 6f 74 20 70 72 6f 63 N: Test not proc
5a20: 65 73 73 65 64 20 63 6f 72 72 65 63 74 6c 79 2e essed correctly.
5a30: 20 43 6f 75 6c 64 20 62 65 20 61 20 72 61 63 65 Could be a race
5a40: 20 63 6f 6e 64 69 74 69 6f 6e 20 69 6e 20 79 6f condition in yo
5a50: 75 72 20 74 65 73 74 20 69 6d 70 6c 65 6d 65 6e ur test implemen
5a60: 74 61 74 69 6f 6e 3f 20 22 20 68 65 64 29 20 3b tation? " hed) ;
5a70: 3b 20 20 22 20 61 73 20 69 74 20 68 61 73 20 70 ; " as it has p
5a80: 72 65 72 65 71 75 69 73 74 65 73 20 74 68 61 74 rerequistes that
5a90: 20 61 72 65 20 46 41 49 4c 2e 20 28 4e 4f 54 45 are FAIL. (NOTE
5aa0: 3a 20 68 65 64 20 69 73 20 6e 6f 74 20 61 20 76 : hed is not a v
5ab0: 65 63 74 6f 72 29 22 29 0a 09 09 09 09 20 20 28 ector)")..... (
5ac0: 72 75 6e 73 3a 73 68 72 69 6e 6b 2d 63 61 6e 2d runs:shrink-can-
5ad0: 72 75 6e 2d 6d 6f 72 65 2d 74 65 73 74 73 2d 64 run-more-tests-d
5ae0: 65 6c 61 79 29 20 3b 3b 20 44 45 4c 41 59 20 54 elay) ;; DELAY T
5af0: 57 45 41 4b 45 52 20 28 73 74 69 6c 6c 20 6e 65 WEAKER (still ne
5b00: 65 64 65 64 3f 29 0a 09 09 09 09 20 20 3b 3b 20 eded?)..... ;;
5b10: 28 74 68 72 65 61 64 2d 73 6c 65 65 70 21 20 28 (thread-sleep! (
5b20: 2b 20 30 2e 30 31 20 2a 67 6c 6f 62 61 6c 2d 64 + 0.01 *global-d
5b30: 65 6c 74 61 2a 29 29 0a 09 09 09 09 20 20 28 6c elta*))..... (l
5b40: 6f 6f 70 20 68 65 64 20 74 61 6c 20 72 65 72 75 oop hed tal reru
5b50: 6e 73 29 29 29 29 29 29 29 29 29 20 3b 3b 20 45 ns))))))))) ;; E
5b60: 4e 44 20 4f 46 20 49 4e 4e 45 52 20 43 4f 4e 44 ND OF INNER COND
5b70: 0a 09 20 20 20 20 20 0a 09 20 20 20 20 20 3b 3b .. .. ;;
5b80: 20 63 61 73 65 20 77 68 65 72 65 20 61 6e 20 69 case where an i
5b90: 74 65 6d 73 20 63 61 6d 65 20 69 6e 20 61 73 20 tems came in as
5ba0: 61 20 6c 69 73 74 20 62 65 65 6e 20 70 72 6f 63 a list been proc
5bb0: 65 73 73 65 64 0a 09 20 20 20 20 20 28 28 61 6e essed.. ((an
5bc0: 64 20 28 6c 69 73 74 3f 20 69 74 65 6d 73 29 20 d (list? items)
5bd0: 20 20 20 20 3b 3b 20 74 68 75 73 20 77 65 20 6b ;; thus we k
5be0: 6e 6f 77 20 6f 75 72 20 69 74 65 6d 73 20 61 72 now our items ar
5bf0: 65 20 61 6c 72 65 61 64 79 20 63 61 6c 63 75 6c e already calcul
5c00: 61 74 65 64 0a 09 09 20 20 20 28 6e 6f 74 20 20 ated... (not
5c10: 20 69 74 65 6d 64 61 74 29 29 20 3b 3b 20 61 6e itemdat)) ;; an
5c20: 64 20 6e 6f 74 20 79 65 74 20 65 78 70 61 6e 64 d not yet expand
5c30: 65 64 20 69 6e 74 6f 20 74 68 65 20 6c 69 73 74 ed into the list
5c40: 20 6f 66 20 74 68 69 6e 67 73 20 74 6f 20 62 65 of things to be
5c50: 20 64 6f 6e 65 0a 09 20 20 20 20 20 20 28 69 66 done.. (if
5c60: 20 28 61 6e 64 20 28 64 65 62 75 67 3a 64 65 62 (and (debug:deb
5c70: 75 67 2d 6d 6f 64 65 20 31 29 20 3b 3b 20 28 3e ug-mode 1) ;; (>
5c80: 3d 20 2a 76 65 72 62 6f 73 69 74 79 2a 20 31 29 = *verbosity* 1)
5c90: 0a 09 09 20 20 20 20 20 20 20 28 3e 20 28 6c 65 ... (> (le
5ca0: 6e 67 74 68 20 69 74 65 6d 73 29 20 30 29 0a 09 ngth items) 0)..
5cb0: 09 20 20 20 20 20 20 20 28 3e 20 28 6c 65 6e 67 . (> (leng
5cc0: 74 68 20 28 63 61 72 20 69 74 65 6d 73 29 29 20 th (car items))
5cd0: 30 29 29 0a 09 09 20 20 28 70 70 20 69 74 65 6d 0))... (pp item
5ce0: 73 29 29 0a 09 20 20 20 20 20 20 28 66 6f 72 2d s)).. (for-
5cf0: 65 61 63 68 0a 09 20 20 20 20 20 20 20 28 6c 61 each.. (la
5d00: 6d 62 64 61 20 28 6d 79 2d 69 74 65 6d 64 61 74 mbda (my-itemdat
5d10: 29 0a 09 09 20 28 6c 65 74 2a 20 28 28 6e 65 77 )... (let* ((new
5d20: 2d 74 65 73 74 2d 72 65 63 6f 72 64 20 28 6c 65 -test-record (le
5d30: 74 20 28 28 6e 65 77 72 65 63 20 28 6d 61 6b 65 t ((newrec (make
5d40: 2d 74 65 73 74 73 3a 74 65 73 74 71 75 65 75 65 -tests:testqueue
5d50: 29 29 29 0a 09 09 09 09 09 20 20 20 28 76 65 63 )))...... (vec
5d60: 74 6f 72 2d 63 6f 70 79 21 20 74 65 73 74 2d 72 tor-copy! test-r
5d70: 65 63 6f 72 64 20 6e 65 77 72 65 63 29 0a 09 09 ecord newrec)...
5d80: 09 09 09 20 20 20 6e 65 77 72 65 63 29 29 0a 09 ... newrec))..
5d90: 09 09 28 6d 79 2d 69 74 65 6d 2d 70 61 74 68 20 ..(my-item-path
5da0: 28 69 74 65 6d 2d 6c 69 73 74 2d 3e 70 61 74 68 (item-list->path
5db0: 20 6d 79 2d 69 74 65 6d 64 61 74 29 29 29 0a 09 my-itemdat)))..
5dc0: 09 20 20 20 28 69 66 20 28 74 65 73 74 73 3a 6d . (if (tests:m
5dd0: 61 74 63 68 20 74 65 73 74 2d 70 61 74 74 73 20 atch test-patts
5de0: 68 65 64 20 6d 79 2d 69 74 65 6d 2d 70 61 74 68 hed my-item-path
5df0: 29 20 3b 3b 20 28 70 61 74 74 2d 6c 69 73 74 2d ) ;; (patt-list-
5e00: 6d 61 74 63 68 20 6d 79 2d 69 74 65 6d 2d 70 61 match my-item-pa
5e10: 74 68 20 69 74 65 6d 2d 70 61 74 74 73 29 20 20 th item-patts)
5e20: 20 20 20 20 20 20 20 20 20 3b 3b 20 79 65 73 2c ;; yes,
5e30: 20 77 65 20 77 61 6e 74 20 74 6f 20 70 72 6f 63 we want to proc
5e40: 65 73 73 20 74 68 69 73 20 69 74 65 6d 2c 20 4e ess this item, N
5e50: 4f 54 45 3a 20 53 68 6f 75 6c 64 20 6e 6f 74 20 OTE: Should not
5e60: 6e 65 65 64 20 74 68 69 73 20 63 68 65 63 6b 20 need this check
5e70: 68 65 72 65 21 0a 09 09 20 20 20 20 20 20 20 28 here!... (
5e80: 6c 65 74 20 28 28 6e 65 77 74 65 73 74 6e 61 6d let ((newtestnam
5e90: 65 20 28 72 75 6e 73 3a 6d 61 6b 65 2d 66 75 6c e (runs:make-ful
5ea0: 6c 2d 74 65 73 74 2d 6e 61 6d 65 20 68 65 64 20 l-test-name hed
5eb0: 6d 79 2d 69 74 65 6d 2d 70 61 74 68 29 29 29 20 my-item-path)))
5ec0: 20 20 20 3b 3b 20 74 65 73 74 20 6e 61 6d 65 73 ;; test names
5ed0: 20 61 72 65 20 75 6e 69 71 75 65 20 6f 6e 20 74 are unique on t
5ee0: 65 73 74 6e 61 6d 65 2f 69 74 65 6d 2d 70 61 74 estname/item-pat
5ef0: 68 0a 09 09 09 20 28 74 65 73 74 73 3a 74 65 73 h.... (tests:tes
5f00: 74 71 75 65 75 65 2d 73 65 74 2d 69 74 65 6d 73 tqueue-set-items
5f10: 21 20 20 20 20 20 6e 65 77 2d 74 65 73 74 2d 72 ! new-test-r
5f20: 65 63 6f 72 64 20 23 66 29 0a 09 09 09 20 28 74 ecord #f).... (t
5f30: 65 73 74 73 3a 74 65 73 74 71 75 65 75 65 2d 73 ests:testqueue-s
5f40: 65 74 2d 69 74 65 6d 64 61 74 21 20 20 20 6e 65 et-itemdat! ne
5f50: 77 2d 74 65 73 74 2d 72 65 63 6f 72 64 20 6d 79 w-test-record my
5f60: 2d 69 74 65 6d 64 61 74 29 0a 09 09 09 20 28 74 -itemdat).... (t
5f70: 65 73 74 73 3a 74 65 73 74 71 75 65 75 65 2d 73 ests:testqueue-s
5f80: 65 74 2d 69 74 65 6d 5f 70 61 74 68 21 20 6e 65 et-item_path! ne
5f90: 77 2d 74 65 73 74 2d 72 65 63 6f 72 64 20 6d 79 w-test-record my
5fa0: 2d 69 74 65 6d 2d 70 61 74 68 29 0a 09 09 09 20 -item-path)....
5fb0: 28 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 (hash-table-set!
5fc0: 20 74 65 73 74 2d 72 65 63 6f 72 64 73 20 6e 65 test-records ne
5fd0: 77 74 65 73 74 6e 61 6d 65 20 6e 65 77 2d 74 65 wtestname new-te
5fe0: 73 74 2d 72 65 63 6f 72 64 29 0a 09 09 09 20 28 st-record).... (
5ff0: 73 65 74 21 20 74 61 6c 20 28 63 6f 6e 73 20 6e set! tal (cons n
6000: 65 77 74 65 73 74 6e 61 6d 65 20 74 61 6c 29 29 ewtestname tal))
6010: 29 29 29 29 20 3b 3b 20 73 69 6e 63 65 20 74 68 )))) ;; since th
6020: 65 73 65 20 61 72 65 20 69 74 65 6d 69 7a 65 64 ese are itemized
6030: 20 63 72 65 61 74 65 20 6e 65 77 20 74 65 73 74 create new test
6040: 20 6e 61 6d 65 73 20 74 65 73 74 6e 61 6d 65 2f names testname/
6050: 69 74 65 6d 70 61 74 68 0a 09 20 20 20 20 20 20 itempath..
6060: 20 69 74 65 6d 73 29 0a 09 20 20 20 20 20 20 28 items).. (
6070: 69 66 20 28 6e 6f 74 20 28 6e 75 6c 6c 3f 20 74 if (not (null? t
6080: 61 6c 29 29 0a 09 09 20 20 28 62 65 67 69 6e 0a al))... (begin.
6090: 09 09 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 .. (debug:pri
60a0: 6e 74 2d 69 6e 66 6f 20 34 20 22 45 6e 64 20 6f nt-info 4 "End o
60b0: 66 20 69 74 65 6d 73 20 6c 69 73 74 2c 20 6c 6f f items list, lo
60c0: 6f 70 69 6e 67 20 77 69 74 68 20 6e 65 78 74 20 oping with next
60d0: 61 66 74 65 72 20 73 68 6f 72 74 20 64 65 6c 61 after short dela
60e0: 79 22 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 y").
60f0: 20 20 20 20 20 20 20 20 3b 3b 20 28 74 68 72 65 ;; (thre
6100: 61 64 2d 73 6c 65 65 70 21 20 28 2b 20 30 2e 30 ad-sleep! (+ 0.0
6110: 31 20 2a 67 6c 6f 62 61 6c 2d 64 65 6c 74 61 2a 1 *global-delta*
6120: 29 29 0a 09 09 20 20 20 20 28 6c 6f 6f 70 20 28 ))... (loop (
6130: 63 61 72 20 74 61 6c 29 28 63 64 72 20 74 61 6c car tal)(cdr tal
6140: 29 20 72 65 72 75 6e 73 29 29 29 29 0a 0a 09 20 ) reruns))))...
6150: 20 20 20 20 3b 3b 20 69 66 20 69 74 65 6d 73 20 ;; if items
6160: 69 73 20 61 20 70 72 6f 63 20 74 68 65 6e 20 6e is a proc then n
6170: 65 65 64 20 74 6f 20 72 75 6e 20 69 74 65 6d 73 eed to run items
6180: 3a 67 65 74 2d 69 74 65 6d 73 2d 66 72 6f 6d 2d :get-items-from-
6190: 63 6f 6e 66 69 67 2c 20 67 65 74 20 74 68 65 20 config, get the
61a0: 6c 69 73 74 20 61 6e 64 20 6c 6f 6f 70 20 0a 09 list and loop ..
61b0: 20 20 20 20 20 3b 3b 20 20 20 20 2d 20 62 75 74 ;; - but
61c0: 20 6f 6e 6c 79 20 64 6f 20 74 68 61 74 20 69 66 only do that if
61d0: 20 72 65 73 6f 75 72 63 65 73 20 65 78 69 73 74 resources exist
61e0: 20 74 6f 20 6b 69 63 6b 20 6f 66 66 20 74 68 65 to kick off the
61f0: 20 6a 6f 62 0a 09 20 20 20 20 20 28 28 6f 72 20 job.. ((or
6200: 28 70 72 6f 63 65 64 75 72 65 3f 20 69 74 65 6d (procedure? item
6210: 73 29 28 65 71 3f 20 69 74 65 6d 73 20 27 68 61 s)(eq? items 'ha
6220: 76 65 2d 70 72 6f 63 65 64 75 72 65 29 29 0a 09 ve-procedure))..
6230: 20 20 20 20 20 20 28 6c 65 74 20 28 28 63 61 6e (let ((can
6240: 2d 72 75 6e 2d 6d 6f 72 65 20 20 20 20 28 72 75 -run-more (ru
6250: 6e 73 3a 63 61 6e 2d 72 75 6e 2d 6d 6f 72 65 2d ns:can-run-more-
6260: 74 65 73 74 73 20 74 65 73 74 2d 72 65 63 6f 72 tests test-recor
6270: 64 29 29 29 0a 09 09 28 69 66 20 28 61 6e 64 20 d)))...(if (and
6280: 28 6c 69 73 74 3f 20 63 61 6e 2d 72 75 6e 2d 6d (list? can-run-m
6290: 6f 72 65 29 0a 09 09 09 20 28 63 61 72 20 63 61 ore).... (car ca
62a0: 6e 2d 72 75 6e 2d 6d 6f 72 65 29 29 0a 09 09 20 n-run-more))...
62b0: 20 20 20 28 6c 65 74 2a 20 28 28 70 72 65 72 65 (let* ((prere
62c0: 71 73 2d 6e 6f 74 2d 6d 65 74 20 28 6f 70 65 6e qs-not-met (open
62d0: 2d 72 75 6e 2d 63 6c 6f 73 65 20 64 62 3a 67 65 -run-close db:ge
62e0: 74 2d 70 72 65 72 65 71 73 2d 6e 6f 74 2d 6d 65 t-prereqs-not-me
62f0: 74 20 23 66 20 72 75 6e 2d 69 64 20 77 61 69 74 t #f run-id wait
6300: 6f 6e 73 20 69 74 65 6d 2d 70 61 74 68 20 6d 6f ons item-path mo
6310: 64 65 3a 20 74 65 73 74 6d 6f 64 65 29 29 0a 09 de: testmode))..
6320: 09 09 20 20 20 28 66 61 69 6c 73 20 20 20 20 20 .. (fails
6330: 20 20 20 20 20 20 28 72 75 6e 73 3a 63 61 6c 63 (runs:calc
6340: 2d 66 61 69 6c 73 20 70 72 65 72 65 71 73 2d 6e -fails prereqs-n
6350: 6f 74 2d 6d 65 74 29 29 0a 09 09 09 20 20 20 28 ot-met)).... (
6360: 6e 6f 6e 2d 63 6f 6d 70 6c 65 74 65 64 20 20 20 non-completed
6370: 28 72 75 6e 73 3a 63 61 6c 63 2d 6e 6f 74 2d 63 (runs:calc-not-c
6380: 6f 6d 70 6c 65 74 65 64 20 70 72 65 72 65 71 73 ompleted prereqs
6390: 2d 6e 6f 74 2d 6d 65 74 29 29 29 0a 09 09 20 20 -not-met)))...
63a0: 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 (debug:print
63b0: 2d 69 6e 66 6f 20 38 20 22 63 61 6e 2d 72 75 6e -info 8 "can-run
63c0: 2d 6d 6f 72 65 3a 20 22 20 63 61 6e 2d 72 75 6e -more: " can-run
63d0: 2d 6d 6f 72 65 0a 09 09 09 09 20 20 20 22 5c 6e -more..... "\n
63e0: 20 74 65 73 74 6e 61 6d 65 3a 20 20 20 20 20 20 testname:
63f0: 20 20 22 20 68 65 64 0a 09 09 09 09 20 20 20 22 " hed..... "
6400: 5c 6e 20 70 72 65 72 65 71 73 2d 6e 6f 74 2d 6d \n prereqs-not-m
6410: 65 74 3a 20 22 20 28 72 75 6e 73 3a 70 72 65 74 et: " (runs:pret
6420: 74 79 2d 73 74 72 69 6e 67 20 70 72 65 72 65 71 ty-string prereq
6430: 73 2d 6e 6f 74 2d 6d 65 74 29 0a 09 09 09 09 20 s-not-met).....
6440: 20 20 22 5c 6e 20 6e 6f 6e 2d 63 6f 6d 70 6c 65 "\n non-comple
6450: 74 65 64 3a 20 20 20 22 20 28 72 75 6e 73 3a 70 ted: " (runs:p
6460: 72 65 74 74 79 2d 73 74 72 69 6e 67 20 6e 6f 6e retty-string non
6470: 2d 63 6f 6d 70 6c 65 74 65 64 29 20 0a 09 09 09 -completed) ....
6480: 09 20 20 20 22 5c 6e 20 66 61 69 6c 73 3a 20 20 . "\n fails:
6490: 20 20 20 20 20 20 20 20 20 22 20 28 72 75 6e 73 " (runs
64a0: 3a 70 72 65 74 74 79 2d 73 74 72 69 6e 67 20 66 :pretty-string f
64b0: 61 69 6c 73 29 0a 09 09 09 09 20 20 20 22 5c 6e ails)..... "\n
64c0: 20 74 65 73 74 6d 6f 64 65 3a 20 20 20 20 20 20 testmode:
64d0: 20 20 22 20 74 65 73 74 6d 6f 64 65 0a 09 09 09 " testmode....
64e0: 09 20 20 20 22 5c 6e 20 6e 75 6d 2d 72 65 74 72 . "\n num-retr
64f0: 69 65 73 3a 20 20 20 20 20 22 20 6e 75 6d 2d 72 ies: " num-r
6500: 65 74 72 69 65 73 0a 09 09 09 09 20 20 20 22 5c etries..... "\
6510: 6e 20 28 65 71 3f 20 74 65 73 74 6d 6f 64 65 20 n (eq? testmode
6520: 27 74 6f 70 6c 65 76 65 6c 29 3a 20 22 20 28 65 'toplevel): " (e
6530: 71 3f 20 74 65 73 74 6d 6f 64 65 20 27 74 6f 70 q? testmode 'top
6540: 6c 65 76 65 6c 29 0a 09 09 09 09 20 20 20 22 5c level)..... "\
6550: 6e 20 28 6e 75 6c 6c 3f 20 6e 6f 6e 2d 63 6f 6d n (null? non-com
6560: 70 6c 65 74 65 64 29 3a 20 20 20 20 22 20 28 6e pleted): " (n
6570: 75 6c 6c 3f 20 6e 6f 6e 2d 63 6f 6d 70 6c 65 74 ull? non-complet
6580: 65 64 29 0a 09 09 09 09 20 20 20 22 5c 6e 20 72 ed)..... "\n r
6590: 65 72 75 6e 73 3a 20 20 20 20 20 20 20 20 20 20 eruns:
65a0: 22 20 72 65 72 75 6e 73 0a 09 09 09 09 20 20 20 " reruns.....
65b0: 22 5c 6e 20 69 74 65 6d 73 3a 20 20 20 20 20 20 "\n items:
65c0: 20 20 20 20 20 22 20 69 74 65 6d 73 0a 09 09 09 " items....
65d0: 09 20 20 20 22 5c 6e 20 63 61 6e 2d 72 75 6e 2d . "\n can-run-
65e0: 6d 6f 72 65 3a 20 20 20 20 22 20 63 61 6e 2d 72 more: " can-r
65f0: 75 6e 2d 6d 6f 72 65 29 0a 09 09 20 20 20 20 20 un-more)...
6600: 20 3b 3b 20 28 74 68 72 65 61 64 2d 73 6c 65 65 ;; (thread-slee
6610: 70 21 20 28 2b 20 30 2e 30 31 20 2a 67 6c 6f 62 p! (+ 0.01 *glob
6620: 61 6c 2d 64 65 6c 74 61 2a 29 29 0a 09 09 20 20 al-delta*))...
6630: 20 20 20 20 28 63 6f 6e 64 20 3b 3b 20 49 4e 4e (cond ;; INN
6640: 45 52 20 43 4f 4e 44 20 23 32 0a 09 09 20 20 20 ER COND #2...
6650: 20 20 20 20 28 28 6f 72 20 28 6e 75 6c 6c 3f 20 ((or (null?
6660: 70 72 65 72 65 71 73 2d 6e 6f 74 2d 6d 65 74 29 prereqs-not-met)
6670: 20 3b 3b 20 61 6c 6c 20 70 72 65 72 65 71 73 20 ;; all prereqs
6680: 6d 65 74 2c 20 66 69 72 65 20 6f 66 66 20 74 68 met, fire off th
6690: 65 20 74 65 73 74 0a 09 09 09 20 20 20 20 3b 3b e test.... ;;
66a0: 20 6f 72 2c 20 69 66 20 69 74 20 69 73 20 61 20 or, if it is a
66b0: 27 74 6f 70 6c 65 76 65 6c 20 74 65 73 74 20 61 'toplevel test a
66c0: 6e 64 20 61 6c 6c 20 70 72 65 72 65 71 73 20 6e nd all prereqs n
66d0: 6f 74 20 6d 65 74 20 61 72 65 20 43 4f 4d 50 4c ot met are COMPL
66e0: 45 54 45 44 20 74 68 65 6e 20 6c 61 75 6e 63 68 ETED then launch
66f0: 0a 09 09 09 20 20 20 20 28 61 6e 64 20 28 65 71 .... (and (eq
6700: 3f 20 74 65 73 74 6d 6f 64 65 20 27 74 6f 70 6c ? testmode 'topl
6710: 65 76 65 6c 29 0a 09 09 09 09 20 28 6e 75 6c 6c evel)..... (null
6720: 3f 20 6e 6f 6e 2d 63 6f 6d 70 6c 65 74 65 64 29 ? non-completed)
6730: 29 29 0a 09 09 09 28 6c 65 74 20 28 28 74 65 73 ))....(let ((tes
6740: 74 2d 6e 61 6d 65 20 28 74 65 73 74 73 3a 74 65 t-name (tests:te
6750: 73 74 71 75 65 75 65 2d 67 65 74 2d 74 65 73 74 stqueue-get-test
6760: 6e 61 6d 65 20 74 65 73 74 2d 72 65 63 6f 72 64 name test-record
6770: 29 29 29 0a 09 09 09 20 20 28 73 65 74 65 6e 76 ))).... (setenv
6780: 20 22 4d 54 5f 54 45 53 54 5f 4e 41 4d 45 22 20 "MT_TEST_NAME"
6790: 74 65 73 74 2d 6e 61 6d 65 29 20 3b 3b 20 0a 09 test-name) ;; ..
67a0: 09 09 20 20 28 73 65 74 65 6e 76 20 22 4d 54 5f .. (setenv "MT_
67b0: 52 55 4e 4e 41 4d 45 22 20 20 20 72 75 6e 6e 61 RUNNAME" runna
67c0: 6d 65 29 0a 09 09 09 20 20 28 73 65 74 2d 6d 65 me).... (set-me
67d0: 67 61 74 65 73 74 2d 65 6e 76 2d 76 61 72 73 20 gatest-env-vars
67e0: 72 75 6e 2d 69 64 29 20 3b 3b 20 74 68 65 73 65 run-id) ;; these
67f0: 20 6d 61 79 20 62 65 20 6e 65 65 64 65 64 20 62 may be needed b
6800: 79 20 74 68 65 20 6c 61 75 6e 63 68 69 6e 67 20 y the launching
6810: 70 72 6f 63 65 73 73 0a 09 09 09 20 20 28 6c 65 process.... (le
6820: 74 20 28 28 69 74 65 6d 73 2d 6c 69 73 74 20 28 t ((items-list (
6830: 69 74 65 6d 73 3a 67 65 74 2d 69 74 65 6d 73 2d items:get-items-
6840: 66 72 6f 6d 2d 63 6f 6e 66 69 67 20 74 63 6f 6e from-config tcon
6850: 66 69 67 29 29 29 0a 09 09 09 20 20 20 20 28 69 fig))).... (i
6860: 66 20 28 6c 69 73 74 3f 20 69 74 65 6d 73 2d 6c f (list? items-l
6870: 69 73 74 29 0a 09 09 09 09 28 62 65 67 69 6e 0a ist).....(begin.
6880: 09 09 09 09 20 20 28 74 65 73 74 73 3a 74 65 73 .... (tests:tes
6890: 74 71 75 65 75 65 2d 73 65 74 2d 69 74 65 6d 73 tqueue-set-items
68a0: 21 20 74 65 73 74 2d 72 65 63 6f 72 64 20 69 74 ! test-record it
68b0: 65 6d 73 2d 6c 69 73 74 29 0a 09 09 09 09 20 20 ems-list).....
68c0: 3b 3b 20 28 74 68 72 65 61 64 2d 73 6c 65 65 70 ;; (thread-sleep
68d0: 21 20 2a 67 6c 6f 62 61 6c 2d 64 65 6c 74 61 2a ! *global-delta*
68e0: 29 0a 09 09 09 09 20 20 28 6c 6f 6f 70 20 68 65 )..... (loop he
68f0: 64 20 74 61 6c 20 72 65 72 75 6e 73 29 29 0a 09 d tal reruns))..
6900: 09 09 09 28 62 65 67 69 6e 0a 09 09 09 09 20 20 ...(begin.....
6910: 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 22 (debug:print 0 "
6920: 45 52 52 4f 52 3a 20 54 68 65 20 70 72 6f 63 20 ERROR: The proc
6930: 66 72 6f 6d 20 72 65 61 64 69 6e 67 20 74 68 65 from reading the
6940: 20 73 65 74 75 70 20 64 69 64 20 6e 6f 74 20 79 setup did not y
6950: 69 65 6c 64 20 61 20 6c 69 73 74 20 2d 20 70 6c ield a list - pl
6960: 65 61 73 65 20 72 65 70 6f 72 74 20 74 68 69 73 ease report this
6970: 22 29 0a 09 09 09 09 20 20 28 65 78 69 74 20 31 ")..... (exit 1
6980: 29 29 29 29 29 29 0a 09 09 20 20 20 20 20 20 20 ))))))...
6990: 28 28 6e 75 6c 6c 3f 20 66 61 69 6c 73 29 0a 09 ((null? fails)..
69a0: 09 09 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 ..(debug:print-i
69b0: 6e 66 6f 20 34 20 22 66 61 69 6c 73 20 69 73 20 nfo 4 "fails is
69c0: 6e 75 6c 6c 2c 20 6d 6f 76 69 6e 67 20 6f 6e 20 null, moving on
69d0: 69 6e 20 74 68 65 20 71 75 65 75 65 20 62 75 74 in the queue but
69e0: 20 6b 65 65 70 69 6e 67 20 22 20 68 65 64 20 22 keeping " hed "
69f0: 20 66 6f 72 20 6e 6f 77 22 29 0a 09 09 09 3b 3b for now")....;;
6a00: 20 6f 6e 6c 79 20 69 6e 63 72 65 6d 65 6e 74 20 only increment
6a10: 6e 75 6d 2d 72 65 74 72 69 65 73 20 77 68 65 6e num-retries when
6a20: 20 74 68 65 72 65 20 61 72 65 20 6e 6f 20 74 65 there are no te
6a30: 73 74 73 20 72 75 6e 69 6e 67 0a 09 09 09 28 69 sts runing....(i
6a40: 66 20 28 65 71 3f 20 30 20 28 6c 69 73 74 2d 72 f (eq? 0 (list-r
6a50: 65 66 20 63 61 6e 2d 72 75 6e 2d 6d 6f 72 65 20 ef can-run-more
6a60: 31 29 29 0a 09 09 09 20 20 20 20 28 62 65 67 69 1)).... (begi
6a70: 6e 0a 09 09 09 20 20 20 20 20 20 28 69 66 20 28 n.... (if (
6a80: 3e 20 6e 75 6d 2d 72 65 74 72 69 65 73 20 31 30 > num-retries 10
6a90: 30 29 20 3b 3b 20 66 69 72 73 74 20 31 30 30 20 0) ;; first 100
6aa0: 72 65 74 72 69 65 73 20 61 72 65 20 6c 6f 77 20 retries are low
6ab0: 74 69 6d 65 20 63 6f 73 74 0a 09 09 09 09 20 20 time cost.....
6ac0: 28 74 68 72 65 61 64 2d 73 6c 65 65 70 21 20 28 (thread-sleep! (
6ad0: 2b 20 32 20 2a 67 6c 6f 62 61 6c 2d 64 65 6c 74 + 2 *global-delt
6ae0: 61 2a 29 29 0a 09 09 09 09 20 20 28 74 68 72 65 a*))..... (thre
6af0: 61 64 2d 73 6c 65 65 70 21 20 28 2b 20 30 2e 30 ad-sleep! (+ 0.0
6b00: 31 20 2a 67 6c 6f 62 61 6c 2d 64 65 6c 74 61 2a 1 *global-delta*
6b10: 29 29 29 0a 09 09 09 20 20 20 20 20 20 28 73 65 ))).... (se
6b20: 74 21 20 6e 75 6d 2d 72 65 74 72 69 65 73 20 28 t! num-retries (
6b30: 2b 20 6e 75 6d 2d 72 65 74 72 69 65 73 20 31 29 + num-retries 1)
6b40: 29 29 29 0a 09 09 09 28 69 66 20 28 3e 20 6e 75 )))....(if (> nu
6b50: 6d 2d 72 65 74 72 69 65 73 20 20 6d 61 78 2d 72 m-retries max-r
6b60: 65 74 72 69 65 73 29 0a 09 09 09 20 20 20 20 28 etries).... (
6b70: 69 66 20 28 6e 6f 74 20 28 6e 75 6c 6c 3f 20 74 if (not (null? t
6b80: 61 6c 29 29 0a 09 09 09 09 28 6c 6f 6f 70 20 28 al)).....(loop (
6b90: 63 61 72 20 74 61 6c 29 28 63 64 72 20 74 61 6c car tal)(cdr tal
6ba0: 29 20 72 65 72 75 6e 73 29 29 0a 09 09 09 20 20 ) reruns))....
6bb0: 20 20 28 6c 6f 6f 70 20 28 63 61 72 20 6e 65 77 (loop (car new
6bc0: 74 61 6c 29 28 63 64 72 20 6e 65 77 74 61 6c 29 tal)(cdr newtal)
6bd0: 20 72 65 72 75 6e 73 29 29 29 20 3b 3b 20 61 6e reruns))) ;; an
6be0: 20 69 73 73 75 65 20 77 69 74 68 20 70 72 65 72 issue with prer
6bf0: 65 71 73 20 6e 6f 74 20 79 65 74 20 6d 65 74 3f eqs not yet met?
6c00: 0a 09 09 20 20 20 20 20 20 20 28 28 61 6e 64 20 ... ((and
6c10: 28 6e 6f 74 20 28 6e 75 6c 6c 3f 20 66 61 69 6c (not (null? fail
6c20: 73 29 29 28 65 71 3f 20 74 65 73 74 6d 6f 64 65 s))(eq? testmode
6c30: 20 27 6e 6f 72 6d 61 6c 29 29 0a 09 09 09 28 64 'normal))....(d
6c40: 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 ebug:print-info
6c50: 31 20 22 74 65 73 74 20 22 20 20 68 65 64 20 22 1 "test " hed "
6c60: 20 28 6d 6f 64 65 3d 22 20 74 65 73 74 6d 6f 64 (mode=" testmod
6c70: 65 20 22 29 20 68 61 73 20 66 61 69 6c 65 64 20 e ") has failed
6c80: 70 72 65 72 65 71 75 69 73 69 74 65 28 73 29 3b prerequisite(s);
6c90: 20 22 0a 09 09 09 09 20 20 20 20 20 28 73 74 72 "..... (str
6ca0: 69 6e 67 2d 69 6e 74 65 72 73 70 65 72 73 65 20 ing-intersperse
6cb0: 28 6d 61 70 20 28 6c 61 6d 62 64 61 20 28 74 29 (map (lambda (t)
6cc0: 28 63 6f 6e 63 20 28 64 62 3a 74 65 73 74 2d 67 (conc (db:test-g
6cd0: 65 74 2d 74 65 73 74 6e 61 6d 65 20 74 29 20 22 et-testname t) "
6ce0: 3a 22 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d :" (db:test-get-
6cf0: 73 74 61 74 65 20 74 29 22 2f 22 28 64 62 3a 74 state t)"/"(db:t
6d00: 65 73 74 2d 67 65 74 2d 73 74 61 74 75 73 20 74 est-get-status t
6d10: 29 29 29 20 66 61 69 6c 73 29 20 22 2c 20 22 29 ))) fails) ", ")
6d20: 0a 09 09 09 09 20 20 20 20 20 22 2c 20 72 65 6d ..... ", rem
6d30: 6f 76 69 6e 67 20 69 74 20 66 72 6f 6d 20 74 6f oving it from to
6d40: 2d 64 6f 20 6c 69 73 74 22 29 0a 09 09 09 28 69 -do list")....(i
6d50: 66 20 28 6e 6f 74 20 28 6e 75 6c 6c 3f 20 74 61 f (not (null? ta
6d60: 6c 29 29 0a 09 09 09 20 20 20 20 28 62 65 67 69 l)).... (begi
6d70: 6e 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 n.
6d80: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
6d90: 3b 3b 20 28 74 68 72 65 61 64 2d 73 6c 65 65 70 ;; (thread-sleep
6da0: 21 20 2a 67 6c 6f 62 61 6c 2d 64 65 6c 74 61 2a ! *global-delta*
6db0: 29 0a 09 09 09 20 20 20 20 20 20 28 6c 6f 6f 70 ).... (loop
6dc0: 20 28 63 61 72 20 74 61 6c 29 28 63 64 72 20 74 (car tal)(cdr t
6dd0: 61 6c 29 28 63 6f 6e 73 20 68 65 64 20 72 65 72 al)(cons hed rer
6de0: 75 6e 73 29 29 29 29 29 0a 09 09 20 20 20 20 20 uns)))))...
6df0: 20 20 28 65 6c 73 65 0a 09 09 09 28 64 65 62 75 (else....(debu
6e00: 67 3a 70 72 69 6e 74 20 38 20 22 45 52 52 4f 52 g:print 8 "ERROR
6e10: 3a 20 4e 6f 20 68 61 6e 64 6c 65 72 20 66 6f 72 : No handler for
6e20: 20 74 68 69 73 20 63 6f 6e 64 69 74 69 6f 6e 2e this condition.
6e30: 22 29 0a 09 09 09 28 74 68 72 65 61 64 2d 73 6c ")....(thread-sl
6e40: 65 65 70 21 20 28 2b 20 31 20 2a 67 6c 6f 62 61 eep! (+ 1 *globa
6e50: 6c 2d 64 65 6c 74 61 2a 29 29 0a 09 09 09 28 6c l-delta*))....(l
6e60: 6f 6f 70 20 28 63 61 72 20 6e 65 77 74 61 6c 29 oop (car newtal)
6e70: 28 63 64 72 20 6e 65 77 74 61 6c 29 20 72 65 72 (cdr newtal) rer
6e80: 75 6e 73 29 29 29 29 20 3b 3b 20 45 4e 44 20 4f uns)))) ;; END O
6e90: 46 20 49 46 20 43 41 4e 20 52 55 4e 20 4d 4f 52 F IF CAN RUN MOR
6ea0: 45 0a 0a 09 09 20 20 20 20 3b 3b 20 69 66 20 63 E.... ;; if c
6eb0: 61 6e 27 74 20 72 75 6e 20 6d 6f 72 65 20 6a 75 an't run more ju
6ec0: 73 74 20 6c 6f 6f 70 20 77 69 74 68 20 6e 65 78 st loop with nex
6ed0: 74 20 70 6f 73 73 69 62 6c 65 20 74 65 73 74 0a t possible test.
6ee0: 09 09 20 20 20 20 28 62 65 67 69 6e 0a 09 09 20 .. (begin...
6ef0: 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e (debug:prin
6f00: 74 2d 69 6e 66 6f 20 34 20 22 70 72 6f 63 65 73 t-info 4 "proces
6f10: 73 69 6e 67 20 74 68 65 20 63 61 73 65 20 77 69 sing the case wi
6f20: 74 68 20 61 20 6c 61 6d 62 64 61 20 66 6f 72 20 th a lambda for
6f30: 69 74 65 6d 73 20 6f 72 20 27 68 61 76 65 2d 70 items or 'have-p
6f40: 72 6f 63 65 64 75 72 65 2e 20 4d 6f 76 69 6e 67 rocedure. Moving
6f50: 20 74 68 72 6f 75 67 68 20 74 68 65 20 71 75 65 through the que
6f60: 75 65 20 77 69 74 68 6f 75 74 20 64 72 6f 70 70 ue without dropp
6f70: 69 6e 67 20 22 20 68 65 64 29 0a 09 09 20 20 20 ing " hed)...
6f80: 20 20 20 3b 3b 20 28 74 68 72 65 61 64 2d 73 6c ;; (thread-sl
6f90: 65 65 70 21 20 28 2b 20 32 20 2a 67 6c 6f 62 61 eep! (+ 2 *globa
6fa0: 6c 2d 64 65 6c 74 61 2a 29 29 0a 09 09 20 20 20 l-delta*))...
6fb0: 20 20 20 28 6c 6f 6f 70 20 28 63 61 72 20 6e 65 (loop (car ne
6fc0: 77 74 61 6c 29 28 63 64 72 20 6e 65 77 74 61 6c wtal)(cdr newtal
6fd0: 29 20 72 65 72 75 6e 73 29 29 29 29 29 20 3b 3b ) reruns))))) ;;
6fe0: 20 45 4e 44 20 4f 46 20 28 6f 72 20 28 70 72 6f END OF (or (pro
6ff0: 63 65 64 75 72 65 3f 20 69 74 65 6d 73 29 28 65 cedure? items)(e
7000: 71 3f 20 69 74 65 6d 73 20 27 68 61 76 65 2d 70 q? items 'have-p
7010: 72 6f 63 65 64 75 72 65 29 29 0a 09 20 20 20 20 rocedure))..
7020: 20 0a 09 20 20 20 20 20 3b 3b 20 74 68 69 73 20 .. ;; this
7030: 63 61 73 65 20 73 68 6f 75 6c 64 20 6e 6f 74 20 case should not
7040: 68 61 70 70 65 6e 2c 20 61 64 64 65 64 20 74 6f happen, added to
7050: 20 68 65 6c 70 20 63 61 74 63 68 20 61 6e 79 20 help catch any
7060: 62 75 67 73 0a 09 20 20 20 20 20 28 28 61 6e 64 bugs.. ((and
7070: 20 28 6c 69 73 74 3f 20 69 74 65 6d 73 29 20 69 (list? items) i
7080: 74 65 6d 64 61 74 29 0a 09 20 20 20 20 20 20 28 temdat).. (
7090: 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 22 45 debug:print 0 "E
70a0: 52 52 4f 52 3a 20 53 68 6f 75 6c 64 20 6e 6f 74 RROR: Should not
70b0: 20 68 61 76 65 20 61 20 6c 69 73 74 20 6f 66 20 have a list of
70c0: 69 74 65 6d 73 20 69 6e 20 61 20 74 65 73 74 20 items in a test
70d0: 61 6e 64 20 74 68 65 20 69 74 65 6d 73 70 61 74 and the itemspat
70e0: 68 20 73 65 74 20 2d 20 70 6c 65 61 73 65 20 72 h set - please r
70f0: 65 70 6f 72 74 20 74 68 69 73 22 29 0a 09 20 20 eport this")..
7100: 20 20 20 20 28 65 78 69 74 20 31 29 29 0a 09 20 (exit 1))..
7110: 20 20 20 20 28 28 6e 6f 74 20 28 6e 75 6c 6c 3f ((not (null?
7120: 20 72 65 72 75 6e 73 29 29 0a 09 20 20 20 20 20 reruns))..
7130: 20 28 6c 65 74 2a 20 28 28 6e 65 77 6c 73 74 20 (let* ((newlst
7140: 28 74 65 73 74 73 3a 66 69 6c 74 65 72 2d 6e 6f (tests:filter-no
7150: 6e 2d 72 75 6e 6e 61 62 6c 65 20 72 75 6e 2d 69 n-runnable run-i
7160: 64 20 74 61 6c 20 74 65 73 74 2d 72 65 63 6f 72 d tal test-recor
7170: 64 73 29 29 20 3b 3b 20 69 2e 65 2e 20 6e 6f 74 ds)) ;; i.e. not
7180: 20 46 41 49 4c 2c 20 57 41 49 56 45 44 2c 20 49 FAIL, WAIVED, I
7190: 4e 43 4f 4d 50 4c 45 54 45 2c 20 50 41 53 53 2c NCOMPLETE, PASS,
71a0: 20 4b 49 4c 4c 45 44 2c 0a 09 09 20 20 20 20 20 KILLED,...
71b0: 28 6a 75 6e 6b 65 64 20 28 6c 73 65 74 2d 64 69 (junked (lset-di
71c0: 66 66 65 72 65 6e 63 65 20 65 71 75 61 6c 3f 20 fference equal?
71d0: 74 61 6c 20 6e 65 77 6c 73 74 29 29 29 0a 09 09 tal newlst)))...
71e0: 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 (debug:print-inf
71f0: 6f 20 34 20 22 66 75 6c 6c 20 64 72 6f 70 20 74 o 4 "full drop t
7200: 68 72 6f 75 67 68 2c 20 69 66 20 72 65 72 75 6e hrough, if rerun
7210: 73 20 69 73 20 6c 65 73 73 20 74 68 61 6e 20 31 s is less than 1
7220: 30 30 20 77 65 20 77 69 6c 6c 20 66 6f 72 63 65 00 we will force
7230: 20 72 65 74 72 79 20 74 68 65 6d 2c 20 72 65 72 retry them, rer
7240: 75 6e 73 3d 22 20 72 65 72 75 6e 73 20 22 2c 20 uns=" reruns ",
7250: 74 61 6c 3d 22 20 74 61 6c 29 0a 09 09 28 69 66 tal=" tal)...(if
7260: 20 28 3c 20 6e 75 6d 2d 72 65 74 72 69 65 73 20 (< num-retries
7270: 6d 61 78 2d 72 65 74 72 69 65 73 29 0a 09 09 20 max-retries)...
7280: 20 20 20 28 73 65 74 21 20 6e 65 77 6c 73 74 20 (set! newlst
7290: 28 61 70 70 65 6e 64 20 72 65 72 75 6e 73 20 6e (append reruns n
72a0: 65 77 6c 73 74 29 29 29 0a 09 09 28 73 65 74 21 ewlst)))...(set!
72b0: 20 6e 75 6d 2d 72 65 74 72 69 65 73 20 28 2b 20 num-retries (+
72c0: 6e 75 6d 2d 72 65 74 72 69 65 73 20 31 29 29 0a num-retries 1)).
72d0: 09 09 3b 3b 20 28 74 68 72 65 61 64 2d 73 6c 65 ..;; (thread-sle
72e0: 65 70 21 20 28 2b 20 31 20 2a 67 6c 6f 62 61 6c ep! (+ 1 *global
72f0: 2d 64 65 6c 74 61 2a 29 29 0a 09 09 28 69 66 20 -delta*))...(if
7300: 28 6e 6f 74 20 28 6e 75 6c 6c 3f 20 6e 65 77 6c (not (null? newl
7310: 73 74 29 29 0a 09 09 20 20 20 20 3b 3b 20 73 69 st))... ;; si
7320: 6e 63 65 20 72 65 72 75 6e 73 20 68 61 76 65 20 nce reruns have
7330: 62 65 65 6e 20 74 61 63 6b 65 64 20 6f 6e 20 74 been tacked on t
7340: 6f 20 6e 65 77 6c 73 74 20 63 72 65 61 74 65 20 o newlst create
7350: 6e 65 77 20 72 65 72 75 6e 73 20 66 72 6f 6d 20 new reruns from
7360: 6a 75 6e 6b 65 64 0a 09 09 20 20 20 20 28 6c 6f junked... (lo
7370: 6f 70 20 28 63 61 72 20 6e 65 77 6c 73 74 29 28 op (car newlst)(
7380: 63 64 72 20 6e 65 77 6c 73 74 29 28 64 65 6c 65 cdr newlst)(dele
7390: 74 65 2d 64 75 70 6c 69 63 61 74 65 73 20 6a 75 te-duplicates ju
73a0: 6e 6b 65 64 29 29 29 29 29 0a 09 20 20 20 20 20 nked)))))..
73b0: 28 28 6e 6f 74 20 28 6e 75 6c 6c 3f 20 74 61 6c ((not (null? tal
73c0: 29 29 0a 09 20 20 20 20 20 20 28 64 65 62 75 67 )).. (debug
73d0: 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 34 20 22 49 :print-info 4 "I
73e0: 27 6d 20 70 72 65 74 74 79 20 73 75 72 65 20 49 'm pretty sure I
73f0: 20 73 68 6f 75 6c 64 6e 27 74 20 67 65 74 20 68 shouldn't get h
7400: 65 72 65 2e 22 29 29 0a 09 20 20 20 20 20 28 65 ere.")).. (e
7410: 6c 73 65 0a 09 20 20 20 20 20 20 28 64 65 62 75 lse.. (debu
7420: 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 34 20 22 g:print-info 4 "
7430: 45 78 69 74 69 6e 67 20 6c 6f 6f 70 20 77 69 74 Exiting loop wit
7440: 68 2e 2e 2e 5c 6e 20 20 68 65 64 3d 22 20 68 65 h...\n hed=" he
7450: 64 20 22 5c 6e 20 20 74 61 6c 3d 22 20 74 61 6c d "\n tal=" tal
7460: 20 22 5c 6e 20 20 72 65 72 75 6e 73 3d 22 20 72 "\n reruns=" r
7470: 65 72 75 6e 73 29 29 0a 09 20 20 20 20 20 29 29 eruns)).. ))
7480: 29 29 20 3b 3b 20 4c 45 54 2a 20 28 28 74 65 73 )) ;; LET* ((tes
7490: 74 2d 72 65 63 6f 72 64 0a 0a 20 20 20 20 3b 3b t-record.. ;;
74a0: 20 77 65 20 67 65 74 20 68 65 72 65 20 6f 6e 20 we get here on
74b0: 22 64 72 6f 70 20 74 68 72 6f 75 67 68 22 20 2d "drop through" -
74c0: 20 6c 6f 6f 70 20 66 6f 72 20 6e 65 78 74 20 74 loop for next t
74d0: 65 73 74 20 69 6e 20 71 75 65 75 65 0a 20 20 20 est in queue.
74e0: 20 3b 3b 20 46 49 58 4d 45 21 21 21 21 20 54 48 ;; FIXME!!!! TH
74f0: 49 53 20 53 48 4f 55 4c 44 20 4e 4f 54 20 52 45 IS SHOULD NOT RE
7500: 51 55 49 52 45 20 41 4e 20 45 58 49 54 21 21 21 QUIRE AN EXIT!!!
7510: 21 21 21 21 0a 20 20 20 20 0a 20 20 20 20 28 64 !!!!. . (d
7520: 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 ebug:print-info
7530: 31 20 22 41 6c 6c 20 74 65 73 74 73 20 6c 61 75 1 "All tests lau
7540: 6e 63 68 65 64 22 29 0a 20 20 20 20 28 74 68 72 nched"). (thr
7550: 65 61 64 2d 73 6c 65 65 70 21 20 30 2e 35 29 0a ead-sleep! 0.5).
7560: 20 20 20 20 3b 3b 20 46 49 58 4d 45 21 20 54 68 ;; FIXME! Th
7570: 69 73 20 68 61 72 73 68 20 65 78 69 74 20 73 68 is harsh exit sh
7580: 6f 75 6c 64 20 6e 6f 74 20 62 65 20 6e 65 63 65 ould not be nece
7590: 73 73 61 72 79 2e 2e 2e 2e 0a 20 20 20 20 3b 3b ssary..... ;;
75a0: 20 28 69 66 20 28 6e 6f 74 20 2a 72 75 6e 72 65 (if (not *runre
75b0: 6d 6f 74 65 2a 29 28 65 78 69 74 29 29 20 3b 3b mote*)(exit)) ;;
75c0: 20 0a 20 20 20 20 23 66 29 29 20 3b 3b 20 72 65 . #f)) ;; re
75d0: 74 75 72 6e 20 61 20 23 66 20 61 73 20 61 20 68 turn a #f as a h
75e0: 69 6e 74 20 74 68 61 74 20 77 65 20 61 72 65 20 int that we are
75f0: 64 6f 6e 65 0a 20 20 3b 3b 20 48 65 72 65 20 77 done. ;; Here w
7600: 65 20 6e 65 65 64 20 74 6f 20 63 68 65 63 6b 20 e need to check
7610: 74 68 61 74 20 61 6c 6c 20 74 68 65 20 74 65 73 that all the tes
7620: 74 73 20 72 65 6d 61 69 6e 69 6e 67 20 74 6f 20 ts remaining to
7630: 62 65 20 72 75 6e 20 61 72 65 20 65 6c 69 67 69 be run are eligi
7640: 62 6c 65 20 74 6f 20 72 75 6e 0a 20 20 3b 3b 20 ble to run. ;;
7650: 61 6e 64 20 61 72 65 20 6e 6f 74 20 62 6c 6f 63 and are not bloc
7660: 6b 65 64 20 62 79 20 66 61 69 6c 65 64 0a 20 20 ked by failed.
7670: 0a 0a 3b 3b 20 70 61 72 65 6e 74 2d 74 65 73 74 ..;; parent-test
7680: 20 69 73 20 74 68 65 72 65 20 61 73 20 61 20 70 is there as a p
7690: 6c 61 63 65 68 6f 6c 64 65 72 20 66 6f 72 20 77 laceholder for w
76a0: 68 65 6e 20 70 61 72 65 6e 74 2d 74 65 73 74 73 hen parent-tests
76b0: 20 63 61 6e 20 62 65 20 72 75 6e 20 61 73 20 61 can be run as a
76c0: 20 73 65 74 75 70 20 73 74 65 70 0a 28 64 65 66 setup step.(def
76d0: 69 6e 65 20 28 72 75 6e 3a 74 65 73 74 20 72 75 ine (run:test ru
76e0: 6e 2d 69 64 20 72 75 6e 6e 61 6d 65 20 6b 65 79 n-id runname key
76f0: 76 61 6c 6c 73 74 20 74 65 73 74 2d 72 65 63 6f vallst test-reco
7700: 72 64 20 66 6c 61 67 73 20 70 61 72 65 6e 74 2d rd flags parent-
7710: 74 65 73 74 29 0a 20 20 3b 3b 20 41 6c 6c 20 74 test). ;; All t
7720: 68 65 73 65 20 76 61 72 73 20 6d 69 67 68 74 20 hese vars might
7730: 62 65 20 72 65 66 65 72 65 6e 63 65 64 20 62 79 be referenced by
7740: 20 74 68 65 20 74 65 73 74 63 6f 6e 66 69 67 20 the testconfig
7750: 66 69 6c 65 20 72 65 61 64 65 72 0a 20 20 28 6c file reader. (l
7760: 65 74 2a 20 28 28 74 65 73 74 2d 6e 61 6d 65 20 et* ((test-name
7770: 20 20 20 28 74 65 73 74 73 3a 74 65 73 74 71 75 (tests:testqu
7780: 65 75 65 2d 67 65 74 2d 74 65 73 74 6e 61 6d 65 eue-get-testname
7790: 20 20 20 74 65 73 74 2d 72 65 63 6f 72 64 29 29 test-record))
77a0: 0a 09 20 28 74 65 73 74 2d 77 61 69 74 6f 6e 73 .. (test-waitons
77b0: 20 28 74 65 73 74 73 3a 74 65 73 74 71 75 65 75 (tests:testqueu
77c0: 65 2d 67 65 74 2d 77 61 69 74 6f 6e 73 20 20 20 e-get-waitons
77d0: 20 74 65 73 74 2d 72 65 63 6f 72 64 29 29 0a 09 test-record))..
77e0: 20 28 74 65 73 74 2d 63 6f 6e 66 20 20 20 20 28 (test-conf (
77f0: 74 65 73 74 73 3a 74 65 73 74 71 75 65 75 65 2d tests:testqueue-
7800: 67 65 74 2d 74 65 73 74 63 6f 6e 66 69 67 20 74 get-testconfig t
7810: 65 73 74 2d 72 65 63 6f 72 64 29 29 0a 09 20 28 est-record)).. (
7820: 69 74 65 6d 64 61 74 20 20 20 20 20 20 28 74 65 itemdat (te
7830: 73 74 73 3a 74 65 73 74 71 75 65 75 65 2d 67 65 sts:testqueue-ge
7840: 74 2d 69 74 65 6d 64 61 74 20 20 20 20 74 65 73 t-itemdat tes
7850: 74 2d 72 65 63 6f 72 64 29 29 0a 09 20 28 74 65 t-record)).. (te
7860: 73 74 2d 70 61 74 68 20 20 20 20 28 63 6f 6e 63 st-path (conc
7870: 20 2a 74 6f 70 70 61 74 68 2a 20 22 2f 74 65 73 *toppath* "/tes
7880: 74 73 2f 22 20 74 65 73 74 2d 6e 61 6d 65 29 29 ts/" test-name))
7890: 20 3b 3b 20 63 6f 75 6c 64 20 75 73 65 20 74 65 ;; could use te
78a0: 73 74 73 3a 67 65 74 2d 74 65 73 74 63 6f 6e 66 sts:get-testconf
78b0: 69 67 20 68 65 72 65 20 2e 2e 2e 0a 09 20 28 66 ig here ..... (f
78c0: 6f 72 63 65 20 20 20 20 20 20 20 20 28 68 61 73 orce (has
78d0: 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 h-table-ref/defa
78e0: 75 6c 74 20 66 6c 61 67 73 20 22 2d 66 6f 72 63 ult flags "-forc
78f0: 65 22 20 23 66 29 29 0a 09 20 28 72 65 72 75 6e e" #f)).. (rerun
7900: 20 20 20 20 20 20 20 20 28 68 61 73 68 2d 74 61 (hash-ta
7910: 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 ble-ref/default
7920: 66 6c 61 67 73 20 22 2d 72 65 72 75 6e 22 20 23 flags "-rerun" #
7930: 66 29 29 0a 09 20 28 6b 65 65 70 67 6f 69 6e 67 f)).. (keepgoing
7940: 20 20 20 20 28 68 61 73 68 2d 74 61 62 6c 65 2d (hash-table-
7950: 72 65 66 2f 64 65 66 61 75 6c 74 20 66 6c 61 67 ref/default flag
7960: 73 20 22 2d 6b 65 65 70 67 6f 69 6e 67 22 20 23 s "-keepgoing" #
7970: 66 29 29 0a 09 20 28 69 74 65 6d 2d 70 61 74 68 f)).. (item-path
7980: 20 20 20 20 20 22 22 29 0a 09 20 28 64 62 20 20 "").. (db
7990: 20 20 20 20 20 20 20 20 20 23 66 29 29 0a 20 20 #f)).
79a0: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 34 (debug:print 4
79b0: 0a 09 09 20 22 74 65 73 74 2d 63 6f 6e 66 69 67 ... "test-config
79c0: 3a 20 22 20 28 68 61 73 68 2d 74 61 62 6c 65 2d : " (hash-table-
79d0: 3e 61 6c 69 73 74 20 74 65 73 74 2d 63 6f 6e 66 >alist test-conf
79e0: 29 0a 09 09 20 22 5c 6e 20 20 20 69 74 65 6d 64 )... "\n itemd
79f0: 61 74 3a 20 22 20 69 74 65 6d 64 61 74 0a 09 09 at: " itemdat...
7a00: 20 29 0a 20 20 20 20 3b 3b 20 73 65 74 74 69 6e ). ;; settin
7a10: 67 20 69 74 65 6d 64 61 74 20 74 6f 20 61 20 6c g itemdat to a l
7a20: 69 73 74 20 69 66 20 69 74 20 69 73 20 23 66 0a ist if it is #f.
7a30: 20 20 20 20 28 69 66 20 28 6e 6f 74 20 69 74 65 (if (not ite
7a40: 6d 64 61 74 29 28 73 65 74 21 20 69 74 65 6d 64 mdat)(set! itemd
7a50: 61 74 20 27 28 29 29 29 0a 20 20 20 20 28 73 65 at '())). (se
7a60: 74 21 20 69 74 65 6d 2d 70 61 74 68 20 28 69 74 t! item-path (it
7a70: 65 6d 2d 6c 69 73 74 2d 3e 70 61 74 68 20 69 74 em-list->path it
7a80: 65 6d 64 61 74 29 29 0a 20 20 20 20 28 64 65 62 emdat)). (deb
7a90: 75 67 3a 70 72 69 6e 74 20 32 20 22 41 74 74 65 ug:print 2 "Atte
7aa0: 6d 70 74 69 6e 67 20 74 6f 20 6c 61 75 6e 63 68 mpting to launch
7ab0: 20 74 65 73 74 20 22 20 74 65 73 74 2d 6e 61 6d test " test-nam
7ac0: 65 20 28 69 66 20 28 65 71 75 61 6c 3f 20 69 74 e (if (equal? it
7ad0: 65 6d 2d 70 61 74 68 20 22 2f 22 29 20 22 2f 22 em-path "/") "/"
7ae0: 20 69 74 65 6d 2d 70 61 74 68 29 29 0a 20 20 20 item-path)).
7af0: 20 28 73 65 74 65 6e 76 20 22 4d 54 5f 54 45 53 (setenv "MT_TES
7b00: 54 5f 4e 41 4d 45 22 20 74 65 73 74 2d 6e 61 6d T_NAME" test-nam
7b10: 65 29 20 3b 3b 20 0a 20 20 20 20 28 73 65 74 65 e) ;; . (sete
7b20: 6e 76 20 22 4d 54 5f 52 55 4e 4e 41 4d 45 22 20 nv "MT_RUNNAME"
7b30: 20 20 72 75 6e 6e 61 6d 65 29 0a 20 20 20 20 28 runname). (
7b40: 73 65 74 2d 6d 65 67 61 74 65 73 74 2d 65 6e 76 set-megatest-env
7b50: 2d 76 61 72 73 20 72 75 6e 2d 69 64 29 20 3b 3b -vars run-id) ;;
7b60: 20 74 68 65 73 65 20 6d 61 79 20 62 65 20 6e 65 these may be ne
7b70: 65 64 65 64 20 62 79 20 74 68 65 20 6c 61 75 6e eded by the laun
7b80: 63 68 69 6e 67 20 70 72 6f 63 65 73 73 0a 20 20 ching process.
7b90: 20 20 28 63 68 61 6e 67 65 2d 64 69 72 65 63 74 (change-direct
7ba0: 6f 72 79 20 2a 74 6f 70 70 61 74 68 2a 29 0a 0a ory *toppath*)..
7bb0: 20 20 20 20 3b 3b 20 48 65 72 65 20 69 73 20 77 ;; Here is w
7bc0: 68 65 72 65 20 74 68 65 20 74 65 73 74 5f 6d 65 here the test_me
7bd0: 74 61 20 74 61 62 6c 65 20 69 73 20 62 65 73 74 ta table is best
7be0: 20 75 70 64 61 74 65 64 0a 20 20 20 20 3b 3b 20 updated. ;;
7bf0: 59 65 73 2c 20 61 6e 6f 74 68 65 72 20 75 73 65 Yes, another use
7c00: 20 6f 66 20 61 20 67 6c 6f 62 61 6c 20 66 6f 72 of a global for
7c10: 20 63 61 63 68 69 6e 67 2e 20 4e 65 65 64 20 61 caching. Need a
7c20: 20 62 65 74 74 65 72 20 77 61 79 3f 0a 20 20 20 better way?.
7c30: 20 28 69 66 20 28 6e 6f 74 20 28 68 61 73 68 2d (if (not (hash-
7c40: 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c table-ref/defaul
7c50: 74 20 2a 74 65 73 74 2d 6d 65 74 61 2d 75 70 64 t *test-meta-upd
7c60: 61 74 65 64 2a 20 74 65 73 74 2d 6e 61 6d 65 20 ated* test-name
7c70: 23 66 29 29 0a 20 20 20 20 20 20 20 20 28 62 65 #f)). (be
7c80: 67 69 6e 0a 09 20 20 20 28 68 61 73 68 2d 74 61 gin.. (hash-ta
7c90: 62 6c 65 2d 73 65 74 21 20 2a 74 65 73 74 2d 6d ble-set! *test-m
7ca0: 65 74 61 2d 75 70 64 61 74 65 64 2a 20 74 65 73 eta-updated* tes
7cb0: 74 2d 6e 61 6d 65 20 23 74 29 0a 20 20 20 20 20 t-name #t).
7cc0: 20 20 20 20 20 20 28 6f 70 65 6e 2d 72 75 6e 2d (open-run-
7cd0: 63 6c 6f 73 65 20 72 75 6e 73 3a 75 70 64 61 74 close runs:updat
7ce0: 65 2d 74 65 73 74 5f 6d 65 74 61 20 64 62 20 74 e-test_meta db t
7cf0: 65 73 74 2d 6e 61 6d 65 20 74 65 73 74 2d 63 6f est-name test-co
7d00: 6e 66 29 29 29 0a 20 20 20 20 0a 20 20 20 20 3b nf))). . ;
7d10: 3b 20 28 6c 61 6d 62 64 61 20 28 69 74 65 6d 64 ; (lambda (itemd
7d20: 61 74 29 20 3b 3b 3b 20 28 28 72 69 70 65 6e 65 at) ;;; ((ripene
7d30: 73 73 20 22 6f 76 65 72 72 69 70 65 22 29 20 28 ss "overripe") (
7d40: 74 65 6d 70 65 72 61 74 75 72 65 20 22 63 6f 6f temperature "coo
7d50: 6c 22 29 20 28 73 65 61 73 6f 6e 20 22 73 75 6d l") (season "sum
7d60: 6d 65 72 22 29 29 0a 20 20 20 20 28 6c 65 74 2a mer")). (let*
7d70: 20 28 28 6e 65 77 2d 74 65 73 74 2d 70 61 74 68 ((new-test-path
7d80: 20 28 73 74 72 69 6e 67 2d 69 6e 74 65 72 73 70 (string-intersp
7d90: 65 72 73 65 20 28 63 6f 6e 73 20 74 65 73 74 2d erse (cons test-
7da0: 70 61 74 68 20 28 6d 61 70 20 63 61 64 72 20 69 path (map cadr i
7db0: 74 65 6d 64 61 74 29 29 20 22 2f 22 29 29 0a 09 temdat)) "/"))..
7dc0: 20 20 20 28 6e 65 77 2d 74 65 73 74 2d 6e 61 6d (new-test-nam
7dd0: 65 20 28 69 66 20 28 65 71 75 61 6c 3f 20 69 74 e (if (equal? it
7de0: 65 6d 2d 70 61 74 68 20 22 22 29 20 74 65 73 74 em-path "") test
7df0: 2d 6e 61 6d 65 20 28 63 6f 6e 63 20 74 65 73 74 -name (conc test
7e00: 2d 6e 61 6d 65 20 22 2f 22 20 69 74 65 6d 2d 70 -name "/" item-p
7e10: 61 74 68 29 29 29 20 3b 3b 20 6a 75 73 74 20 6e ath))) ;; just n
7e20: 65 65 64 20 69 74 20 74 6f 20 62 65 20 75 6e 69 eed it to be uni
7e30: 71 75 65 0a 09 20 20 20 28 74 65 73 74 2d 69 64 que.. (test-id
7e40: 20 20 20 20 20 20 20 28 63 64 62 3a 72 65 6d 6f (cdb:remo
7e50: 74 65 2d 72 75 6e 20 64 62 3a 67 65 74 2d 74 65 te-run db:get-te
7e60: 73 74 2d 69 64 20 23 66 20 20 72 75 6e 2d 69 64 st-id #f run-id
7e70: 20 74 65 73 74 2d 6e 61 6d 65 20 69 74 65 6d 2d test-name item-
7e80: 70 61 74 68 29 29 0a 09 20 20 20 28 74 65 73 74 path)).. (test
7e90: 64 61 74 20 20 20 20 20 20 20 28 63 64 62 3a 67 dat (cdb:g
7ea0: 65 74 2d 74 65 73 74 2d 69 6e 66 6f 2d 62 79 2d et-test-info-by-
7eb0: 69 64 20 2a 72 75 6e 72 65 6d 6f 74 65 2a 20 74 id *runremote* t
7ec0: 65 73 74 2d 69 64 29 29 29 0a 20 20 20 20 20 20 est-id))).
7ed0: 28 69 66 20 28 6e 6f 74 20 74 65 73 74 64 61 74 (if (not testdat
7ee0: 29 0a 09 20 20 28 62 65 67 69 6e 0a 09 20 20 20 ).. (begin..
7ef0: 20 3b 3b 20 65 6e 73 75 72 65 20 74 68 61 74 20 ;; ensure that
7f00: 74 68 65 20 70 61 74 68 20 65 78 69 73 74 73 20 the path exists
7f10: 62 65 66 6f 72 65 20 72 65 67 69 73 74 65 72 69 before registeri
7f20: 6e 67 20 74 68 65 20 74 65 73 74 0a 09 20 20 20 ng the test..
7f30: 20 3b 3b 20 4e 4f 50 45 3a 20 43 61 6e 6e 6f 74 ;; NOPE: Cannot
7f40: 21 20 44 6f 6e 27 74 20 6b 6e 6f 77 20 79 65 74 ! Don't know yet
7f50: 20 77 68 69 63 68 20 64 69 73 6b 20 61 72 65 61 which disk area
7f60: 20 77 69 6c 6c 20 62 65 20 61 73 73 69 67 6e 65 will be assigne
7f70: 64 2e 2e 2e 2e 0a 09 20 20 20 20 3b 3b 20 28 73 d...... ;; (s
7f80: 79 73 74 65 6d 20 28 63 6f 6e 63 20 22 6d 6b 64 ystem (conc "mkd
7f90: 69 72 20 2d 70 20 22 20 6e 65 77 2d 74 65 73 74 ir -p " new-test
7fa0: 2d 70 61 74 68 29 29 0a 09 20 20 20 20 3b 3b 0a -path)).. ;;.
7fb0: 09 20 20 20 20 3b 3b 20 28 6f 70 65 6e 2d 72 75 . ;; (open-ru
7fc0: 6e 2d 63 6c 6f 73 65 20 74 65 73 74 73 3a 72 65 n-close tests:re
7fd0: 67 69 73 74 65 72 2d 74 65 73 74 20 64 62 20 72 gister-test db r
7fe0: 75 6e 2d 69 64 20 74 65 73 74 2d 6e 61 6d 65 20 un-id test-name
7ff0: 69 74 65 6d 2d 70 61 74 68 29 0a 09 20 20 20 20 item-path)..
8000: 3b 3b 0a 09 20 20 20 20 3b 3b 20 4e 42 2f 2f 20 ;;.. ;; NB//
8010: 66 6f 72 20 74 68 65 20 61 62 6f 76 65 20 6c 69 for the above li
8020: 6e 65 2e 20 49 20 77 61 6e 74 20 74 68 65 20 74 ne. I want the t
8030: 65 73 74 20 74 6f 20 62 65 20 72 65 67 69 73 74 est to be regist
8040: 65 72 65 64 20 6c 6f 6e 67 20 62 65 66 6f 72 65 ered long before
8050: 20 74 68 69 73 20 72 6f 75 74 69 6e 65 20 67 65 this routine ge
8060: 74 73 20 63 61 6c 6c 65 64 21 0a 09 20 20 20 20 ts called!..
8070: 3b 3b 0a 09 20 20 20 20 28 73 65 74 21 20 74 65 ;;.. (set! te
8080: 73 74 2d 69 64 20 28 6f 70 65 6e 2d 72 75 6e 2d st-id (open-run-
8090: 63 6c 6f 73 65 20 64 62 3a 67 65 74 2d 74 65 73 close db:get-tes
80a0: 74 2d 69 64 20 64 62 20 72 75 6e 2d 69 64 20 74 t-id db run-id t
80b0: 65 73 74 2d 6e 61 6d 65 20 69 74 65 6d 2d 70 61 est-name item-pa
80c0: 74 68 29 29 0a 09 20 20 20 20 28 69 66 20 28 6e th)).. (if (n
80d0: 6f 74 20 74 65 73 74 2d 69 64 29 0a 09 09 28 62 ot test-id)...(b
80e0: 65 67 69 6e 0a 09 09 20 20 28 64 65 62 75 67 3a egin... (debug:
80f0: 70 72 69 6e 74 20 32 20 22 57 41 52 4e 3a 20 54 print 2 "WARN: T
8100: 65 73 74 20 6e 6f 74 20 70 72 65 2d 63 72 65 61 est not pre-crea
8110: 74 65 64 3f 20 74 65 73 74 2d 6e 61 6d 65 3d 22 ted? test-name="
8120: 20 74 65 73 74 2d 6e 61 6d 65 20 22 2c 20 69 74 test-name ", it
8130: 65 6d 2d 70 61 74 68 3d 22 20 69 74 65 6d 2d 70 em-path=" item-p
8140: 61 74 68 20 22 2c 20 72 75 6e 2d 69 64 3d 22 20 ath ", run-id="
8150: 72 75 6e 2d 69 64 29 0a 09 09 20 20 28 63 64 62 run-id)... (cdb
8160: 3a 74 65 73 74 73 2d 72 65 67 69 73 74 65 72 2d :tests-register-
8170: 74 65 73 74 20 2a 72 75 6e 72 65 6d 6f 74 65 2a test *runremote*
8180: 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 6e 61 6d run-id test-nam
8190: 65 20 69 74 65 6d 2d 70 61 74 68 29 0a 09 09 20 e item-path)...
81a0: 20 28 73 65 74 21 20 74 65 73 74 2d 69 64 20 28 (set! test-id (
81b0: 6f 70 65 6e 2d 72 75 6e 2d 63 6c 6f 73 65 20 64 open-run-close d
81c0: 62 3a 67 65 74 2d 74 65 73 74 2d 69 64 20 64 62 b:get-test-id db
81d0: 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 6e 61 6d run-id test-nam
81e0: 65 20 69 74 65 6d 2d 70 61 74 68 29 29 29 29 0a e item-path)))).
81f0: 09 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e . (debug:prin
8200: 74 2d 69 6e 66 6f 20 34 20 22 74 65 73 74 2d 69 t-info 4 "test-i
8210: 64 3d 22 20 74 65 73 74 2d 69 64 20 22 2c 20 72 d=" test-id ", r
8220: 75 6e 2d 69 64 3d 22 20 72 75 6e 2d 69 64 20 22 un-id=" run-id "
8230: 2c 20 74 65 73 74 2d 6e 61 6d 65 3d 22 20 74 65 , test-name=" te
8240: 73 74 2d 6e 61 6d 65 20 22 2c 20 69 74 65 6d 2d st-name ", item-
8250: 70 61 74 68 3d 5c 22 22 20 69 74 65 6d 2d 70 61 path=\"" item-pa
8260: 74 68 20 22 5c 22 22 29 0a 09 20 20 20 20 28 73 th "\"").. (s
8270: 65 74 21 20 74 65 73 74 64 61 74 20 28 63 64 62 et! testdat (cdb
8280: 3a 67 65 74 2d 74 65 73 74 2d 69 6e 66 6f 2d 62 :get-test-info-b
8290: 79 2d 69 64 20 2a 72 75 6e 72 65 6d 6f 74 65 2a y-id *runremote*
82a0: 20 74 65 73 74 2d 69 64 29 29 29 29 0a 20 20 20 test-id)))).
82b0: 20 20 20 28 73 65 74 21 20 74 65 73 74 2d 69 64 (set! test-id
82c0: 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 69 64 (db:test-get-id
82d0: 20 74 65 73 74 64 61 74 29 29 0a 20 20 20 20 20 testdat)).
82e0: 20 28 63 68 61 6e 67 65 2d 64 69 72 65 63 74 6f (change-directo
82f0: 72 79 20 74 65 73 74 2d 70 61 74 68 29 0a 20 20 ry test-path).
8300: 20 20 20 20 28 63 61 73 65 20 28 69 66 20 66 6f (case (if fo
8310: 72 63 65 20 3b 3b 20 28 61 72 67 73 3a 67 65 74 rce ;; (args:get
8320: 2d 61 72 67 20 22 2d 66 6f 72 63 65 22 29 0a 09 -arg "-force")..
8330: 09 27 4e 4f 54 5f 53 54 41 52 54 45 44 0a 09 09 .'NOT_STARTED...
8340: 28 69 66 20 74 65 73 74 64 61 74 0a 09 09 20 20 (if testdat...
8350: 20 20 28 73 74 72 69 6e 67 2d 3e 73 79 6d 62 6f (string->symbo
8360: 6c 20 28 74 65 73 74 3a 67 65 74 2d 73 74 61 74 l (test:get-stat
8370: 65 20 74 65 73 74 64 61 74 29 29 0a 09 09 20 20 e testdat))...
8380: 20 20 27 66 61 69 6c 65 64 2d 74 6f 2d 69 6e 73 'failed-to-ins
8390: 65 72 74 29 29 0a 09 28 28 66 61 69 6c 65 64 2d ert))..((failed-
83a0: 74 6f 2d 69 6e 73 65 72 74 29 0a 09 20 28 64 65 to-insert).. (de
83b0: 62 75 67 3a 70 72 69 6e 74 20 30 20 22 45 52 52 bug:print 0 "ERR
83c0: 4f 52 3a 20 46 61 69 6c 65 64 20 74 6f 20 69 6e OR: Failed to in
83d0: 73 65 72 74 20 74 68 65 20 72 65 63 6f 72 64 20 sert the record
83e0: 69 6e 74 6f 20 74 68 65 20 64 62 22 29 29 0a 09 into the db"))..
83f0: 28 28 4e 4f 54 5f 53 54 41 52 54 45 44 20 43 4f ((NOT_STARTED CO
8400: 4d 50 4c 45 54 45 44 20 44 45 4c 45 54 45 44 29 MPLETED DELETED)
8410: 0a 09 20 28 6c 65 74 20 28 28 72 75 6e 66 6c 61 .. (let ((runfla
8420: 67 20 23 66 29 29 0a 09 20 20 20 28 63 6f 6e 64 g #f)).. (cond
8430: 0a 09 20 20 20 20 3b 3b 20 2d 66 6f 72 63 65 2c .. ;; -force,
8440: 20 72 75 6e 20 6e 6f 20 6d 61 74 74 65 72 20 77 run no matter w
8450: 68 61 74 0a 09 20 20 20 20 28 66 6f 72 63 65 20 hat.. (force
8460: 28 73 65 74 21 20 72 75 6e 66 6c 61 67 20 23 74 (set! runflag #t
8470: 29 29 0a 09 20 20 20 20 3b 3b 20 4e 4f 54 5f 53 )).. ;; NOT_S
8480: 54 41 52 54 45 44 2c 20 72 75 6e 20 6e 6f 20 6d TARTED, run no m
8490: 61 74 74 65 72 20 77 68 61 74 0a 09 20 20 20 20 atter what..
84a0: 28 28 6d 65 6d 62 65 72 20 28 74 65 73 74 3a 67 ((member (test:g
84b0: 65 74 2d 73 74 61 74 65 20 74 65 73 74 64 61 74 et-state testdat
84c0: 29 20 27 28 22 44 45 4c 45 54 45 44 22 20 22 4e ) '("DELETED" "N
84d0: 4f 54 5f 53 54 41 52 54 45 44 22 29 29 28 73 65 OT_STARTED"))(se
84e0: 74 21 20 72 75 6e 66 6c 61 67 20 23 74 29 29 0a t! runflag #t)).
84f0: 09 20 20 20 20 3b 3b 20 6e 6f 74 20 2d 72 65 72 . ;; not -rer
8500: 75 6e 20 61 6e 64 20 50 41 53 53 2c 20 57 41 52 un and PASS, WAR
8510: 4e 20 6f 72 20 43 48 45 43 4b 2c 20 64 6f 20 6e N or CHECK, do n
8520: 6f 20 72 75 6e 0a 09 20 20 20 20 28 28 61 6e 64 o run.. ((and
8530: 20 28 6f 72 20 28 6e 6f 74 20 72 65 72 75 6e 29 (or (not rerun)
8540: 0a 09 09 20 20 20 20 20 20 6b 65 65 70 67 6f 69 ... keepgoi
8550: 6e 67 29 0a 09 09 20 20 3b 3b 20 52 65 71 75 69 ng)... ;; Requi
8560: 72 65 20 74 6f 20 66 6f 72 63 65 20 72 65 2d 72 re to force re-r
8570: 75 6e 20 66 6f 72 20 43 4f 4d 50 4c 45 54 45 44 un for COMPLETED
8580: 20 6f 72 20 2a 61 6e 79 74 68 69 6e 67 2a 20 2b or *anything* +
8590: 20 50 41 53 53 2c 57 41 52 4e 20 6f 72 20 43 48 PASS,WARN or CH
85a0: 45 43 4b 0a 09 09 20 20 28 6f 72 20 28 6d 65 6d ECK... (or (mem
85b0: 62 65 72 20 28 74 65 73 74 3a 67 65 74 2d 73 74 ber (test:get-st
85c0: 61 74 75 73 20 74 65 73 74 64 61 74 29 20 27 28 atus testdat) '(
85d0: 22 50 41 53 53 22 20 22 57 41 52 4e 22 20 22 43 "PASS" "WARN" "C
85e0: 48 45 43 4b 22 20 22 53 4b 49 50 22 29 29 0a 09 HECK" "SKIP"))..
85f0: 09 20 20 20 20 20 20 28 6d 65 6d 62 65 72 20 28 . (member (
8600: 74 65 73 74 3a 67 65 74 2d 73 74 61 74 65 20 20 test:get-state
8610: 74 65 73 74 64 61 74 29 20 27 28 22 43 4f 4d 50 testdat) '("COMP
8620: 4c 45 54 45 44 22 29 29 29 29 20 0a 09 20 20 20 LETED")))) ..
8630: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 (debug:print-i
8640: 6e 66 6f 20 32 20 22 72 75 6e 6e 69 6e 67 20 74 nfo 2 "running t
8650: 65 73 74 20 22 20 74 65 73 74 2d 6e 61 6d 65 20 est " test-name
8660: 22 2f 22 20 69 74 65 6d 2d 70 61 74 68 20 22 20 "/" item-path "
8670: 73 75 70 70 72 65 73 73 65 64 20 61 73 20 69 74 suppressed as it
8680: 20 69 73 20 22 20 28 74 65 73 74 3a 67 65 74 2d is " (test:get-
8690: 73 74 61 74 65 20 74 65 73 74 64 61 74 29 20 22 state testdat) "
86a0: 20 61 6e 64 20 22 20 28 74 65 73 74 3a 67 65 74 and " (test:get
86b0: 2d 73 74 61 74 75 73 20 74 65 73 74 64 61 74 29 -status testdat)
86c0: 29 0a 09 20 20 20 20 20 28 73 65 74 21 20 72 75 ).. (set! ru
86d0: 6e 66 6c 61 67 20 23 66 29 29 0a 09 20 20 20 20 nflag #f))..
86e0: 3b 3b 20 2d 72 65 72 75 6e 20 61 6e 64 20 73 74 ;; -rerun and st
86f0: 61 74 75 73 20 69 73 20 6f 6e 65 20 6f 66 20 74 atus is one of t
8700: 68 65 20 73 70 65 63 69 66 65 64 2c 20 72 75 6e he specifed, run
8710: 20 69 74 0a 09 20 20 20 20 28 28 61 6e 64 20 72 it.. ((and r
8720: 65 72 75 6e 0a 09 09 20 20 28 6c 65 74 2a 20 28 erun... (let* (
8730: 28 72 65 72 75 6e 6c 73 74 20 20 20 28 73 74 72 (rerunlst (str
8740: 69 6e 67 2d 73 70 6c 69 74 20 72 65 72 75 6e 20 ing-split rerun
8750: 22 2c 22 29 29 0a 09 09 09 20 28 6d 75 73 74 2d ",")).... (must-
8760: 72 65 72 75 6e 20 28 6d 65 6d 62 65 72 20 28 74 rerun (member (t
8770: 65 73 74 3a 67 65 74 2d 73 74 61 74 75 73 20 74 est:get-status t
8780: 65 73 74 64 61 74 29 20 72 65 72 75 6e 6c 73 74 estdat) rerunlst
8790: 29 29 29 0a 09 09 20 20 20 20 28 64 65 62 75 67 )))... (debug
87a0: 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 33 20 22 2d :print-info 3 "-
87b0: 72 65 72 75 6e 20 6c 69 73 74 3a 20 22 20 72 65 rerun list: " re
87c0: 72 75 6e 20 22 2c 20 74 65 73 74 2d 73 74 61 74 run ", test-stat
87d0: 75 73 3a 20 22 20 28 74 65 73 74 3a 67 65 74 2d us: " (test:get-
87e0: 73 74 61 74 75 73 20 74 65 73 74 64 61 74 29 22 status testdat)"
87f0: 2c 20 6d 75 73 74 2d 72 65 72 75 6e 3a 20 22 20 , must-rerun: "
8800: 6d 75 73 74 2d 72 65 72 75 6e 29 0a 09 09 20 20 must-rerun)...
8810: 20 20 6d 75 73 74 2d 72 65 72 75 6e 29 29 0a 09 must-rerun))..
8820: 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e (debug:prin
8830: 74 2d 69 6e 66 6f 20 32 20 22 52 65 72 75 6e 20 t-info 2 "Rerun
8840: 66 6f 72 63 65 64 20 66 6f 72 20 74 65 73 74 20 forced for test
8850: 22 20 74 65 73 74 2d 6e 61 6d 65 20 22 2f 22 20 " test-name "/"
8860: 69 74 65 6d 2d 70 61 74 68 29 0a 09 20 20 20 20 item-path)..
8870: 20 28 73 65 74 21 20 72 75 6e 66 6c 61 67 20 23 (set! runflag #
8880: 74 29 29 0a 09 20 20 20 20 3b 3b 20 2d 6b 65 65 t)).. ;; -kee
8890: 70 67 6f 69 6e 67 2c 20 64 6f 20 6e 6f 74 20 72 pgoing, do not r
88a0: 65 72 75 6e 20 46 41 49 4c 0a 09 20 20 20 20 28 erun FAIL.. (
88b0: 28 61 6e 64 20 6b 65 65 70 67 6f 69 6e 67 0a 09 (and keepgoing..
88c0: 09 20 20 28 6d 65 6d 62 65 72 20 28 74 65 73 74 . (member (test
88d0: 3a 67 65 74 2d 73 74 61 74 75 73 20 74 65 73 74 :get-status test
88e0: 64 61 74 29 20 27 28 22 46 41 49 4c 22 29 29 29 dat) '("FAIL")))
88f0: 0a 09 20 20 20 20 20 28 73 65 74 21 20 72 75 6e .. (set! run
8900: 66 6c 61 67 20 23 66 29 29 0a 09 20 20 20 20 28 flag #f)).. (
8910: 28 61 6e 64 20 28 6e 6f 74 20 72 65 72 75 6e 29 (and (not rerun)
8920: 0a 09 09 20 20 28 6d 65 6d 62 65 72 20 28 74 65 ... (member (te
8930: 73 74 3a 67 65 74 2d 73 74 61 74 75 73 20 74 65 st:get-status te
8940: 73 74 64 61 74 29 20 27 28 22 46 41 49 4c 22 20 stdat) '("FAIL"
8950: 22 6e 2f 61 22 29 29 29 0a 09 20 20 20 20 20 28 "n/a"))).. (
8960: 73 65 74 21 20 72 75 6e 66 6c 61 67 20 23 74 29 set! runflag #t)
8970: 29 0a 09 20 20 20 20 28 65 6c 73 65 20 28 73 65 ).. (else (se
8980: 74 21 20 72 75 6e 66 6c 61 67 20 23 66 29 29 29 t! runflag #f)))
8990: 0a 09 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e .. (debug:prin
89a0: 74 20 36 20 22 52 55 4e 4e 49 4e 47 20 3d 3e 20 t 6 "RUNNING =>
89b0: 72 75 6e 66 6c 61 67 3a 20 22 20 72 75 6e 66 6c runflag: " runfl
89c0: 61 67 20 22 20 53 54 41 54 45 3a 20 22 20 28 74 ag " STATE: " (t
89d0: 65 73 74 3a 67 65 74 2d 73 74 61 74 65 20 74 65 est:get-state te
89e0: 73 74 64 61 74 29 20 22 20 53 54 41 54 55 53 3a stdat) " STATUS:
89f0: 20 22 20 28 74 65 73 74 3a 67 65 74 2d 73 74 61 " (test:get-sta
8a00: 74 75 73 20 74 65 73 74 64 61 74 29 29 0a 09 20 tus testdat))..
8a10: 20 20 28 69 66 20 28 6e 6f 74 20 72 75 6e 66 6c (if (not runfl
8a20: 61 67 29 0a 09 20 20 20 20 20 20 20 28 69 66 20 ag).. (if
8a30: 28 6e 6f 74 20 70 61 72 65 6e 74 2d 74 65 73 74 (not parent-test
8a40: 29 0a 09 09 20 20 20 28 64 65 62 75 67 3a 70 72 )... (debug:pr
8a50: 69 6e 74 20 31 20 22 4e 4f 54 45 3a 20 4e 6f 74 int 1 "NOTE: Not
8a60: 20 73 74 61 72 74 69 6e 67 20 74 65 73 74 20 22 starting test "
8a70: 20 6e 65 77 2d 74 65 73 74 2d 6e 61 6d 65 20 22 new-test-name "
8a80: 20 61 73 20 69 74 20 69 73 20 73 74 61 74 65 20 as it is state
8a90: 5c 22 22 20 28 74 65 73 74 3a 67 65 74 2d 73 74 \"" (test:get-st
8aa0: 61 74 65 20 74 65 73 74 64 61 74 29 20 0a 09 09 ate testdat) ...
8ab0: 09 09 22 5c 22 20 61 6e 64 20 73 74 61 74 75 73 .."\" and status
8ac0: 20 5c 22 22 20 28 74 65 73 74 3a 67 65 74 2d 73 \"" (test:get-s
8ad0: 74 61 74 75 73 20 74 65 73 74 64 61 74 29 20 22 tatus testdat) "
8ae0: 5c 22 2c 20 75 73 65 20 2d 72 65 72 75 6e 20 5c \", use -rerun \
8af0: 22 22 20 28 74 65 73 74 3a 67 65 74 2d 73 74 61 "" (test:get-sta
8b00: 74 75 73 20 74 65 73 74 64 61 74 29 0a 20 20 20 tus testdat).
8b10: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8b20: 20 20 20 20 20 20 20 20 20 20 20 20 20 22 5c 22 "\"
8b30: 20 6f 72 20 2d 66 6f 72 63 65 20 74 6f 20 6f 76 or -force to ov
8b40: 65 72 72 69 64 65 22 29 29 0a 09 20 20 20 20 20 erride"))..
8b50: 20 20 3b 3b 20 4e 4f 54 45 3a 20 4e 6f 20 6c 6f ;; NOTE: No lo
8b60: 6e 67 65 72 20 62 65 20 63 68 65 63 6b 69 6e 67 nger be checking
8b70: 20 70 72 65 72 65 71 75 69 73 69 74 65 73 20 68 prerequisites h
8b80: 65 72 65 21 20 57 69 6c 6c 20 6e 65 76 65 72 20 ere! Will never
8b90: 67 65 74 20 68 65 72 65 20 75 6e 6c 65 73 73 20 get here unless
8ba0: 70 72 65 72 65 71 73 20 61 72 65 0a 09 20 20 20 prereqs are..
8bb0: 20 20 20 20 3b 3b 20 20 20 20 20 20 20 61 6c 72 ;; alr
8bc0: 65 61 64 79 20 6d 65 74 2e 0a 09 20 20 20 20 20 eady met...
8bd0: 20 20 3b 3b 20 54 68 69 73 20 77 6f 75 6c 64 20 ;; This would
8be0: 62 65 20 61 20 67 72 65 61 74 20 70 6c 61 63 65 be a great place
8bf0: 20 74 6f 20 64 6f 20 74 68 65 20 70 72 6f 63 65 to do the proce
8c00: 73 73 2d 66 6f 72 6b 0a 09 20 20 20 20 20 20 20 ss-fork..
8c10: 28 69 66 20 28 6e 6f 74 20 28 6c 61 75 6e 63 68 (if (not (launch
8c20: 2d 74 65 73 74 20 23 66 20 72 75 6e 2d 69 64 20 -test #f run-id
8c30: 72 75 6e 6e 61 6d 65 20 74 65 73 74 2d 63 6f 6e runname test-con
8c40: 66 20 6b 65 79 76 61 6c 6c 73 74 20 74 65 73 74 f keyvallst test
8c50: 2d 6e 61 6d 65 20 74 65 73 74 2d 70 61 74 68 20 -name test-path
8c60: 69 74 65 6d 64 61 74 20 66 6c 61 67 73 29 29 0a itemdat flags)).
8c70: 09 09 20 20 20 28 62 65 67 69 6e 0a 09 09 20 20 .. (begin...
8c80: 20 20 20 28 70 72 69 6e 74 20 22 45 52 52 4f 52 (print "ERROR
8c90: 3a 20 46 61 69 6c 65 64 20 74 6f 20 6c 61 75 6e : Failed to laun
8ca0: 63 68 20 74 68 65 20 74 65 73 74 2e 20 45 78 69 ch the test. Exi
8cb0: 74 69 6e 67 20 61 73 20 73 6f 6f 6e 20 61 73 20 ting as soon as
8cc0: 70 6f 73 73 69 62 6c 65 22 29 0a 09 09 20 20 20 possible")...
8cd0: 20 20 28 73 65 74 21 20 2a 67 6c 6f 62 61 6c 65 (set! *globale
8ce0: 78 69 74 73 74 61 74 75 73 2a 20 31 29 20 3b 3b xitstatus* 1) ;;
8cf0: 20 0a 09 09 20 20 20 20 20 28 70 72 6f 63 65 73 ... (proces
8d00: 73 2d 73 69 67 6e 61 6c 20 28 63 75 72 72 65 6e s-signal (curren
8d10: 74 2d 70 72 6f 63 65 73 73 2d 69 64 29 20 73 69 t-process-id) si
8d20: 67 6e 61 6c 2f 6b 69 6c 6c 29 29 29 29 29 29 0a gnal/kill)))))).
8d30: 09 28 28 4b 49 4c 4c 45 44 29 20 0a 09 20 28 64 .((KILLED) .. (d
8d40: 65 62 75 67 3a 70 72 69 6e 74 20 31 20 22 4e 4f ebug:print 1 "NO
8d50: 54 45 3a 20 22 20 6e 65 77 2d 74 65 73 74 2d 6e TE: " new-test-n
8d60: 61 6d 65 20 22 20 69 73 20 61 6c 72 65 61 64 79 ame " is already
8d70: 20 72 75 6e 6e 69 6e 67 20 6f 72 20 77 61 73 20 running or was
8d80: 65 78 70 6c 69 63 74 6c 79 20 6b 69 6c 6c 65 64 explictly killed
8d90: 2c 20 75 73 65 20 2d 66 6f 72 63 65 20 74 6f 20 , use -force to
8da0: 6c 61 75 6e 63 68 20 69 74 2e 22 29 29 0a 09 28 launch it."))..(
8db0: 28 4c 41 55 4e 43 48 45 44 20 52 45 4d 4f 54 45 (LAUNCHED REMOTE
8dc0: 48 4f 53 54 53 54 41 52 54 20 52 55 4e 4e 49 4e HOSTSTART RUNNIN
8dd0: 47 29 20 20 0a 09 20 28 69 66 20 28 3e 20 28 2d G) .. (if (> (-
8de0: 20 28 63 75 72 72 65 6e 74 2d 73 65 63 6f 6e 64 (current-second
8df0: 73 29 28 2b 20 28 64 62 3a 74 65 73 74 2d 67 65 s)(+ (db:test-ge
8e00: 74 2d 65 76 65 6e 74 5f 74 69 6d 65 20 74 65 73 t-event_time tes
8e10: 74 64 61 74 29 0a 09 09 09 09 20 20 20 20 20 20 tdat).....
8e20: 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 72 75 (db:test-get-ru
8e30: 6e 5f 64 75 72 61 74 69 6f 6e 20 74 65 73 74 64 n_duration testd
8e40: 61 74 29 29 29 0a 09 09 36 30 30 29 20 3b 3b 20 at)))...600) ;;
8e50: 69 2e 65 2e 20 6e 6f 20 75 70 64 61 74 65 20 66 i.e. no update f
8e60: 6f 72 20 6d 6f 72 65 20 74 68 61 6e 20 36 30 30 or more than 600
8e70: 20 73 65 63 6f 6e 64 73 0a 09 20 20 20 20 20 28 seconds.. (
8e80: 62 65 67 69 6e 0a 09 20 20 20 20 20 20 20 28 64 begin.. (d
8e90: 65 62 75 67 3a 70 72 69 6e 74 20 30 20 22 57 41 ebug:print 0 "WA
8ea0: 52 4e 49 4e 47 3a 20 54 65 73 74 20 22 20 74 65 RNING: Test " te
8eb0: 73 74 2d 6e 61 6d 65 20 22 20 61 70 70 65 61 72 st-name " appear
8ec0: 73 20 74 6f 20 62 65 20 64 65 61 64 2e 20 46 6f s to be dead. Fo
8ed0: 72 63 69 6e 67 20 69 74 20 74 6f 20 73 74 61 74 rcing it to stat
8ee0: 65 20 49 4e 43 4f 4d 50 4c 45 54 45 20 61 6e 64 e INCOMPLETE and
8ef0: 20 73 74 61 74 75 73 20 53 54 55 43 4b 2f 44 45 status STUCK/DE
8f00: 41 44 22 29 0a 09 20 20 20 20 20 20 20 28 74 65 AD").. (te
8f10: 73 74 73 3a 74 65 73 74 2d 73 65 74 2d 73 74 61 sts:test-set-sta
8f20: 74 75 73 21 20 74 65 73 74 2d 69 64 20 22 49 4e tus! test-id "IN
8f30: 43 4f 4d 50 4c 45 54 45 22 20 22 53 54 55 43 4b COMPLETE" "STUCK
8f40: 2f 44 45 41 44 22 20 22 54 65 73 74 20 69 73 20 /DEAD" "Test is
8f50: 73 74 75 63 6b 20 6f 72 20 64 65 61 64 22 20 23 stuck or dead" #
8f60: 66 29 29 0a 09 20 20 20 20 20 28 64 65 62 75 67 f)).. (debug
8f70: 3a 70 72 69 6e 74 20 32 20 22 4e 4f 54 45 3a 20 :print 2 "NOTE:
8f80: 22 20 74 65 73 74 2d 6e 61 6d 65 20 22 20 69 73 " test-name " is
8f90: 20 61 6c 72 65 61 64 79 20 72 75 6e 6e 69 6e 67 already running
8fa0: 22 29 29 29 0a 09 28 65 6c 73 65 20 20 20 20 20 ")))..(else
8fb0: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 (debug:print 0
8fc0: 20 22 45 52 52 4f 52 3a 20 46 61 69 6c 65 64 20 "ERROR: Failed
8fd0: 74 6f 20 6c 61 75 6e 63 68 20 74 65 73 74 20 22 to launch test "
8fe0: 20 6e 65 77 2d 74 65 73 74 2d 6e 61 6d 65 20 22 new-test-name "
8ff0: 2e 20 55 6e 72 65 63 6f 67 6e 69 73 65 64 20 73 . Unrecognised s
9000: 74 61 74 65 20 22 20 28 74 65 73 74 3a 67 65 74 tate " (test:get
9010: 2d 73 74 61 74 65 20 74 65 73 74 64 61 74 29 29 -state testdat))
9020: 29 29 29 29 29 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d )))))..;;=======
9030: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
9040: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
9050: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
9060: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a ===============.
9070: 3b 3b 20 45 4e 44 20 4f 46 20 4e 45 57 20 53 54 ;; END OF NEW ST
9080: 55 46 46 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d UFF.;;==========
9090: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
90a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
90b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
90c0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 28 64 ============..(d
90d0: 65 66 69 6e 65 20 28 67 65 74 2d 64 69 72 2d 75 efine (get-dir-u
90e0: 70 2d 6e 20 64 69 72 20 2e 20 70 61 72 61 6d 73 p-n dir . params
90f0: 29 20 0a 20 20 28 6c 65 74 20 28 28 64 70 61 72 ) . (let ((dpar
9100: 74 73 20 20 28 73 74 72 69 6e 67 2d 73 70 6c 69 ts (string-spli
9110: 74 20 64 69 72 20 22 2f 22 29 29 0a 09 28 63 6f t dir "/"))..(co
9120: 75 6e 74 20 20 20 28 69 66 20 28 6e 75 6c 6c 3f unt (if (null?
9130: 20 70 61 72 61 6d 73 29 20 31 20 28 63 61 72 20 params) 1 (car
9140: 70 61 72 61 6d 73 29 29 29 29 0a 20 20 20 20 28 params)))). (
9150: 63 6f 6e 63 20 22 2f 22 20 28 73 74 72 69 6e 67 conc "/" (string
9160: 2d 69 6e 74 65 72 73 70 65 72 73 65 20 0a 09 20 -intersperse ..
9170: 20 20 20 20 20 20 28 74 61 6b 65 20 64 70 61 72 (take dpar
9180: 74 73 20 28 2d 20 28 6c 65 6e 67 74 68 20 64 70 ts (- (length dp
9190: 61 72 74 73 29 20 63 6f 75 6e 74 29 29 0a 09 20 arts) count))..
91a0: 20 20 20 20 20 20 22 2f 22 29 29 29 29 0a 3b 3b "/")))).;;
91b0: 20 52 65 6d 6f 76 65 20 72 75 6e 73 0a 3b 3b 20 Remove runs.;;
91c0: 66 69 65 6c 64 73 20 61 72 65 20 70 61 73 73 69 fields are passi
91d0: 6e 67 20 69 6e 20 74 68 72 6f 75 67 68 20 0a 3b ng in through .;
91e0: 3b 20 61 63 74 69 6f 6e 3a 0a 3b 3b 20 20 20 20 ; action:.;;
91f0: 27 72 65 6d 6f 76 65 2d 72 75 6e 73 0a 3b 3b 20 'remove-runs.;;
9200: 20 20 20 27 73 65 74 2d 73 74 61 74 65 2d 73 74 'set-state-st
9210: 61 74 75 73 0a 3b 3b 0a 3b 3b 20 4e 42 2f 2f 20 atus.;;.;; NB//
9220: 73 68 6f 75 6c 64 20 70 61 73 73 20 69 6e 20 6b should pass in k
9230: 65 79 73 3f 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 eys?.;;.(define
9240: 28 72 75 6e 73 3a 6f 70 65 72 61 74 65 2d 6f 6e (runs:operate-on
9250: 20 61 63 74 69 6f 6e 20 72 75 6e 6e 61 6d 65 70 action runnamep
9260: 61 74 74 20 74 65 73 74 70 61 74 74 20 23 21 6b att testpatt #!k
9270: 65 79 20 28 73 74 61 74 65 20 23 66 29 28 73 74 ey (state #f)(st
9280: 61 74 75 73 20 23 66 29 28 6e 65 77 2d 73 74 61 atus #f)(new-sta
9290: 74 65 2d 73 74 61 74 75 73 20 23 66 29 29 0a 20 te-status #f)).
92a0: 20 28 63 6f 6d 6d 6f 6e 3a 63 6c 65 61 72 2d 63 (common:clear-c
92b0: 61 63 68 65 73 29 20 3b 3b 20 63 6c 65 61 72 20 aches) ;; clear
92c0: 61 6c 6c 20 63 61 63 68 65 73 0a 20 20 28 6c 65 all caches. (le
92d0: 74 2a 20 28 28 64 62 20 20 20 20 20 20 20 20 20 t* ((db
92e0: 20 20 23 66 29 0a 09 20 28 6b 65 79 73 20 20 20 #f).. (keys
92f0: 20 20 20 20 20 20 28 6f 70 65 6e 2d 72 75 6e 2d (open-run-
9300: 63 6c 6f 73 65 20 64 62 3a 67 65 74 2d 6b 65 79 close db:get-key
9310: 73 20 64 62 29 29 0a 09 20 28 72 75 6e 64 61 74 s db)).. (rundat
9320: 20 20 20 20 20 20 20 28 6f 70 65 6e 2d 72 75 6e (open-run
9330: 2d 63 6c 6f 73 65 20 72 75 6e 73 3a 67 65 74 2d -close runs:get-
9340: 72 75 6e 73 2d 62 79 2d 70 61 74 74 20 64 62 20 runs-by-patt db
9350: 6b 65 79 73 20 72 75 6e 6e 61 6d 65 70 61 74 74 keys runnamepatt
9360: 29 29 0a 09 20 28 68 65 61 64 65 72 20 20 20 20 )).. (header
9370: 20 20 20 28 76 65 63 74 6f 72 2d 72 65 66 20 72 (vector-ref r
9380: 75 6e 64 61 74 20 30 29 29 0a 09 20 28 72 75 6e undat 0)).. (run
9390: 73 20 20 20 20 20 20 20 20 20 28 76 65 63 74 6f s (vecto
93a0: 72 2d 72 65 66 20 72 75 6e 64 61 74 20 31 29 29 r-ref rundat 1))
93b0: 0a 09 20 28 73 74 61 74 65 73 20 20 20 20 20 20 .. (states
93c0: 20 28 69 66 20 73 74 61 74 65 20 20 28 73 74 72 (if state (str
93d0: 69 6e 67 2d 73 70 6c 69 74 20 73 74 61 74 65 20 ing-split state
93e0: 20 22 2c 22 29 20 27 28 29 29 29 0a 09 20 28 73 ",") '())).. (s
93f0: 74 61 74 75 73 65 73 20 20 20 20 20 28 69 66 20 tatuses (if
9400: 73 74 61 74 75 73 20 28 73 74 72 69 6e 67 2d 73 status (string-s
9410: 70 6c 69 74 20 73 74 61 74 75 73 20 22 2c 22 29 plit status ",")
9420: 20 27 28 29 29 29 0a 09 20 28 73 74 61 74 65 2d '())).. (state-
9430: 73 74 61 74 75 73 20 28 69 66 20 28 73 74 72 69 status (if (stri
9440: 6e 67 3f 20 6e 65 77 2d 73 74 61 74 65 2d 73 74 ng? new-state-st
9450: 61 74 75 73 29 20 28 73 74 72 69 6e 67 2d 73 70 atus) (string-sp
9460: 6c 69 74 20 6e 65 77 2d 73 74 61 74 65 2d 73 74 lit new-state-st
9470: 61 74 75 73 20 22 2c 22 29 20 27 28 23 66 20 23 atus ",") '(#f #
9480: 66 29 29 29 29 0a 20 20 20 20 28 64 65 62 75 67 f)))). (debug
9490: 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 34 20 22 72 :print-info 4 "r
94a0: 75 6e 73 3a 6f 70 65 72 61 74 65 2d 6f 6e 20 3d uns:operate-on =
94b0: 3e 20 48 65 61 64 65 72 3a 20 22 20 68 65 61 64 > Header: " head
94c0: 65 72 20 22 20 61 63 74 69 6f 6e 3a 20 22 20 61 er " action: " a
94d0: 63 74 69 6f 6e 20 22 20 6e 65 77 2d 73 74 61 74 ction " new-stat
94e0: 65 2d 73 74 61 74 75 73 3a 20 22 20 6e 65 77 2d e-status: " new-
94f0: 73 74 61 74 65 2d 73 74 61 74 75 73 29 0a 20 20 state-status).
9500: 20 20 28 69 66 20 28 3e 20 32 20 28 6c 65 6e 67 (if (> 2 (leng
9510: 74 68 20 73 74 61 74 65 2d 73 74 61 74 75 73 29 th state-status)
9520: 29 0a 09 28 62 65 67 69 6e 0a 09 20 20 28 64 65 )..(begin.. (de
9530: 62 75 67 3a 70 72 69 6e 74 20 30 20 22 45 52 52 bug:print 0 "ERR
9540: 4f 52 3a 20 74 68 65 20 70 61 72 61 6d 65 74 65 OR: the paramete
9550: 72 20 74 6f 20 2d 73 65 74 2d 73 74 61 74 65 2d r to -set-state-
9560: 73 74 61 74 75 73 20 69 73 20 61 20 63 6f 6d 6d status is a comm
9570: 61 20 64 65 6c 69 6d 69 74 65 64 20 73 74 72 69 a delimited stri
9580: 6e 67 2e 20 45 2e 67 2e 20 43 4f 4d 50 4c 45 54 ng. E.g. COMPLET
9590: 45 44 2c 46 41 49 4c 22 29 0a 09 20 20 28 65 78 ED,FAIL").. (ex
95a0: 69 74 29 29 29 0a 20 20 20 20 28 66 6f 72 2d 65 it))). (for-e
95b0: 61 63 68 0a 20 20 20 20 20 28 6c 61 6d 62 64 61 ach. (lambda
95c0: 20 28 72 75 6e 29 0a 20 20 20 20 20 20 20 28 6c (run). (l
95d0: 65 74 20 28 28 72 75 6e 6b 65 79 20 28 73 74 72 et ((runkey (str
95e0: 69 6e 67 2d 69 6e 74 65 72 73 70 65 72 73 65 20 ing-intersperse
95f0: 28 6d 61 70 20 28 6c 61 6d 62 64 61 20 28 6b 29 (map (lambda (k)
9600: 0a 09 09 09 09 09 09 28 64 62 3a 67 65 74 2d 76 .......(db:get-v
9610: 61 6c 75 65 2d 62 79 2d 68 65 61 64 65 72 20 72 alue-by-header r
9620: 75 6e 20 68 65 61 64 65 72 20 28 76 65 63 74 6f un header (vecto
9630: 72 2d 72 65 66 20 6b 20 30 29 29 29 20 6b 65 79 r-ref k 0))) key
9640: 73 29 20 22 2f 22 29 29 0a 09 20 20 20 20 20 28 s) "/")).. (
9650: 64 69 72 73 2d 74 6f 2d 72 65 6d 6f 76 65 20 28 dirs-to-remove (
9660: 6d 61 6b 65 2d 68 61 73 68 2d 74 61 62 6c 65 29 make-hash-table)
9670: 29 29 0a 09 20 28 6c 65 74 2a 20 28 28 72 75 6e )).. (let* ((run
9680: 2d 69 64 20 20 20 20 28 64 62 3a 67 65 74 2d 76 -id (db:get-v
9690: 61 6c 75 65 2d 62 79 2d 68 65 61 64 65 72 20 72 alue-by-header r
96a0: 75 6e 20 68 65 61 64 65 72 20 22 69 64 22 29 29 un header "id"))
96b0: 0a 09 09 28 72 75 6e 2d 73 74 61 74 65 20 28 64 ...(run-state (d
96c0: 62 3a 67 65 74 2d 76 61 6c 75 65 2d 62 79 2d 68 b:get-value-by-h
96d0: 65 61 64 65 72 20 72 75 6e 20 68 65 61 64 65 72 eader run header
96e0: 20 22 73 74 61 74 65 22 29 29 0a 09 09 28 74 65 "state"))...(te
96f0: 73 74 73 20 20 20 20 20 28 69 66 20 28 6e 6f 74 sts (if (not
9700: 20 28 65 71 75 61 6c 3f 20 72 75 6e 2d 73 74 61 (equal? run-sta
9710: 74 65 20 22 6c 6f 63 6b 65 64 22 29 29 0a 09 09 te "locked"))...
9720: 09 20 20 20 20 20 20 20 28 6f 70 65 6e 2d 72 75 . (open-ru
9730: 6e 2d 63 6c 6f 73 65 20 64 62 3a 67 65 74 2d 74 n-close db:get-t
9740: 65 73 74 73 2d 66 6f 72 2d 72 75 6e 20 64 62 20 ests-for-run db
9750: 72 75 6e 2d 69 64 0a 09 09 09 09 09 09 20 20 20 run-id.......
9760: 20 20 20 74 65 73 74 70 61 74 74 20 73 74 61 74 testpatt stat
9770: 65 73 20 73 74 61 74 75 73 65 73 0a 09 09 09 09 es statuses.....
9780: 09 09 20 20 20 20 20 20 6e 6f 74 2d 69 6e 3a 20 .. not-in:
9790: 20 23 66 0a 09 09 09 09 09 09 20 20 20 20 20 20 #f.......
97a0: 73 6f 72 74 2d 62 79 3a 20 28 63 61 73 65 20 61 sort-by: (case a
97b0: 63 74 69 6f 6e 0a 09 09 09 09 09 09 09 09 20 28 ction......... (
97c0: 28 72 65 6d 6f 76 65 2d 72 75 6e 73 29 20 27 72 (remove-runs) 'r
97d0: 75 6e 64 69 72 29 0a 09 09 09 09 09 09 09 09 20 undir).........
97e0: 28 65 6c 73 65 20 20 20 20 20 20 20 20 20 20 27 (else '
97f0: 65 76 65 6e 74 5f 74 69 6d 65 29 29 29 0a 09 09 event_time)))...
9800: 09 20 20 20 20 20 20 20 27 28 29 29 29 0a 09 09 . '()))...
9810: 28 6c 61 73 74 74 70 61 74 68 20 22 2f 64 6f 65 (lasttpath "/doe
9820: 73 2f 6e 6f 74 2f 65 78 69 73 74 2f 49 2f 68 6f s/not/exist/I/ho
9830: 70 65 22 29 29 0a 09 20 20 20 28 64 65 62 75 67 pe")).. (debug
9840: 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 34 20 22 72 :print-info 4 "r
9850: 75 6e 73 3a 6f 70 65 72 61 74 65 2d 6f 6e 20 72 uns:operate-on r
9860: 75 6e 3d 22 20 72 75 6e 20 22 2c 20 68 65 61 64 un=" run ", head
9870: 65 72 3d 22 20 68 65 61 64 65 72 29 0a 09 20 20 er=" header)..
9880: 20 28 69 66 20 28 6e 6f 74 20 28 6e 75 6c 6c 3f (if (not (null?
9890: 20 74 65 73 74 73 29 29 0a 09 20 20 20 20 20 20 tests))..
98a0: 20 28 62 65 67 69 6e 0a 09 09 20 28 63 61 73 65 (begin... (case
98b0: 20 61 63 74 69 6f 6e 0a 09 09 20 20 20 28 28 72 action... ((r
98c0: 65 6d 6f 76 65 2d 72 75 6e 73 29 0a 09 09 20 20 emove-runs)...
98d0: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 31 (debug:print 1
98e0: 20 22 52 65 6d 6f 76 69 6e 67 20 74 65 73 74 73 "Removing tests
98f0: 20 66 6f 72 20 72 75 6e 3a 20 22 20 72 75 6e 6b for run: " runk
9900: 65 79 20 22 20 22 20 28 64 62 3a 67 65 74 2d 76 ey " " (db:get-v
9910: 61 6c 75 65 2d 62 79 2d 68 65 61 64 65 72 20 72 alue-by-header r
9920: 75 6e 20 68 65 61 64 65 72 20 22 72 75 6e 6e 61 un header "runna
9930: 6d 65 22 29 29 29 0a 09 09 20 20 20 28 28 73 65 me")))... ((se
9940: 74 2d 73 74 61 74 65 2d 73 74 61 74 75 73 29 0a t-state-status).
9950: 09 09 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 .. (debug:pri
9960: 6e 74 20 31 20 22 4d 6f 64 69 66 79 69 6e 67 20 nt 1 "Modifying
9970: 73 74 61 74 65 20 61 6e 64 20 73 74 61 75 73 20 state and staus
9980: 66 6f 72 20 74 65 73 74 73 20 66 6f 72 20 72 75 for tests for ru
9990: 6e 3a 20 22 20 72 75 6e 6b 65 79 20 22 20 22 20 n: " runkey " "
99a0: 28 64 62 3a 67 65 74 2d 76 61 6c 75 65 2d 62 79 (db:get-value-by
99b0: 2d 68 65 61 64 65 72 20 72 75 6e 20 68 65 61 64 -header run head
99c0: 65 72 20 22 72 75 6e 6e 61 6d 65 22 29 29 29 0a er "runname"))).
99d0: 09 09 20 20 20 28 28 70 72 69 6e 74 2d 72 75 6e .. ((print-run
99e0: 29 0a 09 09 20 20 20 20 28 64 65 62 75 67 3a 70 )... (debug:p
99f0: 72 69 6e 74 20 31 20 22 50 72 69 6e 74 69 6e 67 rint 1 "Printing
9a00: 20 69 6e 66 6f 20 66 6f 72 20 72 75 6e 20 22 20 info for run "
9a10: 72 75 6e 6b 65 79 20 22 2c 20 72 75 6e 3d 22 20 runkey ", run="
9a20: 72 75 6e 20 22 2c 20 74 65 73 74 73 3d 22 20 74 run ", tests=" t
9a30: 65 73 74 73 20 22 2c 20 68 65 61 64 65 72 3d 22 ests ", header="
9a40: 20 68 65 61 64 65 72 29 0a 09 09 20 20 20 20 61 header)... a
9a50: 63 74 69 6f 6e 29 0a 09 09 20 20 20 28 65 6c 73 ction)... (els
9a60: 65 0a 09 09 20 20 20 20 28 64 65 62 75 67 3a 70 e... (debug:p
9a70: 72 69 6e 74 2d 69 6e 66 6f 20 30 20 22 61 63 74 rint-info 0 "act
9a80: 69 6f 6e 20 6e 6f 74 20 72 65 63 6f 67 6e 69 73 ion not recognis
9a90: 65 64 20 22 20 61 63 74 69 6f 6e 29 29 29 0a 09 ed " action)))..
9aa0: 09 20 28 66 6f 72 2d 65 61 63 68 0a 09 09 20 20 . (for-each...
9ab0: 28 6c 61 6d 62 64 61 20 28 74 65 73 74 29 0a 09 (lambda (test)..
9ac0: 09 20 20 20 20 28 6c 65 74 2a 20 28 28 69 74 65 . (let* ((ite
9ad0: 6d 2d 70 61 74 68 20 28 64 62 3a 74 65 73 74 2d m-path (db:test-
9ae0: 67 65 74 2d 69 74 65 6d 2d 70 61 74 68 20 74 65 get-item-path te
9af0: 73 74 29 29 0a 09 09 09 20 20 20 28 74 65 73 74 st)).... (test
9b00: 2d 6e 61 6d 65 20 28 64 62 3a 74 65 73 74 2d 67 -name (db:test-g
9b10: 65 74 2d 74 65 73 74 6e 61 6d 65 20 74 65 73 74 et-testname test
9b20: 29 29 0a 09 09 09 20 20 20 28 72 75 6e 2d 64 69 )).... (run-di
9b30: 72 20 20 20 28 64 62 3a 74 65 73 74 2d 67 65 74 r (db:test-get
9b40: 2d 72 75 6e 64 69 72 20 74 65 73 74 29 29 20 20 -rundir test))
9b50: 20 20 3b 3b 20 72 75 6e 20 64 69 72 20 69 73 20 ;; run dir is
9b60: 66 72 6f 6d 20 74 68 65 20 6c 69 6e 6b 20 74 72 from the link tr
9b70: 65 65 0a 09 09 09 20 20 20 28 72 65 61 6c 2d 64 ee.... (real-d
9b80: 69 72 20 20 28 69 66 20 28 66 69 6c 65 2d 65 78 ir (if (file-ex
9b90: 69 73 74 73 3f 20 72 75 6e 2d 64 69 72 29 0a 09 ists? run-dir)..
9ba0: 09 09 09 09 20 20 28 72 65 73 6f 6c 76 65 2d 70 .... (resolve-p
9bb0: 61 74 68 6e 61 6d 65 20 72 75 6e 2d 64 69 72 29 athname run-dir)
9bc0: 0a 09 09 09 09 09 20 20 23 66 29 29 0a 09 09 09 ...... #f))....
9bd0: 20 20 20 28 74 65 73 74 2d 69 64 20 20 20 28 64 (test-id (d
9be0: 62 3a 74 65 73 74 2d 67 65 74 2d 69 64 20 74 65 b:test-get-id te
9bf0: 73 74 29 29 29 0a 09 09 20 20 20 20 20 20 3b 3b st)))... ;;
9c00: 20 20 20 28 74 64 62 20 20 20 20 20 20 20 28 64 (tdb (d
9c10: 62 3a 6f 70 65 6e 2d 74 65 73 74 2d 64 62 20 72 b:open-test-db r
9c20: 75 6e 2d 64 69 72 29 29 29 0a 09 09 20 20 20 20 un-dir)))...
9c30: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 (debug:print-i
9c40: 6e 66 6f 20 34 20 22 74 65 73 74 3d 22 20 74 65 nfo 4 "test=" te
9c50: 73 74 29 20 3b 3b 20 20 20 22 20 28 64 62 3a 74 st) ;; " (db:t
9c60: 65 73 74 2d 67 65 74 2d 74 65 73 74 6e 61 6d 65 est-get-testname
9c70: 20 74 65 73 74 29 20 22 20 69 64 3a 20 22 20 28 test) " id: " (
9c80: 64 62 3a 74 65 73 74 2d 67 65 74 2d 69 64 20 74 db:test-get-id t
9c90: 65 73 74 29 20 22 20 22 20 69 74 65 6d 2d 70 61 est) " " item-pa
9ca0: 74 68 20 22 20 61 63 74 69 6f 6e 3a 20 22 20 61 th " action: " a
9cb0: 63 74 69 6f 6e 29 0a 09 09 20 20 20 20 20 20 28 ction)... (
9cc0: 63 61 73 65 20 61 63 74 69 6f 6e 0a 09 09 09 28 case action....(
9cd0: 28 72 65 6d 6f 76 65 2d 72 75 6e 73 29 20 3b 3b (remove-runs) ;;
9ce0: 20 74 68 65 20 74 64 62 20 69 73 20 66 6f 72 20 the tdb is for
9cf0: 66 75 74 75 72 65 20 70 6f 73 73 69 62 6c 65 2e future possible.
9d00: 20 0a 09 09 09 20 28 6f 70 65 6e 2d 72 75 6e 2d .... (open-run-
9d10: 63 6c 6f 73 65 20 64 62 3a 64 65 6c 65 74 65 2d close db:delete-
9d20: 74 65 73 74 2d 72 65 63 6f 72 64 73 20 64 62 20 test-records db
9d30: 23 66 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d #f (db:test-get-
9d40: 69 64 20 74 65 73 74 29 29 0a 09 09 09 20 28 64 id test)).... (d
9d50: 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 ebug:print-info
9d60: 31 20 22 41 74 74 65 6d 70 74 69 6e 67 20 74 6f 1 "Attempting to
9d70: 20 72 65 6d 6f 76 65 20 22 20 28 69 66 20 72 65 remove " (if re
9d80: 61 6c 2d 64 69 72 20 28 63 6f 6e 63 20 22 20 64 al-dir (conc " d
9d90: 69 72 20 22 20 72 65 61 6c 2d 64 69 72 20 22 20 ir " real-dir "
9da0: 61 6e 64 20 22 29 20 22 22 29 20 22 20 6c 69 6e and ") "") " lin
9db0: 6b 20 22 20 72 75 6e 2d 64 69 72 29 0a 09 09 09 k " run-dir)....
9dc0: 20 28 69 66 20 28 61 6e 64 20 72 65 61 6c 2d 64 (if (and real-d
9dd0: 69 72 20 0a 09 09 09 09 20 20 28 3e 20 28 73 74 ir ..... (> (st
9de0: 72 69 6e 67 2d 6c 65 6e 67 74 68 20 72 65 61 6c ring-length real
9df0: 2d 64 69 72 29 20 35 29 0a 09 09 09 09 20 20 28 -dir) 5)..... (
9e00: 66 69 6c 65 2d 65 78 69 73 74 73 3f 20 72 65 61 file-exists? rea
9e10: 6c 2d 64 69 72 29 29 20 3b 3b 20 62 61 64 20 68 l-dir)) ;; bad h
9e20: 65 75 72 69 73 74 69 63 20 62 75 74 20 73 68 6f euristic but sho
9e30: 75 6c 64 20 70 72 65 76 65 6e 74 20 2f 74 6d 70 uld prevent /tmp
9e40: 20 2f 68 6f 6d 65 20 65 74 63 2e 0a 09 09 09 20 /home etc.....
9e50: 20 20 20 20 28 62 65 67 69 6e 20 3b 3b 20 6c 65 (begin ;; le
9e60: 74 2a 20 28 28 72 65 61 6c 70 61 74 68 20 28 72 t* ((realpath (r
9e70: 65 73 6f 6c 76 65 2d 70 61 74 68 6e 61 6d 65 20 esolve-pathname
9e80: 72 75 6e 2d 64 69 72 29 29 29 0a 09 09 09 20 20 run-dir)))....
9e90: 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e (debug:prin
9ea0: 74 2d 69 6e 66 6f 20 31 20 22 52 65 63 75 72 73 t-info 1 "Recurs
9eb0: 69 76 65 6c 79 20 72 65 6d 6f 76 69 6e 67 20 22 ively removing "
9ec0: 20 72 65 61 6c 2d 64 69 72 29 0a 09 09 09 20 20 real-dir)....
9ed0: 20 20 20 20 20 28 69 66 20 28 66 69 6c 65 2d 65 (if (file-e
9ee0: 78 69 73 74 73 3f 20 72 65 61 6c 2d 64 69 72 29 xists? real-dir)
9ef0: 0a 09 09 09 09 20 20 20 28 69 66 20 28 3e 20 28 ..... (if (> (
9f00: 73 79 73 74 65 6d 20 28 63 6f 6e 63 20 22 72 6d system (conc "rm
9f10: 20 2d 72 66 20 22 20 72 65 61 6c 2d 64 69 72 29 -rf " real-dir)
9f20: 29 20 30 29 0a 09 09 09 09 20 20 20 20 20 20 20 ) 0).....
9f30: 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 22 (debug:print 0 "
9f40: 45 52 52 4f 52 3a 20 54 68 65 72 65 20 77 61 73 ERROR: There was
9f50: 20 61 20 70 72 6f 62 6c 65 6d 20 72 65 6d 6f 76 a problem remov
9f60: 69 6e 67 20 22 20 72 65 61 6c 2d 64 69 72 20 22 ing " real-dir "
9f70: 20 77 69 74 68 20 72 6d 20 2d 66 22 29 29 0a 09 with rm -f"))..
9f80: 09 09 09 20 20 20 28 64 65 62 75 67 3a 70 72 69 ... (debug:pri
9f90: 6e 74 20 30 20 22 57 41 52 4e 49 4e 47 3a 20 74 nt 0 "WARNING: t
9fa0: 65 73 74 20 64 69 72 20 22 20 72 65 61 6c 2d 64 est dir " real-d
9fb0: 69 72 20 22 20 61 70 70 65 61 72 73 20 74 6f 20 ir " appears to
9fc0: 6e 6f 74 20 65 78 69 73 74 20 6f 72 20 69 73 20 not exist or is
9fd0: 6e 6f 74 20 72 65 61 64 61 62 6c 65 22 29 29 29 not readable")))
9fe0: 0a 09 09 09 20 20 20 20 20 28 69 66 20 72 65 61 .... (if rea
9ff0: 6c 2d 64 69 72 20 0a 09 09 09 09 20 28 64 65 62 l-dir ..... (deb
a000: 75 67 3a 70 72 69 6e 74 20 30 20 22 57 41 52 4e ug:print 0 "WARN
a010: 49 4e 47 3a 20 64 69 72 65 63 74 6f 72 79 20 22 ING: directory "
a020: 20 72 65 61 6c 2d 64 69 72 20 22 20 64 6f 65 73 real-dir " does
a030: 20 6e 6f 74 20 65 78 69 73 74 22 29 0a 09 09 09 not exist")....
a040: 09 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 . (debug:print 0
a050: 20 22 57 41 52 4e 49 4e 47 3a 20 6e 6f 20 72 65 "WARNING: no re
a060: 61 6c 20 64 69 72 65 63 74 6f 72 79 20 63 6f 72 al directory cor
a070: 72 6f 73 70 6f 6e 64 69 6e 67 20 74 6f 20 6c 69 rosponding to li
a080: 6e 6b 20 22 20 72 75 6e 2d 64 69 72 20 22 2c 20 nk " run-dir ",
a090: 6e 6f 74 68 69 6e 67 20 64 6f 6e 65 22 29 29 29 nothing done")))
a0a0: 0a 09 09 09 20 28 69 66 20 28 73 79 6d 62 6f 6c .... (if (symbol
a0b0: 69 63 2d 6c 69 6e 6b 3f 20 72 75 6e 2d 64 69 72 ic-link? run-dir
a0c0: 29 0a 09 09 09 20 20 20 20 20 28 62 65 67 69 6e ).... (begin
a0d0: 0a 09 09 09 20 20 20 20 20 20 20 28 64 65 62 75 .... (debu
a0e0: 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 31 20 22 g:print-info 1 "
a0f0: 52 65 6d 6f 76 69 6e 67 20 73 79 6d 6c 69 6e 6b Removing symlink
a100: 20 22 20 72 75 6e 2d 64 69 72 29 0a 09 09 09 20 " run-dir)....
a110: 20 20 20 20 20 20 28 68 61 6e 64 6c 65 2d 65 78 (handle-ex
a120: 63 65 70 74 69 6f 6e 73 0a 09 09 09 09 65 78 6e ceptions.....exn
a130: 0a 09 09 09 09 28 64 65 62 75 67 3a 70 72 69 6e .....(debug:prin
a140: 74 20 30 20 22 45 52 52 4f 52 3a 20 20 46 61 69 t 0 "ERROR: Fai
a150: 6c 65 64 20 74 6f 20 72 65 6d 6f 76 65 20 73 79 led to remove sy
a160: 6d 6c 69 6e 6b 20 22 20 72 75 6e 2d 64 69 72 20 mlink " run-dir
a170: 28 28 63 6f 6e 64 69 74 69 6f 6e 2d 70 72 6f 70 ((condition-prop
a180: 65 72 74 79 2d 61 63 63 65 73 73 6f 72 20 27 65 erty-accessor 'e
a190: 78 6e 20 27 6d 65 73 73 61 67 65 29 20 65 78 6e xn 'message) exn
a1a0: 29 20 22 2c 20 61 74 74 65 6d 70 74 69 6e 67 20 ) ", attempting
a1b0: 74 6f 20 63 6f 6e 74 69 6e 75 65 22 29 0a 09 09 to continue")...
a1c0: 09 09 28 64 65 6c 65 74 65 2d 66 69 6c 65 20 72 ..(delete-file r
a1d0: 75 6e 2d 64 69 72 29 29 29 0a 09 09 09 20 20 20 un-dir)))....
a1e0: 20 20 28 69 66 20 28 64 69 72 65 63 74 6f 72 79 (if (directory
a1f0: 3f 20 72 75 6e 2d 64 69 72 29 0a 09 09 09 09 20 ? run-dir).....
a200: 28 69 66 20 28 3e 20 28 64 69 72 65 63 74 6f 72 (if (> (director
a210: 79 2d 66 6f 6c 64 20 28 6c 61 6d 62 64 61 20 28 y-fold (lambda (
a220: 66 20 78 29 28 2b 20 31 20 78 29 29 20 30 20 72 f x)(+ 1 x)) 0 r
a230: 75 6e 2d 64 69 72 29 20 30 29 0a 09 09 09 09 20 un-dir) 0).....
a240: 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 (debug:print
a250: 20 30 20 22 57 41 52 4e 49 4e 47 3a 20 72 65 66 0 "WARNING: ref
a260: 75 73 69 6e 67 20 74 6f 20 72 65 6d 6f 76 65 20 using to remove
a270: 22 20 72 75 6e 2d 64 69 72 20 22 20 61 73 20 69 " run-dir " as i
a280: 74 20 69 73 20 6e 6f 74 20 65 6d 70 74 79 22 29 t is not empty")
a290: 0a 09 09 09 09 20 20 20 20 20 20 28 68 61 6e 64 ..... (hand
a2a0: 6c 65 2d 65 78 63 65 70 74 69 6f 6e 73 0a 09 09 le-exceptions...
a2b0: 09 09 20 20 20 20 20 20 20 65 78 6e 0a 09 09 09 .. exn....
a2c0: 09 20 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 . (debug:p
a2d0: 72 69 6e 74 20 30 20 22 45 52 52 4f 52 3a 20 20 rint 0 "ERROR:
a2e0: 46 61 69 6c 65 64 20 74 6f 20 72 65 6d 6f 76 65 Failed to remove
a2f0: 20 64 69 72 65 63 74 6f 72 79 20 22 20 72 75 6e directory " run
a300: 2d 64 69 72 20 28 28 63 6f 6e 64 69 74 69 6f 6e -dir ((condition
a310: 2d 70 72 6f 70 65 72 74 79 2d 61 63 63 65 73 73 -property-access
a320: 6f 72 20 27 65 78 6e 20 27 6d 65 73 73 61 67 65 or 'exn 'message
a330: 29 20 65 78 6e 29 20 22 2c 20 61 74 74 65 6d 70 ) exn) ", attemp
a340: 74 69 6e 67 20 74 6f 20 63 6f 6e 74 69 6e 75 65 ting to continue
a350: 22 29 0a 09 09 09 09 20 20 20 20 20 20 20 28 64 ")..... (d
a360: 65 6c 65 74 65 2d 64 69 72 65 63 74 6f 72 79 20 elete-directory
a370: 72 75 6e 2d 64 69 72 29 29 29 0a 09 09 09 09 20 run-dir))).....
a380: 28 69 66 20 72 75 6e 2d 64 69 72 0a 09 09 09 09 (if run-dir.....
a390: 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e (debug:prin
a3a0: 74 20 30 20 22 57 41 52 4e 49 4e 47 3a 20 6e 6f t 0 "WARNING: no
a3b0: 74 20 72 65 6d 6f 76 69 6e 67 20 22 20 72 75 6e t removing " run
a3c0: 2d 64 69 72 20 22 20 61 73 20 69 74 20 65 69 74 -dir " as it eit
a3d0: 68 65 72 20 64 6f 65 73 6e 27 74 20 65 78 69 73 her doesn't exis
a3e0: 74 20 6f 72 20 69 73 20 6e 6f 74 20 61 20 73 79 t or is not a sy
a3f0: 6d 6c 69 6e 6b 22 29 0a 09 09 09 09 20 20 20 20 mlink").....
a400: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 (debug:print 0
a410: 22 4e 4f 54 45 3a 20 74 68 65 20 72 75 6e 20 64 "NOTE: the run d
a420: 69 72 20 66 6f 72 20 74 68 69 73 20 74 65 73 74 ir for this test
a430: 20 69 73 20 75 6e 64 65 66 69 6e 65 64 2e 20 54 is undefined. T
a440: 65 73 74 20 6d 61 79 20 68 61 76 65 20 61 6c 72 est may have alr
a450: 65 61 64 79 20 62 65 65 6e 20 64 65 6c 65 74 65 eady been delete
a460: 64 2e 22 29 29 0a 09 09 09 09 20 29 29 29 0a 09 d."))..... )))..
a470: 09 09 28 28 73 65 74 2d 73 74 61 74 65 2d 73 74 ..((set-state-st
a480: 61 74 75 73 29 0a 09 09 09 20 28 64 65 62 75 67 atus).... (debug
a490: 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 32 20 22 6e :print-info 2 "n
a4a0: 65 77 20 73 74 61 74 65 20 22 20 28 63 61 72 20 ew state " (car
a4b0: 73 74 61 74 65 2d 73 74 61 74 75 73 29 20 22 2c state-status) ",
a4c0: 20 6e 65 77 20 73 74 61 74 75 73 20 22 20 28 63 new status " (c
a4d0: 61 64 72 20 73 74 61 74 65 2d 73 74 61 74 75 73 adr state-status
a4e0: 29 29 0a 09 09 09 20 28 6f 70 65 6e 2d 72 75 6e )).... (open-run
a4f0: 2d 63 6c 6f 73 65 20 64 62 3a 74 65 73 74 2d 73 -close db:test-s
a500: 65 74 2d 73 74 61 74 65 2d 73 74 61 74 75 73 2d et-state-status-
a510: 62 79 2d 69 64 20 64 62 20 28 64 62 3a 74 65 73 by-id db (db:tes
a520: 74 2d 67 65 74 2d 69 64 20 74 65 73 74 29 20 28 t-get-id test) (
a530: 63 61 72 20 73 74 61 74 65 2d 73 74 61 74 75 73 car state-status
a540: 29 28 63 61 64 72 20 73 74 61 74 65 2d 73 74 61 )(cadr state-sta
a550: 74 75 73 29 20 23 66 29 29 29 29 29 0a 09 09 20 tus) #f)))))...
a560: 20 28 73 6f 72 74 20 74 65 73 74 73 20 28 6c 61 (sort tests (la
a570: 6d 62 64 61 20 28 61 20 62 29 28 6c 65 74 20 28 mbda (a b)(let (
a580: 28 64 69 72 61 20 28 64 62 3a 74 65 73 74 2d 67 (dira (db:test-g
a590: 65 74 2d 72 75 6e 64 69 72 20 61 29 29 0a 09 09 et-rundir a))...
a5a0: 09 09 09 09 20 28 64 69 72 62 20 28 64 62 3a 74 .... (dirb (db:t
a5b0: 65 73 74 2d 67 65 74 2d 72 75 6e 64 69 72 20 62 est-get-rundir b
a5c0: 29 29 29 0a 09 09 09 09 09 20 20 20 20 20 28 69 )))...... (i
a5d0: 66 20 28 61 6e 64 20 28 73 74 72 69 6e 67 3f 20 f (and (string?
a5e0: 64 69 72 61 29 28 73 74 72 69 6e 67 3f 20 64 69 dira)(string? di
a5f0: 72 62 29 29 0a 09 09 09 09 09 09 20 28 3e 20 28 rb))....... (> (
a600: 73 74 72 69 6e 67 2d 6c 65 6e 67 74 68 20 64 69 string-length di
a610: 72 61 29 28 73 74 72 69 6e 67 2d 6c 65 6e 67 74 ra)(string-lengt
a620: 68 20 64 69 72 62 29 29 0a 09 09 09 09 09 09 20 h dirb)).......
a630: 23 66 29 29 29 29 29 29 29 0a 09 20 20 20 3b 3b #f))))))).. ;;
a640: 20 72 65 6d 6f 76 65 20 74 68 65 20 72 75 6e 20 remove the run
a650: 69 66 20 7a 65 72 6f 20 74 65 73 74 73 20 72 65 if zero tests re
a660: 6d 61 69 6e 0a 09 20 20 20 28 69 66 20 28 65 71 main.. (if (eq
a670: 3f 20 61 63 74 69 6f 6e 20 27 72 65 6d 6f 76 65 ? action 'remove
a680: 2d 72 75 6e 73 29 0a 09 20 20 20 20 20 20 20 28 -runs).. (
a690: 6c 65 74 20 28 28 72 65 6d 74 65 73 74 73 20 28 let ((remtests (
a6a0: 6f 70 65 6e 2d 72 75 6e 2d 63 6c 6f 73 65 20 64 open-run-close d
a6b0: 62 3a 67 65 74 2d 74 65 73 74 73 2d 66 6f 72 2d b:get-tests-for-
a6c0: 72 75 6e 20 64 62 20 28 64 62 3a 67 65 74 2d 76 run db (db:get-v
a6d0: 61 6c 75 65 2d 62 79 2d 68 65 61 64 65 72 20 72 alue-by-header r
a6e0: 75 6e 20 68 65 61 64 65 72 20 22 69 64 22 29 20 un header "id")
a6f0: 23 66 20 27 28 22 44 45 4c 45 54 45 44 22 29 20 #f '("DELETED")
a700: 27 28 22 6e 2f 61 22 29 20 6e 6f 74 2d 69 6e 3a '("n/a") not-in:
a710: 20 23 74 29 29 29 0a 09 09 20 28 69 66 20 28 6e #t)))... (if (n
a720: 75 6c 6c 3f 20 72 65 6d 74 65 73 74 73 29 20 3b ull? remtests) ;
a730: 3b 20 6e 6f 20 6d 6f 72 65 20 74 65 73 74 73 20 ; no more tests
a740: 72 65 6d 61 69 6e 69 6e 67 0a 09 09 20 20 20 20 remaining...
a750: 20 28 6c 65 74 2a 20 28 28 64 70 61 72 74 73 20 (let* ((dparts
a760: 20 28 73 74 72 69 6e 67 2d 73 70 6c 69 74 20 6c (string-split l
a770: 61 73 74 74 70 61 74 68 20 22 2f 22 29 29 0a 09 asttpath "/"))..
a780: 09 09 20 20 20 20 28 72 75 6e 70 61 74 68 20 28 .. (runpath (
a790: 63 6f 6e 63 20 22 2f 22 20 28 73 74 72 69 6e 67 conc "/" (string
a7a0: 2d 69 6e 74 65 72 73 70 65 72 73 65 20 0a 09 09 -intersperse ...
a7b0: 09 09 09 09 28 74 61 6b 65 20 64 70 61 72 74 73 ....(take dparts
a7c0: 20 28 2d 20 28 6c 65 6e 67 74 68 20 64 70 61 72 (- (length dpar
a7d0: 74 73 29 20 31 29 29 0a 09 09 09 09 09 09 22 2f ts) 1))......."/
a7e0: 22 29 29 29 29 0a 09 09 20 20 20 20 20 20 20 28 "))))... (
a7f0: 64 65 62 75 67 3a 70 72 69 6e 74 20 31 20 22 52 debug:print 1 "R
a800: 65 6d 6f 76 69 6e 67 20 72 75 6e 3a 20 22 20 72 emoving run: " r
a810: 75 6e 6b 65 79 20 22 20 22 20 28 64 62 3a 67 65 unkey " " (db:ge
a820: 74 2d 76 61 6c 75 65 2d 62 79 2d 68 65 61 64 65 t-value-by-heade
a830: 72 20 72 75 6e 20 68 65 61 64 65 72 20 22 72 75 r run header "ru
a840: 6e 6e 61 6d 65 22 29 20 22 20 61 6e 64 20 72 65 nname") " and re
a850: 6c 61 74 65 64 20 72 65 63 6f 72 64 22 29 0a 09 lated record")..
a860: 09 20 20 20 20 20 20 20 28 6f 70 65 6e 2d 72 75 . (open-ru
a870: 6e 2d 63 6c 6f 73 65 20 64 62 3a 64 65 6c 65 74 n-close db:delet
a880: 65 2d 72 75 6e 20 64 62 20 72 75 6e 2d 69 64 29 e-run db run-id)
a890: 0a 09 09 20 20 20 20 20 20 20 3b 3b 20 54 68 69 ... ;; Thi
a8a0: 73 20 69 73 20 61 20 70 72 65 74 74 79 20 67 6f s is a pretty go
a8b0: 6f 64 20 70 6c 61 63 65 20 74 6f 20 70 75 72 67 od place to purg
a8c0: 65 20 6f 6c 64 20 44 45 4c 45 54 45 44 20 74 65 e old DELETED te
a8d0: 73 74 73 0a 09 09 20 20 20 20 20 20 20 28 6f 70 sts... (op
a8e0: 65 6e 2d 72 75 6e 2d 63 6c 6f 73 65 20 64 62 3a en-run-close db:
a8f0: 64 65 6c 65 74 65 2d 74 65 73 74 73 2d 66 6f 72 delete-tests-for
a900: 2d 72 75 6e 20 64 62 20 72 75 6e 2d 69 64 29 0a -run db run-id).
a910: 09 09 20 20 20 20 20 20 20 28 6f 70 65 6e 2d 72 .. (open-r
a920: 75 6e 2d 63 6c 6f 73 65 20 64 62 3a 64 65 6c 65 un-close db:dele
a930: 74 65 2d 6f 6c 64 2d 64 65 6c 65 74 65 64 2d 74 te-old-deleted-t
a940: 65 73 74 2d 72 65 63 6f 72 64 73 20 64 62 29 0a est-records db).
a950: 09 09 20 20 20 20 20 20 20 28 6f 70 65 6e 2d 72 .. (open-r
a960: 75 6e 2d 63 6c 6f 73 65 20 64 62 3a 73 65 74 2d un-close db:set-
a970: 76 61 72 20 64 62 20 22 44 45 4c 45 54 45 44 5f var db "DELETED_
a980: 54 45 53 54 53 22 20 28 63 75 72 72 65 6e 74 2d TESTS" (current-
a990: 73 65 63 6f 6e 64 73 29 29 0a 09 09 20 20 20 20 seconds))...
a9a0: 20 20 20 3b 3b 20 6e 65 65 64 20 74 6f 20 66 69 ;; need to fi
a9b0: 67 75 72 65 20 6f 75 74 20 74 68 65 20 70 61 74 gure out the pat
a9c0: 68 20 74 6f 20 74 68 65 20 72 75 6e 20 64 69 72 h to the run dir
a9d0: 20 61 6e 64 20 72 65 6d 6f 76 65 20 69 74 20 69 and remove it i
a9e0: 66 20 65 6d 70 74 79 0a 09 09 20 20 20 20 20 20 f empty...
a9f0: 20 3b 3b 20 20 20 20 28 69 66 20 28 6e 75 6c 6c ;; (if (null
aa00: 3f 20 28 67 6c 6f 62 20 28 63 6f 6e 63 20 72 75 ? (glob (conc ru
aa10: 6e 70 61 74 68 20 22 2f 2a 22 29 29 29 0a 09 09 npath "/*")))...
aa20: 20 20 20 20 20 20 20 3b 3b 20 20 20 20 20 20 20 ;;
aa30: 20 28 62 65 67 69 6e 0a 09 09 20 20 20 20 20 20 (begin...
aa40: 20 3b 3b 20 09 20 28 64 65 62 75 67 3a 70 72 69 ;; . (debug:pri
aa50: 6e 74 20 31 20 22 52 65 6d 6f 76 69 6e 67 20 72 nt 1 "Removing r
aa60: 75 6e 20 64 69 72 20 22 20 72 75 6e 70 61 74 68 un dir " runpath
aa70: 29 0a 09 09 20 20 20 20 20 20 20 3b 3b 20 09 20 )... ;; .
aa80: 28 73 79 73 74 65 6d 20 28 63 6f 6e 63 20 22 72 (system (conc "r
aa90: 6d 64 69 72 20 2d 70 20 22 20 72 75 6e 70 61 74 mdir -p " runpat
aaa0: 68 29 29 29 29 0a 09 09 20 20 20 20 20 20 20 29 h))))... )
aab0: 29 29 29 29 0a 09 20 29 29 0a 20 20 20 20 20 72 )))).. )). r
aac0: 75 6e 73 29 29 0a 20 20 23 74 29 0a 0a 3b 3b 3d uns)). #t)..;;=
aad0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
aae0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
aaf0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
ab00: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
ab10: 3d 3d 3d 3d 3d 0a 3b 3b 20 52 6f 75 74 69 6e 65 =====.;; Routine
ab20: 73 20 66 6f 72 20 6d 61 6e 69 70 75 6c 61 74 69 s for manipulati
ab30: 6e 67 20 72 75 6e 73 0a 3b 3b 3d 3d 3d 3d 3d 3d ng runs.;;======
ab40: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
ab50: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
ab60: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
ab70: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
ab80: 0a 0a 3b 3b 20 53 69 6e 63 65 20 6d 61 6e 79 20 ..;; Since many
ab90: 63 61 6c 6c 73 20 74 6f 20 61 20 72 75 6e 20 72 calls to a run r
aba0: 65 71 75 69 72 65 20 70 72 65 74 74 79 20 6d 75 equire pretty mu
abb0: 63 68 20 74 68 65 20 73 61 6d 65 20 73 65 74 75 ch the same setu
abc0: 70 20 0a 3b 3b 20 74 68 69 73 20 77 72 61 70 70 p .;; this wrapp
abd0: 65 72 20 69 73 20 75 73 65 64 20 74 6f 20 72 65 er is used to re
abe0: 64 75 63 65 20 74 68 65 20 72 65 70 6c 69 63 61 duce the replica
abf0: 74 69 6f 6e 20 6f 66 20 63 6f 64 65 0a 28 64 65 tion of code.(de
ac00: 66 69 6e 65 20 28 67 65 6e 65 72 61 6c 2d 72 75 fine (general-ru
ac10: 6e 2d 63 61 6c 6c 20 73 77 69 74 63 68 6e 61 6d n-call switchnam
ac20: 65 20 61 63 74 69 6f 6e 2d 64 65 73 63 20 70 72 e action-desc pr
ac30: 6f 63 29 0a 20 20 28 6c 65 74 20 28 28 72 75 6e oc). (let ((run
ac40: 6e 61 6d 65 20 28 61 72 67 73 3a 67 65 74 2d 61 name (args:get-a
ac50: 72 67 20 22 3a 72 75 6e 6e 61 6d 65 22 29 29 0a rg ":runname")).
ac60: 09 28 74 61 72 67 65 74 20 20 28 69 66 20 28 61 .(target (if (a
ac70: 72 67 73 3a 67 65 74 2d 61 72 67 20 22 2d 74 61 rgs:get-arg "-ta
ac80: 72 67 65 74 22 29 0a 09 09 20 20 20 20 20 28 61 rget")... (a
ac90: 72 67 73 3a 67 65 74 2d 61 72 67 20 22 2d 74 61 rgs:get-arg "-ta
aca0: 72 67 65 74 22 29 0a 09 09 20 20 20 20 20 28 61 rget")... (a
acb0: 72 67 73 3a 67 65 74 2d 61 72 67 20 22 2d 72 65 rgs:get-arg "-re
acc0: 71 74 61 72 67 22 29 29 29 0a 09 28 74 68 31 20 qtarg")))..(th1
acd0: 20 20 20 20 23 66 29 29 0a 20 20 20 20 28 63 6f #f)). (co
ace0: 6e 64 0a 20 20 20 20 20 28 28 6e 6f 74 20 74 61 nd. ((not ta
acf0: 72 67 65 74 29 0a 20 20 20 20 20 20 28 64 65 62 rget). (deb
ad00: 75 67 3a 70 72 69 6e 74 20 30 20 22 45 52 52 4f ug:print 0 "ERRO
ad10: 52 3a 20 4d 69 73 73 69 6e 67 20 72 65 71 75 69 R: Missing requi
ad20: 72 65 64 20 70 61 72 61 6d 65 74 65 72 20 66 6f red parameter fo
ad30: 72 20 22 20 73 77 69 74 63 68 6e 61 6d 65 20 22 r " switchname "
ad40: 2c 20 79 6f 75 20 6d 75 73 74 20 73 70 65 63 69 , you must speci
ad50: 66 79 20 74 68 65 20 74 61 72 67 65 74 20 77 69 fy the target wi
ad60: 74 68 20 2d 74 61 72 67 65 74 22 29 0a 20 20 20 th -target").
ad70: 20 20 20 28 65 78 69 74 20 33 29 29 0a 20 20 20 (exit 3)).
ad80: 20 20 28 28 6e 6f 74 20 72 75 6e 6e 61 6d 65 29 ((not runname)
ad90: 0a 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 . (debug:pr
ada0: 69 6e 74 20 30 20 22 45 52 52 4f 52 3a 20 4d 69 int 0 "ERROR: Mi
adb0: 73 73 69 6e 67 20 72 65 71 75 69 72 65 64 20 70 ssing required p
adc0: 61 72 61 6d 65 74 65 72 20 66 6f 72 20 22 20 73 arameter for " s
add0: 77 69 74 63 68 6e 61 6d 65 20 22 2c 20 79 6f 75 witchname ", you
ade0: 20 6d 75 73 74 20 73 70 65 63 69 66 79 20 74 68 must specify th
adf0: 65 20 72 75 6e 20 6e 61 6d 65 20 77 69 74 68 20 e run name with
ae00: 3a 72 75 6e 6e 61 6d 65 20 72 75 6e 6e 61 6d 65 :runname runname
ae10: 22 29 0a 20 20 20 20 20 20 28 65 78 69 74 20 33 "). (exit 3
ae20: 29 29 0a 20 20 20 20 20 28 65 6c 73 65 0a 20 20 )). (else.
ae30: 20 20 20 20 28 6c 65 74 20 28 28 64 62 20 20 20 (let ((db
ae40: 23 66 29 0a 09 20 20 20 20 28 6b 65 79 73 20 23 #f).. (keys #
ae50: 66 29 29 0a 09 28 69 66 20 28 6e 6f 74 20 28 73 f))..(if (not (s
ae60: 65 74 75 70 2d 66 6f 72 2d 72 75 6e 29 29 0a 09 etup-for-run))..
ae70: 20 20 20 20 28 62 65 67 69 6e 20 0a 09 20 20 20 (begin ..
ae80: 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 (debug:print
ae90: 30 20 22 46 61 69 6c 65 64 20 74 6f 20 73 65 74 0 "Failed to set
aea0: 75 70 2c 20 65 78 69 74 69 6e 67 22 29 0a 09 20 up, exiting")..
aeb0: 20 20 20 20 20 28 65 78 69 74 20 31 29 29 29 0a (exit 1))).
aec0: 09 28 69 66 20 28 61 72 67 73 3a 67 65 74 2d 61 .(if (args:get-a
aed0: 72 67 20 22 2d 73 65 72 76 65 72 22 29 0a 09 20 rg "-server")..
aee0: 20 20 20 28 6f 70 65 6e 2d 72 75 6e 2d 63 6c 6f (open-run-clo
aef0: 73 65 20 73 65 72 76 65 72 3a 73 74 61 72 74 20 se server:start
af00: 64 62 20 28 61 72 67 73 3a 67 65 74 2d 61 72 67 db (args:get-arg
af10: 20 22 2d 73 65 72 76 65 72 22 29 29 29 0a 20 09 "-server"))). .
af20: 20 20 20 20 3b 3b 20 28 69 66 20 28 6e 6f 74 20 ;; (if (not
af30: 28 6f 72 20 28 61 72 67 73 3a 67 65 74 2d 61 72 (or (args:get-ar
af40: 67 20 22 2d 72 75 6e 61 6c 6c 22 29 20 20 20 20 g "-runall")
af50: 20 3b 3b 20 72 75 6e 61 6c 6c 20 61 6e 64 20 72 ;; runall and r
af60: 75 6e 74 65 73 74 73 20 61 72 65 20 61 6c 6c 6f untests are allo
af70: 77 65 64 20 74 6f 20 62 65 20 73 65 72 76 65 72 wed to be server
af80: 73 0a 20 09 20 20 20 20 3b 3b 20 20 20 20 20 09 s. . ;; .
af90: 20 28 61 72 67 73 3a 67 65 74 2d 61 72 67 20 22 (args:get-arg "
afa0: 2d 72 75 6e 74 65 73 74 73 22 29 29 29 0a 09 20 -runtests")))..
afb0: 20 20 20 3b 3b 20 20 20 20 20 28 63 6c 69 65 6e ;; (clien
afc0: 74 3a 73 65 74 75 70 29 20 3b 3b 20 54 68 69 73 t:setup) ;; This
afd0: 20 69 73 20 61 20 64 75 70 6c 69 63 61 74 65 20 is a duplicate
afe0: 73 74 61 72 74 75 70 21 21 21 3f 3f 3f 20 42 55 startup!!!??? BU
aff0: 47 3f 0a 09 20 20 20 20 3b 3b 20 20 20 20 20 29 G?.. ;; )
b000: 29 0a 09 28 73 65 74 21 20 6b 65 79 73 20 28 6f )..(set! keys (o
b010: 70 65 6e 2d 72 75 6e 2d 63 6c 6f 73 65 20 64 62 pen-run-close db
b020: 3a 67 65 74 2d 6b 65 79 73 20 64 62 29 29 0a 09 :get-keys db))..
b030: 3b 3b 20 68 61 76 65 20 65 6e 6f 75 67 68 20 74 ;; have enough t
b040: 6f 20 70 72 6f 63 65 73 73 20 2d 74 61 72 67 65 o process -targe
b050: 74 20 6f 72 20 2d 72 65 71 74 61 72 67 20 68 65 t or -reqtarg he
b060: 72 65 0a 09 28 69 66 20 28 61 72 67 73 3a 67 65 re..(if (args:ge
b070: 74 2d 61 72 67 20 22 2d 72 65 71 74 61 72 67 22 t-arg "-reqtarg"
b080: 29 0a 09 20 20 20 20 28 6c 65 74 2a 20 28 28 72 ).. (let* ((r
b090: 75 6e 63 6f 6e 66 69 67 66 20 28 63 6f 6e 63 20 unconfigf (conc
b0a0: 20 2a 74 6f 70 70 61 74 68 2a 20 22 2f 72 75 6e *toppath* "/run
b0b0: 63 6f 6e 66 69 67 73 2e 63 6f 6e 66 69 67 22 29 configs.config")
b0c0: 29 20 3b 3b 20 44 4f 20 4e 4f 54 20 45 56 41 4c ) ;; DO NOT EVAL
b0d0: 55 41 54 45 20 41 4c 4c 20 0a 09 09 20 20 20 28 UATE ALL ... (
b0e0: 72 75 6e 63 6f 6e 66 69 67 20 20 28 72 65 61 64 runconfig (read
b0f0: 2d 63 6f 6e 66 69 67 20 72 75 6e 63 6f 6e 66 69 -config runconfi
b100: 67 66 20 23 66 20 23 74 20 65 6e 76 69 72 6f 6e gf #f #t environ
b110: 2d 70 61 74 74 3a 20 23 66 29 29 29 20 0a 09 20 -patt: #f))) ..
b120: 20 20 20 20 20 28 69 66 20 28 68 61 73 68 2d 74 (if (hash-t
b130: 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 able-ref/default
b140: 20 72 75 6e 63 6f 6e 66 69 67 20 28 61 72 67 73 runconfig (args
b150: 3a 67 65 74 2d 61 72 67 20 22 2d 72 65 71 74 61 :get-arg "-reqta
b160: 72 67 22 29 20 23 66 29 0a 09 09 20 20 28 6b 65 rg") #f)... (ke
b170: 79 73 3a 74 61 72 67 65 74 2d 73 65 74 2d 61 72 ys:target-set-ar
b180: 67 73 20 6b 65 79 73 20 28 61 72 67 73 3a 67 65 gs keys (args:ge
b190: 74 2d 61 72 67 20 22 2d 72 65 71 74 61 72 67 22 t-arg "-reqtarg"
b1a0: 29 20 61 72 67 73 3a 61 72 67 2d 68 61 73 68 29 ) args:arg-hash)
b1b0: 0a 09 09 20 20 28 62 65 67 69 6e 0a 09 09 20 20 ... (begin...
b1c0: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 (debug:print 0
b1d0: 20 22 45 52 52 4f 52 3a 20 5b 22 20 28 61 72 67 "ERROR: [" (arg
b1e0: 73 3a 67 65 74 2d 61 72 67 20 22 2d 72 65 71 74 s:get-arg "-reqt
b1f0: 61 72 67 22 29 20 22 5d 20 6e 6f 74 20 66 6f 75 arg") "] not fou
b200: 6e 64 20 69 6e 20 22 20 72 75 6e 63 6f 6e 66 69 nd in " runconfi
b210: 67 66 29 0a 09 09 20 20 20 20 28 69 66 20 64 62 gf)... (if db
b220: 20 28 73 71 6c 69 74 65 33 3a 66 69 6e 61 6c 69 (sqlite3:finali
b230: 7a 65 21 20 64 62 29 29 0a 09 09 20 20 20 20 28 ze! db))... (
b240: 65 78 69 74 20 31 29 29 29 29 0a 09 20 20 20 20 exit 1))))..
b250: 28 69 66 20 28 61 72 67 73 3a 67 65 74 2d 61 72 (if (args:get-ar
b260: 67 20 22 2d 74 61 72 67 65 74 22 29 0a 09 09 28 g "-target")...(
b270: 6b 65 79 73 3a 74 61 72 67 65 74 2d 73 65 74 2d keys:target-set-
b280: 61 72 67 73 20 6b 65 79 73 20 28 61 72 67 73 3a args keys (args:
b290: 67 65 74 2d 61 72 67 20 22 2d 74 61 72 67 65 74 get-arg "-target
b2a0: 22 20 61 72 67 73 3a 61 72 67 2d 68 61 73 68 29 " args:arg-hash)
b2b0: 20 61 72 67 73 3a 61 72 67 2d 68 61 73 68 29 29 args:arg-hash))
b2c0: 29 0a 09 28 69 66 20 28 6e 6f 74 20 28 63 61 72 )..(if (not (car
b2d0: 20 2a 63 6f 6e 66 69 67 69 6e 66 6f 2a 29 29 0a *configinfo*)).
b2e0: 09 20 20 20 20 28 62 65 67 69 6e 0a 09 20 20 20 . (begin..
b2f0: 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 (debug:print
b300: 30 20 22 45 52 52 4f 52 3a 20 41 74 74 65 6d 70 0 "ERROR: Attemp
b310: 74 65 64 20 74 6f 20 22 20 61 63 74 69 6f 6e 2d ted to " action-
b320: 64 65 73 63 20 22 20 62 75 74 20 72 75 6e 20 61 desc " but run a
b330: 72 65 61 20 63 6f 6e 66 69 67 20 66 69 6c 65 20 rea config file
b340: 6e 6f 74 20 66 6f 75 6e 64 22 29 0a 09 20 20 20 not found")..
b350: 20 20 20 28 65 78 69 74 20 31 29 29 0a 09 20 20 (exit 1))..
b360: 20 20 3b 3b 20 45 78 74 72 61 63 74 20 6f 75 74 ;; Extract out
b370: 20 73 74 75 66 66 20 6e 65 65 64 65 64 20 69 6e stuff needed in
b380: 20 6d 6f 73 74 20 6f 72 20 6d 61 6e 79 20 63 61 most or many ca
b390: 6c 6c 73 0a 09 20 20 20 20 3b 3b 20 68 65 72 65 lls.. ;; here
b3a0: 20 74 68 65 6e 20 63 61 6c 6c 20 70 72 6f 63 0a then call proc.
b3b0: 09 20 20 20 20 28 6c 65 74 2a 20 28 28 6b 65 79 . (let* ((key
b3c0: 6e 61 6d 65 73 20 20 20 28 6d 61 70 20 6b 65 79 names (map key
b3d0: 3a 67 65 74 2d 66 69 65 6c 64 6e 61 6d 65 20 6b :get-fieldname k
b3e0: 65 79 73 29 29 0a 09 09 20 20 20 28 6b 65 79 76 eys))... (keyv
b3f0: 61 6c 6c 73 74 20 20 28 6b 65 79 73 2d 3e 76 61 allst (keys->va
b400: 6c 6c 69 73 74 20 6b 65 79 73 20 23 74 29 29 29 llist keys #t)))
b410: 0a 09 20 20 20 20 20 20 28 70 72 6f 63 20 74 61 .. (proc ta
b420: 72 67 65 74 20 72 75 6e 6e 61 6d 65 20 6b 65 79 rget runname key
b430: 73 20 6b 65 79 6e 61 6d 65 73 20 6b 65 79 76 61 s keynames keyva
b440: 6c 6c 73 74 29 29 29 0a 09 28 69 66 20 74 68 31 llst)))..(if th1
b450: 20 28 74 68 72 65 61 64 2d 6a 6f 69 6e 21 20 74 (thread-join! t
b460: 68 31 29 29 0a 09 28 69 66 20 64 62 20 28 73 71 h1))..(if db (sq
b470: 6c 69 74 65 33 3a 66 69 6e 61 6c 69 7a 65 21 20 lite3:finalize!
b480: 64 62 29 29 0a 09 28 73 65 74 21 20 2a 64 69 64 db))..(set! *did
b490: 73 6f 6d 65 74 68 69 6e 67 2a 20 23 74 29 29 29 something* #t)))
b4a0: 29 29 29 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d )))..;;=========
b4b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
b4c0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
b4d0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
b4e0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b =============.;;
b4f0: 20 4c 6f 63 6b 2f 75 6e 6c 6f 63 6b 20 72 75 6e Lock/unlock run
b500: 73 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d s.;;============
b510: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
b520: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
b530: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
b540: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 28 64 65 66 ==========..(def
b550: 69 6e 65 20 28 72 75 6e 73 3a 68 61 6e 64 6c 65 ine (runs:handle
b560: 2d 6c 6f 63 6b 69 6e 67 20 74 61 72 67 65 74 20 -locking target
b570: 6b 65 79 73 20 72 75 6e 6e 61 6d 65 20 6c 6f 63 keys runname loc
b580: 6b 20 75 6e 6c 6f 63 6b 20 75 73 65 72 29 0a 20 k unlock user).
b590: 20 28 6c 65 74 2a 20 28 28 64 62 20 20 20 20 20 (let* ((db
b5a0: 20 20 23 66 29 0a 09 20 28 72 75 6e 64 61 74 20 #f).. (rundat
b5b0: 20 20 28 6f 70 65 6e 2d 72 75 6e 2d 63 6c 6f 73 (open-run-clos
b5c0: 65 20 72 75 6e 73 3a 67 65 74 2d 72 75 6e 73 2d e runs:get-runs-
b5d0: 62 79 2d 70 61 74 74 20 64 62 20 6b 65 79 73 20 by-patt db keys
b5e0: 72 75 6e 6e 61 6d 65 29 29 0a 09 20 28 68 65 61 runname)).. (hea
b5f0: 64 65 72 20 20 20 28 76 65 63 74 6f 72 2d 72 65 der (vector-re
b600: 66 20 72 75 6e 64 61 74 20 30 29 29 0a 09 20 28 f rundat 0)).. (
b610: 72 75 6e 73 20 20 20 20 20 28 76 65 63 74 6f 72 runs (vector
b620: 2d 72 65 66 20 72 75 6e 64 61 74 20 31 29 29 29 -ref rundat 1)))
b630: 0a 20 20 20 20 28 66 6f 72 2d 65 61 63 68 20 28 . (for-each (
b640: 6c 61 6d 62 64 61 20 28 72 75 6e 29 0a 09 09 28 lambda (run)...(
b650: 6c 65 74 20 28 28 72 75 6e 2d 69 64 20 28 64 62 let ((run-id (db
b660: 3a 67 65 74 2d 76 61 6c 75 65 2d 62 79 2d 68 65 :get-value-by-he
b670: 61 64 65 72 20 72 75 6e 20 68 65 61 64 65 72 20 ader run header
b680: 22 69 64 22 29 29 29 0a 09 09 20 20 28 69 66 20 "id")))... (if
b690: 28 6f 72 20 6c 6f 63 6b 0a 09 09 09 20 20 28 61 (or lock.... (a
b6a0: 6e 64 20 75 6e 6c 6f 63 6b 0a 09 09 09 20 20 20 nd unlock....
b6b0: 20 20 20 20 28 62 65 67 69 6e 0a 09 09 09 09 20 (begin.....
b6c0: 28 70 72 69 6e 74 20 22 44 6f 20 79 6f 75 20 72 (print "Do you r
b6d0: 65 61 6c 6c 79 20 77 69 73 68 20 74 6f 20 75 6e eally wish to un
b6e0: 6c 6f 63 6b 20 72 75 6e 20 22 20 72 75 6e 2d 69 lock run " run-i
b6f0: 64 20 22 3f 5c 6e 20 20 20 79 2f 6e 3a 20 22 29 d "?\n y/n: ")
b700: 0a 09 09 09 09 20 28 65 71 75 61 6c 3f 20 22 79 ..... (equal? "y
b710: 22 20 28 72 65 61 64 2d 6c 69 6e 65 29 29 29 29 " (read-line))))
b720: 29 0a 09 09 20 20 20 20 20 20 28 6f 70 65 6e 2d )... (open-
b730: 72 75 6e 2d 63 6c 6f 73 65 20 64 62 3a 6c 6f 63 run-close db:loc
b740: 6b 2f 75 6e 6c 6f 63 6b 2d 72 75 6e 20 64 62 20 k/unlock-run db
b750: 72 75 6e 2d 69 64 20 6c 6f 63 6b 20 75 6e 6c 6f run-id lock unlo
b760: 63 6b 20 75 73 65 72 29 0a 09 09 20 20 20 20 20 ck user)...
b770: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e (debug:print-in
b780: 66 6f 20 30 20 22 53 6b 69 70 70 69 6e 67 20 6c fo 0 "Skipping l
b790: 6f 63 6b 2f 75 6e 6c 6f 63 6b 20 6f 6e 20 22 20 ock/unlock on "
b7a0: 72 75 6e 2d 69 64 29 29 29 29 0a 09 20 20 20 20 run-id))))..
b7b0: 20 20 72 75 6e 73 29 29 29 0a 3b 3b 3d 3d 3d 3d runs))).;;====
b7c0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
b7d0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
b7e0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
b7f0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
b800: 3d 3d 0a 3b 3b 20 52 6f 6c 6c 75 70 20 72 75 6e ==.;; Rollup run
b810: 73 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d s.;;============
b820: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
b830: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
b840: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
b850: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 3b 3b 20 55 ==========..;; U
b860: 70 64 61 74 65 20 74 68 65 20 74 65 73 74 5f 6d pdate the test_m
b870: 65 74 61 20 74 61 62 6c 65 20 66 6f 72 20 74 68 eta table for th
b880: 69 73 20 74 65 73 74 0a 28 64 65 66 69 6e 65 20 is test.(define
b890: 28 72 75 6e 73 3a 75 70 64 61 74 65 2d 74 65 73 (runs:update-tes
b8a0: 74 5f 6d 65 74 61 20 64 62 20 74 65 73 74 2d 6e t_meta db test-n
b8b0: 61 6d 65 20 74 65 73 74 2d 63 6f 6e 66 29 0a 20 ame test-conf).
b8c0: 20 28 6c 65 74 20 28 28 63 75 72 72 72 65 63 6f (let ((currreco
b8d0: 72 64 20 28 63 64 62 3a 72 65 6d 6f 74 65 2d 72 rd (cdb:remote-r
b8e0: 75 6e 20 64 62 3a 74 65 73 74 6d 65 74 61 2d 67 un db:testmeta-g
b8f0: 65 74 2d 72 65 63 6f 72 64 20 64 62 20 74 65 73 et-record db tes
b900: 74 2d 6e 61 6d 65 29 29 29 0a 20 20 20 20 28 69 t-name))). (i
b910: 66 20 28 6e 6f 74 20 63 75 72 72 72 65 63 6f 72 f (not currrecor
b920: 64 29 0a 09 28 62 65 67 69 6e 0a 09 20 20 28 73 d)..(begin.. (s
b930: 65 74 21 20 63 75 72 72 72 65 63 6f 72 64 20 28 et! currrecord (
b940: 6d 61 6b 65 2d 76 65 63 74 6f 72 20 31 30 20 23 make-vector 10 #
b950: 66 29 29 0a 09 20 20 28 63 64 62 3a 72 65 6d 6f f)).. (cdb:remo
b960: 74 65 2d 72 75 6e 20 64 62 3a 74 65 73 74 6d 65 te-run db:testme
b970: 74 61 2d 61 64 64 2d 72 65 63 6f 72 64 20 64 62 ta-add-record db
b980: 20 74 65 73 74 2d 6e 61 6d 65 29 29 29 0a 20 20 test-name))).
b990: 20 20 28 66 6f 72 2d 65 61 63 68 20 0a 20 20 20 (for-each .
b9a0: 20 20 28 6c 61 6d 62 64 61 20 28 6b 65 79 29 0a (lambda (key).
b9b0: 20 20 20 20 20 20 20 28 6c 65 74 2a 20 28 28 69 (let* ((i
b9c0: 64 78 20 28 63 61 64 72 20 6b 65 79 29 29 0a 09 dx (cadr key))..
b9d0: 20 20 20 20 20 20 28 66 6c 64 20 28 63 61 72 20 (fld (car
b9e0: 20 6b 65 79 29 29 0a 09 20 20 20 20 20 20 28 76 key)).. (v
b9f0: 61 6c 20 28 63 6f 6e 66 69 67 2d 6c 6f 6f 6b 75 al (config-looku
ba00: 70 20 74 65 73 74 2d 63 6f 6e 66 20 22 74 65 73 p test-conf "tes
ba10: 74 5f 6d 65 74 61 22 20 66 6c 64 29 29 29 0a 09 t_meta" fld)))..
ba20: 20 3b 3b 20 28 64 65 62 75 67 3a 70 72 69 6e 74 ;; (debug:print
ba30: 20 35 20 22 69 64 78 3a 20 22 20 69 64 78 20 22 5 "idx: " idx "
ba40: 20 66 6c 64 3a 20 22 20 66 6c 64 20 22 20 76 61 fld: " fld " va
ba50: 6c 3a 20 22 20 76 61 6c 29 0a 09 20 28 69 66 20 l: " val).. (if
ba60: 28 61 6e 64 20 76 61 6c 20 28 6e 6f 74 20 28 65 (and val (not (e
ba70: 71 75 61 6c 3f 20 28 76 65 63 74 6f 72 2d 72 65 qual? (vector-re
ba80: 66 20 63 75 72 72 72 65 63 6f 72 64 20 69 64 78 f currrecord idx
ba90: 29 20 76 61 6c 29 29 29 0a 09 20 20 20 20 20 28 ) val))).. (
baa0: 62 65 67 69 6e 0a 09 20 20 20 20 20 20 20 28 70 begin.. (p
bab0: 72 69 6e 74 20 22 55 70 64 61 74 69 6e 67 20 22 rint "Updating "
bac0: 20 74 65 73 74 2d 6e 61 6d 65 20 22 20 22 20 66 test-name " " f
bad0: 6c 64 20 22 20 74 6f 20 22 20 76 61 6c 29 0a 09 ld " to " val)..
bae0: 20 20 20 20 20 20 20 28 63 64 62 3a 72 65 6d 6f (cdb:remo
baf0: 74 65 2d 72 75 6e 20 64 62 3a 74 65 73 74 6d 65 te-run db:testme
bb00: 74 61 2d 75 70 64 61 74 65 2d 66 69 65 6c 64 20 ta-update-field
bb10: 64 62 20 74 65 73 74 2d 6e 61 6d 65 20 66 6c 64 db test-name fld
bb20: 20 76 61 6c 29 29 29 29 29 0a 20 20 20 20 20 27 val))))). '
bb30: 28 28 22 61 75 74 68 6f 72 22 20 32 29 28 22 6f (("author" 2)("o
bb40: 77 6e 65 72 22 20 33 29 28 22 64 65 73 63 72 69 wner" 3)("descri
bb50: 70 74 69 6f 6e 22 20 34 29 28 22 72 65 76 69 65 ption" 4)("revie
bb60: 77 65 64 22 20 35 29 28 22 74 61 67 73 22 20 39 wed" 5)("tags" 9
bb70: 29 29 29 29 29 0a 0a 3b 3b 20 55 70 64 61 74 65 )))))..;; Update
bb80: 20 74 65 73 74 5f 6d 65 74 61 20 66 6f 72 20 61 test_meta for a
bb90: 6c 6c 20 74 65 73 74 73 0a 28 64 65 66 69 6e 65 ll tests.(define
bba0: 20 28 72 75 6e 73 3a 75 70 64 61 74 65 2d 61 6c (runs:update-al
bbb0: 6c 2d 74 65 73 74 5f 6d 65 74 61 20 64 62 29 0a l-test_meta db).
bbc0: 20 20 28 6c 65 74 20 28 28 74 65 73 74 2d 6e 61 (let ((test-na
bbd0: 6d 65 73 20 28 67 65 74 2d 61 6c 6c 2d 6c 65 67 mes (get-all-leg
bbe0: 61 6c 2d 74 65 73 74 73 29 29 29 0a 20 20 20 20 al-tests))).
bbf0: 28 66 6f 72 2d 65 61 63 68 20 0a 20 20 20 20 20 (for-each .
bc00: 28 6c 61 6d 62 64 61 20 28 74 65 73 74 2d 6e 61 (lambda (test-na
bc10: 6d 65 29 0a 20 20 20 20 20 20 20 28 6c 65 74 2a me). (let*
bc20: 20 28 28 74 65 73 74 2d 70 61 74 68 20 20 20 20 ((test-path
bc30: 28 63 6f 6e 63 20 2a 74 6f 70 70 61 74 68 2a 20 (conc *toppath*
bc40: 22 2f 74 65 73 74 73 2f 22 20 74 65 73 74 2d 6e "/tests/" test-n
bc50: 61 6d 65 29 29 0a 09 20 20 20 20 20 20 28 74 65 ame)).. (te
bc60: 73 74 2d 63 6f 6e 66 69 67 66 20 28 63 6f 6e 63 st-configf (conc
bc70: 20 74 65 73 74 2d 70 61 74 68 20 22 2f 74 65 73 test-path "/tes
bc80: 74 63 6f 6e 66 69 67 22 29 29 0a 09 20 20 20 20 tconfig"))..
bc90: 20 20 28 74 65 73 74 65 78 69 73 74 73 20 20 20 (testexists
bca0: 28 61 6e 64 20 28 66 69 6c 65 2d 65 78 69 73 74 (and (file-exist
bcb0: 73 3f 20 74 65 73 74 2d 63 6f 6e 66 69 67 66 29 s? test-configf)
bcc0: 28 66 69 6c 65 2d 72 65 61 64 2d 61 63 63 65 73 (file-read-acces
bcd0: 73 3f 20 74 65 73 74 2d 63 6f 6e 66 69 67 66 29 s? test-configf)
bce0: 29 29 0a 09 20 20 20 20 20 20 3b 3b 20 72 65 61 )).. ;; rea
bcf0: 64 20 63 6f 6e 66 69 67 73 20 77 69 74 68 20 74 d configs with t
bd00: 72 69 63 6b 73 20 74 75 72 6e 65 64 20 6f 66 66 ricks turned off
bd10: 20 28 69 2e 65 2e 20 6e 6f 20 73 79 73 74 65 6d (i.e. no system
bd20: 29 0a 09 20 20 20 20 20 20 28 74 65 73 74 2d 63 ).. (test-c
bd30: 6f 6e 66 20 20 20 20 28 69 66 20 74 65 73 74 65 onf (if teste
bd40: 78 69 73 74 73 20 28 72 65 61 64 2d 63 6f 6e 66 xists (read-conf
bd50: 69 67 20 74 65 73 74 2d 63 6f 6e 66 69 67 66 20 ig test-configf
bd60: 23 66 20 23 66 29 28 6d 61 6b 65 2d 68 61 73 68 #f #f)(make-hash
bd70: 2d 74 61 62 6c 65 29 29 29 29 0a 09 20 3b 3b 20 -table)))).. ;;
bd80: 75 73 65 20 74 68 65 20 6f 70 65 6e 2d 72 75 6e use the open-run
bd90: 2d 63 6c 6f 73 65 20 69 6e 73 74 65 61 64 20 6f -close instead o
bda0: 66 20 70 61 73 73 69 6e 67 20 69 6e 20 64 62 0a f passing in db.
bdb0: 09 20 28 72 75 6e 73 3a 75 70 64 61 74 65 2d 74 . (runs:update-t
bdc0: 65 73 74 5f 6d 65 74 61 20 23 66 20 74 65 73 74 est_meta #f test
bdd0: 2d 6e 61 6d 65 20 74 65 73 74 2d 63 6f 6e 66 29 -name test-conf)
bde0: 29 29 0a 20 20 20 20 20 74 65 73 74 2d 6e 61 6d )). test-nam
bdf0: 65 73 29 29 29 0a 0a 3b 3b 20 54 68 69 73 20 63 es)))..;; This c
be00: 6f 75 6c 64 20 70 72 6f 62 61 62 6c 79 20 62 65 ould probably be
be10: 20 72 65 66 61 63 74 6f 72 65 64 20 69 6e 74 6f refactored into
be20: 20 6f 6e 65 20 63 6f 6d 70 6c 65 78 20 71 75 65 one complex que
be30: 72 79 20 2e 2e 2e 0a 28 64 65 66 69 6e 65 20 28 ry ....(define (
be40: 72 75 6e 73 3a 72 6f 6c 6c 75 70 2d 72 75 6e 20 runs:rollup-run
be50: 6b 65 79 73 20 6b 65 79 76 61 6c 6c 73 74 20 72 keys keyvallst r
be60: 75 6e 6e 61 6d 65 20 75 73 65 72 29 20 3b 3b 20 unname user) ;;
be70: 77 61 73 20 74 61 72 67 65 74 2c 20 6e 6f 77 20 was target, now
be80: 6b 65 79 76 61 6c 6c 73 74 0a 20 20 28 64 65 62 keyvallst. (deb
be90: 75 67 3a 70 72 69 6e 74 20 34 20 22 72 75 6e 73 ug:print 4 "runs
bea0: 3a 72 6f 6c 6c 75 70 2d 72 75 6e 2c 20 6b 65 79 :rollup-run, key
beb0: 73 3a 20 22 20 6b 65 79 73 20 22 20 6b 65 79 76 s: " keys " keyv
bec0: 61 6c 6c 73 74 3a 20 22 20 6b 65 79 76 61 6c 6c allst: " keyvall
bed0: 73 74 20 22 20 3a 72 75 6e 6e 61 6d 65 20 22 20 st " :runname "
bee0: 72 75 6e 6e 61 6d 65 20 22 20 75 73 65 72 3a 20 runname " user:
bef0: 22 20 75 73 65 72 29 0a 20 20 28 6c 65 74 2a 20 " user). (let*
bf00: 28 28 64 62 20 20 20 20 20 20 20 20 20 20 20 20 ((db
bf10: 20 20 23 66 29 20 3b 3b 20 28 6b 65 79 76 61 6c #f) ;; (keyval
bf20: 6c 6c 73 74 20 20 20 20 20 20 28 6b 65 79 73 3a llst (keys:
bf30: 74 61 72 67 65 74 2d 3e 6b 65 79 76 61 6c 20 6b target->keyval k
bf40: 65 79 73 20 74 61 72 67 65 74 29 29 0a 09 20 28 eys target)).. (
bf50: 6e 65 77 2d 72 75 6e 2d 69 64 20 20 20 20 20 20 new-run-id
bf60: 28 63 64 62 3a 72 65 6d 6f 74 65 2d 72 75 6e 20 (cdb:remote-run
bf70: 64 62 3a 72 65 67 69 73 74 65 72 2d 72 75 6e 20 db:register-run
bf80: 23 66 20 6b 65 79 73 20 6b 65 79 76 61 6c 6c 73 #f keys keyvalls
bf90: 74 20 72 75 6e 6e 61 6d 65 20 22 6e 65 77 22 20 t runname "new"
bfa0: 22 6e 2f 61 22 20 75 73 65 72 29 29 0a 09 20 28 "n/a" user)).. (
bfb0: 70 72 65 76 2d 74 65 73 74 73 20 20 20 20 20 20 prev-tests
bfc0: 28 6f 70 65 6e 2d 72 75 6e 2d 63 6c 6f 73 65 20 (open-run-close
bfd0: 74 65 73 74 3a 67 65 74 2d 6d 61 74 63 68 69 6e test:get-matchin
bfe0: 67 2d 70 72 65 76 69 6f 75 73 2d 74 65 73 74 2d g-previous-test-
bff0: 72 75 6e 2d 72 65 63 6f 72 64 73 20 64 62 20 6e run-records db n
c000: 65 77 2d 72 75 6e 2d 69 64 20 22 25 22 20 22 25 ew-run-id "%" "%
c010: 22 29 29 0a 09 20 28 63 75 72 72 2d 74 65 73 74 ")).. (curr-test
c020: 73 20 20 20 20 20 20 28 6f 70 65 6e 2d 72 75 6e s (open-run
c030: 2d 63 6c 6f 73 65 20 64 62 3a 67 65 74 2d 74 65 -close db:get-te
c040: 73 74 73 2d 66 6f 72 2d 72 75 6e 20 64 62 20 6e sts-for-run db n
c050: 65 77 2d 72 75 6e 2d 69 64 20 22 25 2f 25 22 20 ew-run-id "%/%"
c060: 27 28 29 20 27 28 29 29 29 0a 09 20 28 63 75 72 '() '())).. (cur
c070: 72 2d 74 65 73 74 73 2d 68 61 73 68 20 28 6d 61 r-tests-hash (ma
c080: 6b 65 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 29 ke-hash-table)))
c090: 0a 20 20 20 20 28 6f 70 65 6e 2d 72 75 6e 2d 63 . (open-run-c
c0a0: 6c 6f 73 65 20 64 62 3a 75 70 64 61 74 65 2d 72 lose db:update-r
c0b0: 75 6e 2d 65 76 65 6e 74 5f 74 69 6d 65 20 64 62 un-event_time db
c0c0: 20 6e 65 77 2d 72 75 6e 2d 69 64 29 0a 20 20 20 new-run-id).
c0d0: 20 3b 3b 20 69 6e 64 65 78 20 74 68 65 20 61 6c ;; index the al
c0e0: 72 65 61 64 79 20 73 61 76 65 64 20 74 65 73 74 ready saved test
c0f0: 73 20 62 79 20 74 65 73 74 6e 61 6d 65 20 61 6e s by testname an
c100: 64 20 69 74 65 6d 64 61 74 20 69 6e 20 63 75 72 d itemdat in cur
c110: 72 2d 74 65 73 74 73 2d 68 61 73 68 0a 20 20 20 r-tests-hash.
c120: 20 28 66 6f 72 2d 65 61 63 68 0a 20 20 20 20 20 (for-each.
c130: 28 6c 61 6d 62 64 61 20 28 74 65 73 74 64 61 74 (lambda (testdat
c140: 29 0a 20 20 20 20 20 20 20 28 6c 65 74 2a 20 28 ). (let* (
c150: 28 74 65 73 74 6e 61 6d 65 20 20 28 64 62 3a 74 (testname (db:t
c160: 65 73 74 2d 67 65 74 2d 74 65 73 74 6e 61 6d 65 est-get-testname
c170: 20 74 65 73 74 64 61 74 29 29 0a 09 20 20 20 20 testdat))..
c180: 20 20 28 69 74 65 6d 2d 70 61 74 68 20 28 64 62 (item-path (db
c190: 3a 74 65 73 74 2d 67 65 74 2d 69 74 65 6d 2d 70 :test-get-item-p
c1a0: 61 74 68 20 74 65 73 74 64 61 74 29 29 0a 09 20 ath testdat))..
c1b0: 20 20 20 20 20 28 66 75 6c 6c 2d 6e 61 6d 65 20 (full-name
c1c0: 28 63 6f 6e 63 20 74 65 73 74 6e 61 6d 65 20 22 (conc testname "
c1d0: 2f 22 20 69 74 65 6d 2d 70 61 74 68 29 29 29 0a /" item-path))).
c1e0: 09 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 . (hash-table-se
c1f0: 74 21 20 63 75 72 72 2d 74 65 73 74 73 2d 68 61 t! curr-tests-ha
c200: 73 68 20 66 75 6c 6c 2d 6e 61 6d 65 20 74 65 73 sh full-name tes
c210: 74 64 61 74 29 29 29 0a 20 20 20 20 20 63 75 72 tdat))). cur
c220: 72 2d 74 65 73 74 73 29 0a 20 20 20 20 3b 3b 20 r-tests). ;;
c230: 4e 4f 50 45 3a 20 4e 6f 6e 2d 6f 70 74 69 6d 61 NOPE: Non-optima
c240: 6c 20 61 70 70 72 6f 61 63 68 2e 20 54 72 79 20 l approach. Try
c250: 74 68 69 73 20 69 6e 73 74 65 61 64 2e 0a 20 20 this instead..
c260: 20 20 3b 3b 20 20 20 31 2e 20 74 65 73 74 73 20 ;; 1. tests
c270: 61 72 65 20 72 65 63 65 69 76 65 64 20 69 6e 20 are received in
c280: 61 20 6c 69 73 74 2c 20 6d 6f 73 74 20 72 65 63 a list, most rec
c290: 65 6e 74 20 66 69 72 73 74 0a 20 20 20 20 3b 3b ent first. ;;
c2a0: 20 20 20 32 2e 20 72 65 70 6c 61 63 65 20 74 68 2. replace th
c2b0: 65 20 72 6f 6c 6c 75 70 20 74 65 73 74 20 77 69 e rollup test wi
c2c0: 74 68 20 74 68 65 20 6e 65 77 20 2a 61 6c 77 61 th the new *alwa
c2d0: 79 73 2a 0a 20 20 20 20 28 66 6f 72 2d 65 61 63 ys*. (for-eac
c2e0: 68 20 0a 20 20 20 20 20 28 6c 61 6d 62 64 61 20 h . (lambda
c2f0: 28 74 65 73 74 64 61 74 29 0a 20 20 20 20 20 20 (testdat).
c300: 20 28 6c 65 74 2a 20 28 28 74 65 73 74 6e 61 6d (let* ((testnam
c310: 65 20 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d e (db:test-get-
c320: 74 65 73 74 6e 61 6d 65 20 74 65 73 74 64 61 74 testname testdat
c330: 29 29 0a 09 20 20 20 20 20 20 28 69 74 65 6d 2d )).. (item-
c340: 70 61 74 68 20 28 64 62 3a 74 65 73 74 2d 67 65 path (db:test-ge
c350: 74 2d 69 74 65 6d 2d 70 61 74 68 20 74 65 73 74 t-item-path test
c360: 64 61 74 29 29 0a 09 20 20 20 20 20 20 28 66 75 dat)).. (fu
c370: 6c 6c 2d 6e 61 6d 65 20 28 63 6f 6e 63 20 74 65 ll-name (conc te
c380: 73 74 6e 61 6d 65 20 22 2f 22 20 69 74 65 6d 2d stname "/" item-
c390: 70 61 74 68 29 29 0a 09 20 20 20 20 20 20 28 70 path)).. (p
c3a0: 72 65 76 2d 74 65 73 74 2d 64 61 74 20 28 68 61 rev-test-dat (ha
c3b0: 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 sh-table-ref/def
c3c0: 61 75 6c 74 20 63 75 72 72 2d 74 65 73 74 73 2d ault curr-tests-
c3d0: 68 61 73 68 20 66 75 6c 6c 2d 6e 61 6d 65 20 23 hash full-name #
c3e0: 66 29 29 0a 09 20 20 20 20 20 20 28 74 65 73 74 f)).. (test
c3f0: 2d 73 74 65 70 73 20 20 20 20 20 20 28 6f 70 65 -steps (ope
c400: 6e 2d 72 75 6e 2d 63 6c 6f 73 65 20 64 62 3a 67 n-run-close db:g
c410: 65 74 2d 73 74 65 70 73 2d 66 6f 72 2d 74 65 73 et-steps-for-tes
c420: 74 20 64 62 20 28 64 62 3a 74 65 73 74 2d 67 65 t db (db:test-ge
c430: 74 2d 69 64 20 74 65 73 74 64 61 74 29 29 29 0a t-id testdat))).
c440: 09 20 20 20 20 20 20 28 6e 65 77 2d 74 65 73 74 . (new-test
c450: 2d 72 65 63 6f 72 64 20 23 66 29 29 0a 09 20 3b -record #f)).. ;
c460: 3b 20 72 65 70 6c 61 63 65 20 74 68 65 73 65 20 ; replace these
c470: 77 69 74 68 20 69 6e 73 65 72 74 20 2e 2e 2e 20 with insert ...
c480: 73 65 6c 65 63 74 0a 09 20 28 61 70 70 6c 79 20 select.. (apply
c490: 73 71 6c 69 74 65 33 3a 65 78 65 63 75 74 65 20 sqlite3:execute
c4a0: 0a 09 09 64 62 20 0a 09 09 28 63 6f 6e 63 20 22 ...db ...(conc "
c4b0: 49 4e 53 45 52 54 20 4f 52 20 52 45 50 4c 41 43 INSERT OR REPLAC
c4c0: 45 20 49 4e 54 4f 20 74 65 73 74 73 20 28 72 75 E INTO tests (ru
c4d0: 6e 5f 69 64 2c 74 65 73 74 6e 61 6d 65 2c 73 74 n_id,testname,st
c4e0: 61 74 65 2c 73 74 61 74 75 73 2c 65 76 65 6e 74 ate,status,event
c4f0: 5f 74 69 6d 65 2c 68 6f 73 74 2c 63 70 75 6c 6f _time,host,cpulo
c500: 61 64 2c 64 69 73 6b 66 72 65 65 2c 75 6e 61 6d ad,diskfree,unam
c510: 65 2c 72 75 6e 64 69 72 2c 69 74 65 6d 5f 70 61 e,rundir,item_pa
c520: 74 68 2c 72 75 6e 5f 64 75 72 61 74 69 6f 6e 2c th,run_duration,
c530: 66 69 6e 61 6c 5f 6c 6f 67 66 2c 63 6f 6d 6d 65 final_logf,comme
c540: 6e 74 29 20 22 0a 09 09 20 20 20 20 20 20 22 56 nt) "... "V
c550: 41 4c 55 45 53 20 28 3f 2c 3f 2c 3f 2c 3f 2c 3f ALUES (?,?,?,?,?
c560: 2c 3f 2c 3f 2c 3f 2c 3f 2c 3f 2c 3f 2c 3f 2c 3f ,?,?,?,?,?,?,?,?
c570: 2c 3f 29 3b 22 29 0a 09 09 6e 65 77 2d 72 75 6e ,?);")...new-run
c580: 2d 69 64 20 28 63 64 64 72 20 28 76 65 63 74 6f -id (cddr (vecto
c590: 72 2d 3e 6c 69 73 74 20 74 65 73 74 64 61 74 29 r->list testdat)
c5a0: 29 29 0a 09 20 28 73 65 74 21 20 6e 65 77 2d 74 )).. (set! new-t
c5b0: 65 73 74 64 61 74 20 28 63 61 72 20 28 6f 70 65 estdat (car (ope
c5c0: 6e 2d 72 75 6e 2d 63 6c 6f 73 65 20 64 62 3a 67 n-run-close db:g
c5d0: 65 74 2d 74 65 73 74 73 2d 66 6f 72 2d 72 75 6e et-tests-for-run
c5e0: 20 64 62 20 6e 65 77 2d 72 75 6e 2d 69 64 20 28 db new-run-id (
c5f0: 63 6f 6e 63 20 74 65 73 74 6e 61 6d 65 20 22 2f conc testname "/
c600: 22 20 69 74 65 6d 2d 70 61 74 68 29 20 27 28 29 " item-path) '()
c610: 20 27 28 29 29 29 29 0a 09 20 28 68 61 73 68 2d '()))).. (hash-
c620: 74 61 62 6c 65 2d 73 65 74 21 20 63 75 72 72 2d table-set! curr-
c630: 74 65 73 74 73 2d 68 61 73 68 20 66 75 6c 6c 2d tests-hash full-
c640: 6e 61 6d 65 20 6e 65 77 2d 74 65 73 74 64 61 74 name new-testdat
c650: 29 20 3b 3b 20 74 68 69 73 20 63 6f 75 6c 64 20 ) ;; this could
c660: 62 65 20 63 6f 6e 66 75 73 69 6e 67 2c 20 77 68 be confusing, wh
c670: 69 63 68 20 72 65 63 6f 72 64 20 73 68 6f 75 6c ich record shoul
c680: 64 20 67 6f 20 69 6e 74 6f 20 74 68 65 20 6c 6f d go into the lo
c690: 6f 6b 75 70 20 74 61 62 6c 65 3f 0a 09 20 3b 3b okup table?.. ;;
c6a0: 20 4e 6f 77 20 64 75 70 6c 69 63 61 74 65 20 74 Now duplicate t
c6b0: 68 65 20 74 65 73 74 20 73 74 65 70 73 0a 09 20 he test steps..
c6c0: 28 64 65 62 75 67 3a 70 72 69 6e 74 20 34 20 22 (debug:print 4 "
c6d0: 43 6f 70 79 69 6e 67 20 72 65 63 6f 72 64 73 20 Copying records
c6e0: 69 6e 20 74 65 73 74 5f 73 74 65 70 73 20 66 72 in test_steps fr
c6f0: 6f 6d 20 74 65 73 74 5f 69 64 3d 22 20 28 64 62 om test_id=" (db
c700: 3a 74 65 73 74 2d 67 65 74 2d 69 64 20 74 65 73 :test-get-id tes
c710: 74 64 61 74 29 20 22 20 74 6f 20 22 20 28 64 62 tdat) " to " (db
c720: 3a 74 65 73 74 2d 67 65 74 2d 69 64 20 6e 65 77 :test-get-id new
c730: 2d 74 65 73 74 64 61 74 29 29 0a 09 20 28 6f 70 -testdat)).. (op
c740: 65 6e 2d 72 75 6e 2d 63 6c 6f 73 65 20 0a 09 20 en-run-close ..
c750: 20 28 6c 61 6d 62 64 61 20 28 29 0a 09 20 20 20 (lambda ()..
c760: 20 28 73 71 6c 69 74 65 33 3a 65 78 65 63 75 74 (sqlite3:execut
c770: 65 20 0a 09 20 20 20 20 20 64 62 20 0a 09 20 20 e .. db ..
c780: 20 20 20 28 63 6f 6e 63 20 22 49 4e 53 45 52 54 (conc "INSERT
c790: 20 4f 52 20 52 45 50 4c 41 43 45 20 49 4e 54 4f OR REPLACE INTO
c7a0: 20 74 65 73 74 5f 73 74 65 70 73 20 28 74 65 73 test_steps (tes
c7b0: 74 5f 69 64 2c 73 74 65 70 6e 61 6d 65 2c 73 74 t_id,stepname,st
c7c0: 61 74 65 2c 73 74 61 74 75 73 2c 65 76 65 6e 74 ate,status,event
c7d0: 5f 74 69 6d 65 2c 63 6f 6d 6d 65 6e 74 29 20 22 _time,comment) "
c7e0: 0a 09 09 20 20 20 22 53 45 4c 45 43 54 20 22 20 ... "SELECT "
c7f0: 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 69 64 20 (db:test-get-id
c800: 6e 65 77 2d 74 65 73 74 64 61 74 29 20 22 2c 73 new-testdat) ",s
c810: 74 65 70 6e 61 6d 65 2c 73 74 61 74 65 2c 73 74 tepname,state,st
c820: 61 74 75 73 2c 65 76 65 6e 74 5f 74 69 6d 65 2c atus,event_time,
c830: 63 6f 6d 6d 65 6e 74 20 46 52 4f 4d 20 74 65 73 comment FROM tes
c840: 74 5f 73 74 65 70 73 20 57 48 45 52 45 20 74 65 t_steps WHERE te
c850: 73 74 5f 69 64 3d 3f 3b 22 29 0a 09 20 20 20 20 st_id=?;")..
c860: 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 69 64 (db:test-get-id
c870: 20 74 65 73 74 64 61 74 29 29 0a 09 20 20 20 20 testdat))..
c880: 3b 3b 20 4e 6f 77 20 64 75 70 6c 69 63 61 74 65 ;; Now duplicate
c890: 20 74 68 65 20 74 65 73 74 20 64 61 74 61 0a 09 the test data..
c8a0: 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 (debug:print
c8b0: 20 34 20 22 43 6f 70 79 69 6e 67 20 72 65 63 6f 4 "Copying reco
c8c0: 72 64 73 20 69 6e 20 74 65 73 74 5f 64 61 74 61 rds in test_data
c8d0: 20 66 72 6f 6d 20 74 65 73 74 5f 69 64 3d 22 20 from test_id="
c8e0: 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 69 64 20 (db:test-get-id
c8f0: 74 65 73 74 64 61 74 29 20 22 20 74 6f 20 22 20 testdat) " to "
c900: 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 69 64 20 (db:test-get-id
c910: 6e 65 77 2d 74 65 73 74 64 61 74 29 29 0a 09 20 new-testdat))..
c920: 20 20 20 28 73 71 6c 69 74 65 33 3a 65 78 65 63 (sqlite3:exec
c930: 75 74 65 20 0a 09 20 20 20 20 20 64 62 20 0a 09 ute .. db ..
c940: 20 20 20 20 20 28 63 6f 6e 63 20 22 49 4e 53 45 (conc "INSE
c950: 52 54 20 4f 52 20 52 45 50 4c 41 43 45 20 49 4e RT OR REPLACE IN
c960: 54 4f 20 74 65 73 74 5f 64 61 74 61 20 28 74 65 TO test_data (te
c970: 73 74 5f 69 64 2c 63 61 74 65 67 6f 72 79 2c 76 st_id,category,v
c980: 61 72 69 61 62 6c 65 2c 76 61 6c 75 65 2c 65 78 ariable,value,ex
c990: 70 65 63 74 65 64 2c 74 6f 6c 2c 75 6e 69 74 73 pected,tol,units
c9a0: 2c 63 6f 6d 6d 65 6e 74 29 20 22 0a 09 09 20 20 ,comment) "...
c9b0: 20 22 53 45 4c 45 43 54 20 22 20 28 64 62 3a 74 "SELECT " (db:t
c9c0: 65 73 74 2d 67 65 74 2d 69 64 20 6e 65 77 2d 74 est-get-id new-t
c9d0: 65 73 74 64 61 74 29 20 22 2c 63 61 74 65 67 6f estdat) ",catego
c9e0: 72 79 2c 76 61 72 69 61 62 6c 65 2c 76 61 6c 75 ry,variable,valu
c9f0: 65 2c 65 78 70 65 63 74 65 64 2c 74 6f 6c 2c 75 e,expected,tol,u
ca00: 6e 69 74 73 2c 63 6f 6d 6d 65 6e 74 20 46 52 4f nits,comment FRO
ca10: 4d 20 74 65 73 74 5f 64 61 74 61 20 57 48 45 52 M test_data WHER
ca20: 45 20 74 65 73 74 5f 69 64 3d 3f 3b 22 29 0a 09 E test_id=?;")..
ca30: 20 20 20 20 20 28 64 62 3a 74 65 73 74 2d 67 65 (db:test-ge
ca40: 74 2d 69 64 20 74 65 73 74 64 61 74 29 29 29 29 t-id testdat))))
ca50: 0a 09 20 29 29 0a 20 20 20 20 20 70 72 65 76 2d .. )). prev-
ca60: 74 65 73 74 73 29 29 29 0a 09 20 0a 20 20 20 20 tests))).. .
ca70: 20 0a .