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 28 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 20 74 65 73 74 2d 72 65 63 6f 72 64 29 sts test-record)
0fe0: 0a 20 20 28 6c 65 74 2a 20 28 28 74 63 6f 6e 66 . (let* ((tconf
0ff0: 69 67 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ig
1000: 20 20 20 28 74 65 73 74 73 3a 74 65 73 74 71 75 (tests:testqu
1010: 65 75 65 2d 67 65 74 2d 74 65 73 74 63 6f 6e 66 eue-get-testconf
1020: 69 67 20 74 65 73 74 2d 72 65 63 6f 72 64 29 29 ig test-record))
1030: 0a 09 20 28 6a 6f 62 67 72 6f 75 70 20 20 20 20 .. (jobgroup
1040: 20 20 20 20 20 20 20 20 20 20 20 20 28 63 6f 6e (con
1050: 66 69 67 2d 6c 6f 6f 6b 75 70 20 74 63 6f 6e 66 fig-lookup tconf
1060: 69 67 20 22 72 65 71 75 69 72 65 6d 65 6e 74 73 ig "requirements
1070: 22 20 22 6a 6f 62 67 72 6f 75 70 22 29 29 0a 09 " "jobgroup"))..
1080: 20 28 6e 75 6d 2d 72 75 6e 6e 69 6e 67 20 20 20 (num-running
1090: 20 20 20 20 20 20 20 20 20 20 28 63 64 62 3a 72 (cdb:r
10a0: 65 6d 6f 74 65 2d 72 75 6e 20 64 62 3a 67 65 74 emote-run db:get
10b0: 2d 63 6f 75 6e 74 2d 74 65 73 74 73 2d 72 75 6e -count-tests-run
10c0: 6e 69 6e 67 20 23 66 29 29 0a 09 20 28 6e 75 6d ning #f)).. (num
10d0: 2d 72 75 6e 6e 69 6e 67 2d 69 6e 2d 6a 6f 62 67 -running-in-jobg
10e0: 72 6f 75 70 20 28 63 64 62 3a 72 65 6d 6f 74 65 roup (cdb:remote
10f0: 2d 72 75 6e 20 64 62 3a 67 65 74 2d 63 6f 75 6e -run db:get-coun
1100: 74 2d 74 65 73 74 73 2d 72 75 6e 6e 69 6e 67 2d t-tests-running-
1110: 69 6e 2d 6a 6f 62 67 72 6f 75 70 20 23 66 20 6a in-jobgroup #f j
1120: 6f 62 67 72 6f 75 70 29 29 0a 09 20 28 6d 61 78 obgroup)).. (max
1130: 2d 63 6f 6e 63 75 72 72 65 6e 74 2d 6a 6f 62 73 -concurrent-jobs
1140: 20 20 20 20 20 28 6c 65 74 20 28 28 6d 63 6a 20 (let ((mcj
1150: 28 63 6f 6e 66 69 67 2d 6c 6f 6f 6b 75 70 20 2a (config-lookup *
1160: 63 6f 6e 66 69 67 64 61 74 2a 20 22 73 65 74 75 configdat* "setu
1170: 70 22 20 20 20 20 20 22 6d 61 78 5f 63 6f 6e 63 p" "max_conc
1180: 75 72 72 65 6e 74 5f 6a 6f 62 73 22 29 29 29 0a urrent_jobs"))).
1190: 09 09 09 09 20 20 20 20 28 69 66 20 28 61 6e 64 .... (if (and
11a0: 20 6d 63 6a 20 28 73 74 72 69 6e 67 2d 3e 6e 75 mcj (string->nu
11b0: 6d 62 65 72 20 6d 63 6a 29 29 0a 09 09 09 09 09 mber mcj))......
11c0: 28 73 74 72 69 6e 67 2d 3e 6e 75 6d 62 65 72 20 (string->number
11d0: 6d 63 6a 29 0a 09 09 09 09 09 31 29 29 29 0a 09 mcj)......1)))..
11e0: 20 28 6a 6f 62 2d 67 72 6f 75 70 2d 6c 69 6d 69 (job-group-limi
11f0: 74 20 20 20 20 20 20 20 20 20 28 63 6f 6e 66 69 t (confi
1200: 67 2d 6c 6f 6f 6b 75 70 20 2a 63 6f 6e 66 69 67 g-lookup *config
1210: 64 61 74 2a 20 22 6a 6f 62 67 72 6f 75 70 73 22 dat* "jobgroups"
1220: 20 6a 6f 62 67 72 6f 75 70 29 29 29 0a 20 20 20 jobgroup))).
1230: 20 28 69 66 20 28 6e 6f 74 20 28 65 71 3f 20 2a (if (not (eq? *
1240: 6c 61 73 74 2d 6e 75 6d 2d 72 75 6e 6e 69 6e 67 last-num-running
1250: 2d 74 65 73 74 73 2a 20 6e 75 6d 2d 72 75 6e 6e -tests* num-runn
1260: 69 6e 67 29 29 0a 09 28 62 65 67 69 6e 0a 09 20 ing))..(begin..
1270: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 32 20 (debug:print 2
1280: 22 6d 61 78 2d 63 6f 6e 63 75 72 72 65 6e 74 2d "max-concurrent-
1290: 6a 6f 62 73 3a 20 22 20 6d 61 78 2d 63 6f 6e 63 jobs: " max-conc
12a0: 75 72 72 65 6e 74 2d 6a 6f 62 73 20 22 2c 20 6e urrent-jobs ", n
12b0: 75 6d 2d 72 75 6e 6e 69 6e 67 3a 20 22 20 6e 75 um-running: " nu
12c0: 6d 2d 72 75 6e 6e 69 6e 67 29 0a 09 20 20 28 73 m-running).. (s
12d0: 65 74 21 20 2a 6c 61 73 74 2d 6e 75 6d 2d 72 75 et! *last-num-ru
12e0: 6e 6e 69 6e 67 2d 74 65 73 74 73 2a 20 6e 75 6d nning-tests* num
12f0: 2d 72 75 6e 6e 69 6e 67 29 29 29 0a 20 20 20 20 -running))).
1300: 28 69 66 20 28 6e 6f 74 20 28 65 71 3f 20 30 20 (if (not (eq? 0
1310: 2a 67 6c 6f 62 61 6c 65 78 69 74 73 74 61 74 75 *globalexitstatu
1320: 73 2a 29 29 0a 09 28 6c 69 73 74 20 23 66 20 6e s*))..(list #f n
1330: 75 6d 2d 72 75 6e 6e 69 6e 67 20 6e 75 6d 2d 72 um-running num-r
1340: 75 6e 6e 69 6e 67 2d 69 6e 2d 6a 6f 62 67 72 6f unning-in-jobgro
1350: 75 70 20 6d 61 78 2d 63 6f 6e 63 75 72 72 65 6e up max-concurren
1360: 74 2d 6a 6f 62 73 20 6a 6f 62 2d 67 72 6f 75 70 t-jobs job-group
1370: 2d 6c 69 6d 69 74 29 0a 09 28 6c 65 74 20 28 28 -limit)..(let ((
1380: 63 61 6e 2d 6e 6f 74 2d 72 75 6e 2d 6d 6f 72 65 can-not-run-more
1390: 20 28 63 6f 6e 64 0a 09 09 09 09 20 3b 3b 20 69 (cond..... ;; i
13a0: 66 20 6d 61 78 2d 63 6f 6e 63 75 72 72 65 6e 74 f max-concurrent
13b0: 2d 6a 6f 62 73 20 69 73 20 73 65 74 20 61 6e 64 -jobs is set and
13c0: 20 74 68 65 20 6e 75 6d 62 65 72 20 72 75 6e 6e the number runn
13d0: 69 6e 67 20 69 73 20 67 72 65 61 74 65 72 20 0a ing is greater .
13e0: 09 09 09 09 20 3b 3b 20 74 68 61 6e 20 69 74 20 .... ;; than it
13f0: 74 68 61 6e 20 63 61 6e 6e 6f 74 20 72 75 6e 20 than cannot run
1400: 6d 6f 72 65 20 6a 6f 62 73 0a 09 09 09 09 20 28 more jobs..... (
1410: 28 61 6e 64 20 6d 61 78 2d 63 6f 6e 63 75 72 72 (and max-concurr
1420: 65 6e 74 2d 6a 6f 62 73 20 28 3e 3d 20 6e 75 6d ent-jobs (>= num
1430: 2d 72 75 6e 6e 69 6e 67 20 6d 61 78 2d 63 6f 6e -running max-con
1440: 63 75 72 72 65 6e 74 2d 6a 6f 62 73 29 29 0a 09 current-jobs))..
1450: 09 09 09 20 20 28 64 65 62 75 67 3a 70 72 69 6e ... (debug:prin
1460: 74 20 30 20 22 57 41 52 4e 49 4e 47 3a 20 4d 61 t 0 "WARNING: Ma
1470: 78 20 72 75 6e 6e 69 6e 67 20 6a 6f 62 73 20 65 x running jobs e
1480: 78 63 65 65 64 65 64 2c 20 63 75 72 72 65 6e 74 xceeded, current
1490: 20 6e 75 6d 62 65 72 20 72 75 6e 6e 69 6e 67 3a number running:
14a0: 20 22 20 6e 75 6d 2d 72 75 6e 6e 69 6e 67 20 0a " num-running .
14b0: 09 09 09 09 09 20 20 20 20 20 20 20 22 2c 20 6d ..... ", m
14c0: 61 78 5f 63 6f 6e 63 75 72 72 65 6e 74 5f 6a 6f ax_concurrent_jo
14d0: 62 73 3a 20 22 20 6d 61 78 2d 63 6f 6e 63 75 72 bs: " max-concur
14e0: 72 65 6e 74 2d 6a 6f 62 73 29 0a 09 09 09 09 20 rent-jobs).....
14f0: 20 23 74 29 0a 09 09 09 09 20 3b 3b 20 69 66 20 #t)..... ;; if
1500: 6a 6f 62 2d 67 72 6f 75 70 2d 6c 69 6d 69 74 20 job-group-limit
1510: 69 73 20 73 65 74 20 61 6e 64 20 6e 75 6d 62 65 is set and numbe
1520: 72 20 6f 66 20 6a 6f 62 73 20 69 6e 20 74 68 65 r of jobs in the
1530: 20 67 72 6f 75 70 20 69 73 20 67 72 65 61 74 65 group is greate
1540: 72 0a 09 09 09 09 20 3b 3b 20 74 68 61 6e 20 74 r..... ;; than t
1550: 68 65 20 6c 69 6d 69 74 20 74 68 65 6e 20 63 61 he limit then ca
1560: 6e 6e 6f 74 20 72 75 6e 20 6d 6f 72 65 20 6a 6f nnot run more jo
1570: 62 73 20 6f 66 20 74 68 69 73 20 6b 69 6e 64 0a bs of this kind.
1580: 09 09 09 09 20 28 28 61 6e 64 20 6a 6f 62 2d 67 .... ((and job-g
1590: 72 6f 75 70 2d 6c 69 6d 69 74 0a 09 09 09 09 20 roup-limit.....
15a0: 20 20 20 20 20 20 28 3e 3d 20 6e 75 6d 2d 72 75 (>= num-ru
15b0: 6e 6e 69 6e 67 2d 69 6e 2d 6a 6f 62 67 72 6f 75 nning-in-jobgrou
15c0: 70 20 6a 6f 62 2d 67 72 6f 75 70 2d 6c 69 6d 69 p job-group-limi
15d0: 74 29 29 0a 09 09 09 09 20 20 28 64 65 62 75 67 t))..... (debug
15e0: 3a 70 72 69 6e 74 20 31 20 22 57 41 52 4e 49 4e :print 1 "WARNIN
15f0: 47 3a 20 6e 75 6d 62 65 72 20 6f 66 20 6a 6f 62 G: number of job
1600: 73 20 22 20 6e 75 6d 2d 72 75 6e 6e 69 6e 67 2d s " num-running-
1610: 69 6e 2d 6a 6f 62 67 72 6f 75 70 20 0a 09 09 09 in-jobgroup ....
1620: 09 09 20 20 20 20 20 20 20 22 20 69 6e 20 22 20 .. " in "
1630: 6a 6f 62 67 72 6f 75 70 20 22 20 65 78 63 65 65 jobgroup " excee
1640: 64 65 64 2c 20 77 69 6c 6c 20 6e 6f 74 20 72 75 ded, will not ru
1650: 6e 20 22 20 28 74 65 73 74 73 3a 74 65 73 74 71 n " (tests:testq
1660: 75 65 75 65 2d 67 65 74 2d 74 65 73 74 6e 61 6d ueue-get-testnam
1670: 65 20 74 65 73 74 2d 72 65 63 6f 72 64 29 29 0a e test-record)).
1680: 09 09 09 09 20 20 23 74 29 0a 09 09 09 09 20 28 .... #t)..... (
1690: 65 6c 73 65 20 23 66 29 29 29 29 0a 09 20 20 28 else #f)))).. (
16a0: 6c 69 73 74 20 28 6e 6f 74 20 63 61 6e 2d 6e 6f list (not can-no
16b0: 74 2d 72 75 6e 2d 6d 6f 72 65 29 20 6e 75 6d 2d t-run-more) num-
16c0: 72 75 6e 6e 69 6e 67 20 6e 75 6d 2d 72 75 6e 6e running num-runn
16d0: 69 6e 67 2d 69 6e 2d 6a 6f 62 67 72 6f 75 70 20 ing-in-jobgroup
16e0: 6d 61 78 2d 63 6f 6e 63 75 72 72 65 6e 74 2d 6a max-concurrent-j
16f0: 6f 62 73 20 6a 6f 62 2d 67 72 6f 75 70 2d 6c 69 obs job-group-li
1700: 6d 69 74 29 29 29 29 29 0a 0a 3b 3b 3d 3d 3d 3d mit)))))..;;====
1710: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1720: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1730: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1740: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1750: 3d 3d 0a 3b 3b 20 4e 65 77 20 6d 65 74 68 6f 64 ==.;; New method
1760: 6f 6c 6f 67 79 2e 20 54 68 65 73 65 20 72 6f 75 ology. These rou
1770: 74 69 6e 65 73 20 77 69 6c 6c 20 72 65 70 6c 61 tines will repla
1780: 63 65 20 74 68 65 20 61 62 6f 76 65 20 69 6e 20 ce the above in
1790: 74 69 6d 65 2e 20 46 6f 72 0a 3b 3b 20 6e 6f 77 time. For.;; now
17a0: 20 74 68 65 20 63 6f 64 65 20 69 73 20 64 75 70 the code is dup
17b0: 6c 69 63 61 74 65 64 2e 20 54 68 69 73 20 73 74 licated. This st
17c0: 75 66 66 20 69 73 20 69 6e 69 74 69 61 6c 6c 79 uff is initially
17d0: 20 75 73 65 64 20 69 6e 20 74 68 65 20 6d 6f 6e used in the mon
17e0: 69 74 6f 72 0a 3b 3b 20 62 61 73 65 64 20 63 6f itor.;; based co
17f0: 64 65 2e 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d de..;;==========
1800: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1810: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1820: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1830: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 3b 3b ============..;;
1840: 20 72 65 67 69 73 74 65 72 20 61 20 74 65 73 74 register a test
1850: 20 72 75 6e 20 77 69 74 68 20 74 68 65 20 64 62 run with the db
1860: 0a 28 64 65 66 69 6e 65 20 28 72 75 6e 73 3a 72 .(define (runs:r
1870: 65 67 69 73 74 65 72 2d 72 75 6e 20 64 62 20 6b egister-run db k
1880: 65 79 73 20 6b 65 79 76 61 6c 6c 73 74 20 72 75 eys keyvallst ru
1890: 6e 6e 61 6d 65 20 73 74 61 74 65 20 73 74 61 74 nname state stat
18a0: 75 73 20 75 73 65 72 29 0a 20 20 28 64 65 62 75 us user). (debu
18b0: 67 3a 70 72 69 6e 74 20 33 20 22 72 75 6e 73 3a g:print 3 "runs:
18c0: 72 65 67 69 73 74 65 72 2d 72 75 6e 2c 20 6b 65 register-run, ke
18d0: 79 73 3a 20 22 20 6b 65 79 73 20 22 20 6b 65 79 ys: " keys " key
18e0: 76 61 6c 6c 73 74 3a 20 22 20 6b 65 79 76 61 6c vallst: " keyval
18f0: 6c 73 74 20 22 20 72 75 6e 6e 61 6d 65 3a 20 22 lst " runname: "
1900: 20 72 75 6e 6e 61 6d 65 20 22 20 73 74 61 74 65 runname " state
1910: 3a 20 22 20 73 74 61 74 65 20 22 20 73 74 61 74 : " state " stat
1920: 75 73 3a 20 22 20 73 74 61 74 75 73 20 22 20 75 us: " status " u
1930: 73 65 72 3a 20 22 20 75 73 65 72 29 0a 20 20 28 ser: " user). (
1940: 6c 65 74 2a 20 28 28 6b 65 79 73 74 72 20 20 20 let* ((keystr
1950: 20 28 6b 65 79 73 2d 3e 6b 65 79 73 74 72 20 6b (keys->keystr k
1960: 65 79 73 29 29 0a 09 20 28 63 6f 6d 6d 61 20 20 eys)).. (comma
1970: 20 20 20 28 69 66 20 28 3e 20 28 6c 65 6e 67 74 (if (> (lengt
1980: 68 20 6b 65 79 73 29 20 30 29 20 22 2c 22 20 22 h keys) 0) "," "
1990: 22 29 29 0a 09 20 28 61 6e 64 73 74 72 20 20 20 ")).. (andstr
19a0: 20 28 69 66 20 28 3e 20 28 6c 65 6e 67 74 68 20 (if (> (length
19b0: 6b 65 79 73 29 20 30 29 20 22 20 41 4e 44 20 22 keys) 0) " AND "
19c0: 20 22 22 29 29 0a 09 20 28 76 61 6c 73 6c 6f 74 "")).. (valslot
19d0: 73 20 20 28 6b 65 79 73 2d 3e 76 61 6c 73 6c 6f s (keys->valslo
19e0: 74 73 20 6b 65 79 73 29 29 20 3b 3b 20 3f 2c 3f ts keys)) ;; ?,?
19f0: 2c 3f 20 2e 2e 2e 0a 09 20 28 6b 65 79 76 61 6c ,? ..... (keyval
1a00: 73 20 20 20 28 6d 61 70 20 63 61 64 72 20 6b 65 s (map cadr ke
1a10: 79 76 61 6c 6c 73 74 29 29 0a 09 20 28 61 6c 6c yvallst)).. (all
1a20: 76 61 6c 73 20 20 20 28 61 70 70 65 6e 64 20 28 vals (append (
1a30: 6c 69 73 74 20 72 75 6e 6e 61 6d 65 20 73 74 61 list runname sta
1a40: 74 65 20 73 74 61 74 75 73 20 75 73 65 72 29 20 te status user)
1a50: 6b 65 79 76 61 6c 73 29 29 0a 09 20 28 71 72 79 keyvals)).. (qry
1a60: 76 61 6c 73 20 20 20 28 61 70 70 65 6e 64 20 28 vals (append (
1a70: 6c 69 73 74 20 72 75 6e 6e 61 6d 65 29 20 6b 65 list runname) ke
1a80: 79 76 61 6c 73 29 29 0a 09 20 28 6b 65 79 3d 3f yvals)).. (key=?
1a90: 73 74 72 20 20 28 73 74 72 69 6e 67 2d 69 6e 74 str (string-int
1aa0: 65 72 73 70 65 72 73 65 20 28 6d 61 70 20 28 6c ersperse (map (l
1ab0: 61 6d 62 64 61 20 28 6b 29 28 63 6f 6e 63 20 28 ambda (k)(conc (
1ac0: 6b 65 79 3a 67 65 74 2d 66 69 65 6c 64 6e 61 6d key:get-fieldnam
1ad0: 65 20 6b 29 20 22 3d 3f 22 29 29 20 6b 65 79 73 e k) "=?")) keys
1ae0: 29 20 22 20 41 4e 44 20 22 29 29 29 0a 20 20 20 ) " AND "))).
1af0: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 33 20 (debug:print 3
1b00: 22 6b 65 79 73 3a 20 22 20 6b 65 79 73 20 22 20 "keys: " keys "
1b10: 61 6c 6c 76 61 6c 73 3a 20 22 20 61 6c 6c 76 61 allvals: " allva
1b20: 6c 73 20 22 20 6b 65 79 76 61 6c 73 3a 20 22 20 ls " keyvals: "
1b30: 6b 65 79 76 61 6c 73 29 0a 20 20 20 20 28 64 65 keyvals). (de
1b40: 62 75 67 3a 70 72 69 6e 74 20 32 20 22 4e 4f 54 bug:print 2 "NOT
1b50: 45 3a 20 75 73 69 6e 67 20 74 61 72 67 65 74 20 E: using target
1b60: 22 20 28 73 74 72 69 6e 67 2d 69 6e 74 65 72 73 " (string-inters
1b70: 70 65 72 73 65 20 6b 65 79 76 61 6c 73 20 22 2f perse keyvals "/
1b80: 22 29 20 22 20 66 6f 72 20 74 68 69 73 20 72 75 ") " for this ru
1b90: 6e 22 29 0a 20 20 20 20 28 69 66 20 28 61 6e 64 n"). (if (and
1ba0: 20 72 75 6e 6e 61 6d 65 20 28 6e 75 6c 6c 3f 20 runname (null?
1bb0: 28 66 69 6c 74 65 72 20 28 6c 61 6d 62 64 61 20 (filter (lambda
1bc0: 28 78 29 28 6e 6f 74 20 78 29 29 20 6b 65 79 76 (x)(not x)) keyv
1bd0: 61 6c 73 29 29 29 20 3b 3b 20 74 68 65 72 65 20 als))) ;; there
1be0: 6d 75 73 74 20 62 65 20 61 20 62 65 74 74 65 72 must be a better
1bf0: 20 77 61 79 20 74 6f 20 22 61 70 70 6c 79 20 61 way to "apply a
1c00: 6e 64 22 0a 09 28 6c 65 74 20 28 28 72 65 73 20 nd"..(let ((res
1c10: 23 66 29 29 0a 09 20 20 28 61 70 70 6c 79 20 73 #f)).. (apply s
1c20: 71 6c 69 74 65 33 3a 65 78 65 63 75 74 65 20 64 qlite3:execute d
1c30: 62 20 28 63 6f 6e 63 20 22 49 4e 53 45 52 54 20 b (conc "INSERT
1c40: 4f 52 20 49 47 4e 4f 52 45 20 49 4e 54 4f 20 72 OR IGNORE INTO r
1c50: 75 6e 73 20 28 72 75 6e 6e 61 6d 65 2c 73 74 61 uns (runname,sta
1c60: 74 65 2c 73 74 61 74 75 73 2c 6f 77 6e 65 72 2c te,status,owner,
1c70: 65 76 65 6e 74 5f 74 69 6d 65 22 20 63 6f 6d 6d event_time" comm
1c80: 61 20 6b 65 79 73 74 72 20 22 29 20 56 41 4c 55 a keystr ") VALU
1c90: 45 53 20 28 3f 2c 3f 2c 3f 2c 3f 2c 73 74 72 66 ES (?,?,?,?,strf
1ca0: 74 69 6d 65 28 27 25 73 27 2c 27 6e 6f 77 27 29 time('%s','now')
1cb0: 22 20 63 6f 6d 6d 61 20 76 61 6c 73 6c 6f 74 73 " comma valslots
1cc0: 20 22 29 3b 22 29 0a 09 09 20 61 6c 6c 76 61 6c ");")... allval
1cd0: 73 29 0a 09 20 20 28 61 70 70 6c 79 20 73 71 6c s).. (apply sql
1ce0: 69 74 65 33 3a 66 6f 72 2d 65 61 63 68 2d 72 6f ite3:for-each-ro
1cf0: 77 20 0a 09 20 20 20 28 6c 61 6d 62 64 61 20 28 w .. (lambda (
1d00: 69 64 29 0a 09 20 20 20 20 20 28 73 65 74 21 20 id).. (set!
1d10: 72 65 73 20 69 64 29 29 0a 09 20 20 20 64 62 0a res id)).. db.
1d20: 09 20 20 20 28 6c 65 74 20 28 28 71 72 79 20 28 . (let ((qry (
1d30: 63 6f 6e 63 20 22 53 45 4c 45 43 54 20 69 64 20 conc "SELECT id
1d40: 46 52 4f 4d 20 72 75 6e 73 20 57 48 45 52 45 20 FROM runs WHERE
1d50: 28 72 75 6e 6e 61 6d 65 3d 3f 20 22 20 61 6e 64 (runname=? " and
1d60: 73 74 72 20 6b 65 79 3d 3f 73 74 72 20 22 29 3b str key=?str ");
1d70: 22 29 29 29 0a 09 20 20 20 20 20 3b 28 64 65 62 "))).. ;(deb
1d80: 75 67 3a 70 72 69 6e 74 20 34 20 22 71 72 79 3a ug:print 4 "qry:
1d90: 20 22 20 71 72 79 29 20 0a 09 20 20 20 20 20 71 " qry) .. q
1da0: 72 79 29 0a 09 20 20 20 71 72 79 76 61 6c 73 29 ry).. qryvals)
1db0: 0a 09 20 20 28 73 71 6c 69 74 65 33 3a 65 78 65 .. (sqlite3:exe
1dc0: 63 75 74 65 20 64 62 20 22 55 50 44 41 54 45 20 cute db "UPDATE
1dd0: 72 75 6e 73 20 53 45 54 20 73 74 61 74 65 3d 3f runs SET state=?
1de0: 2c 73 74 61 74 75 73 3d 3f 20 57 48 45 52 45 20 ,status=? WHERE
1df0: 69 64 3d 3f 3b 22 20 73 74 61 74 65 20 73 74 61 id=?;" state sta
1e00: 74 75 73 20 72 65 73 29 0a 09 20 20 72 65 73 29 tus res).. res)
1e10: 20 0a 09 28 62 65 67 69 6e 0a 09 20 20 28 64 65 ..(begin.. (de
1e20: 62 75 67 3a 70 72 69 6e 74 20 30 20 22 45 52 52 bug:print 0 "ERR
1e30: 4f 52 3a 20 43 61 6c 6c 65 64 20 77 69 74 68 6f OR: Called witho
1e40: 75 74 20 61 6c 6c 20 6e 65 63 65 73 73 61 72 79 ut all necessary
1e50: 20 6b 65 79 73 22 29 0a 09 20 20 23 66 29 29 29 keys").. #f)))
1e60: 29 0a 0a 3b 3b 20 54 68 69 73 20 69 73 20 61 20 )..;; This is a
1e70: 64 75 70 6c 69 63 61 74 65 20 6f 66 20 72 75 6e duplicate of run
1e80: 2d 74 65 73 74 73 20 28 77 68 69 63 68 20 68 61 -tests (which ha
1e90: 73 20 62 65 65 6e 20 64 65 70 72 65 63 61 74 65 s been deprecate
1ea0: 64 29 2e 20 55 73 65 20 74 68 69 73 20 6f 6e 65 d). Use this one
1eb0: 20 69 6e 73 74 65 61 64 20 6f 66 20 72 75 6e 20 instead of run
1ec0: 74 65 73 74 73 2e 0a 3b 3b 20 6b 65 79 76 61 6c tests..;; keyval
1ed0: 73 2e 0a 3b 3b 0a 3b 3b 20 20 74 65 73 74 2d 6e s..;;.;; test-n
1ee0: 61 6d 65 73 3a 20 43 6f 6d 6d 61 20 73 65 70 61 ames: Comma sepa
1ef0: 72 61 74 65 64 20 70 61 74 74 65 72 6e 73 20 73 rated patterns s
1f00: 61 6d 65 20 61 73 20 74 65 73 74 2d 70 61 74 74 ame as test-patt
1f10: 73 20 62 75 74 20 75 73 65 64 20 69 6e 20 73 65 s but used in se
1f20: 6c 65 63 74 69 6f 6e 20 0a 3b 3b 20 20 20 20 20 lection .;;
1f30: 20 20 20 20 20 20 20 20 20 6f 66 20 74 65 73 74 of test
1f40: 73 20 74 6f 20 72 75 6e 2e 20 54 68 65 20 69 74 s to run. The it
1f50: 65 6d 20 70 6f 72 74 69 6f 6e 73 20 61 72 65 20 em portions are
1f60: 6e 6f 74 20 72 65 73 70 65 63 74 65 64 2e 0a 3b not respected..;
1f70: 3b 20 20 20 20 20 20 20 20 20 20 20 20 20 20 46 ; F
1f80: 49 58 4d 45 3a 20 65 72 72 6f 72 20 6f 75 74 20 IXME: error out
1f90: 69 66 20 2f 70 61 74 74 20 73 70 65 63 69 66 69 if /patt specifi
1fa0: 65 64 0a 3b 3b 20 20 20 20 20 20 20 20 20 20 20 ed.;;
1fb0: 20 0a 28 64 65 66 69 6e 65 20 28 72 75 6e 73 3a .(define (runs:
1fc0: 72 75 6e 2d 74 65 73 74 73 20 74 61 72 67 65 74 run-tests target
1fd0: 20 72 75 6e 6e 61 6d 65 20 74 65 73 74 2d 6e 61 runname test-na
1fe0: 6d 65 73 20 74 65 73 74 2d 70 61 74 74 73 20 75 mes test-patts u
1ff0: 73 65 72 20 66 6c 61 67 73 29 0a 20 20 28 63 6f ser flags). (co
2000: 6d 6d 6f 6e 3a 63 6c 65 61 72 2d 63 61 63 68 65 mmon:clear-cache
2010: 73 29 20 3b 3b 20 63 6c 65 61 72 20 61 6c 6c 20 s) ;; clear all
2020: 63 61 63 68 65 73 0a 20 20 28 6c 65 74 2a 20 28 caches. (let* (
2030: 28 64 62 20 20 20 20 20 20 20 20 20 20 23 66 29 (db #f)
2040: 0a 09 20 28 6b 65 79 73 20 20 20 20 20 20 20 20 .. (keys
2050: 28 63 64 62 3a 72 65 6d 6f 74 65 2d 72 75 6e 20 (cdb:remote-run
2060: 64 62 3a 67 65 74 2d 6b 65 79 73 20 23 66 29 29 db:get-keys #f))
2070: 0a 09 20 28 6b 65 79 76 61 6c 6c 73 74 20 20 20 .. (keyvallst
2080: 28 6b 65 79 73 3a 74 61 72 67 65 74 2d 3e 6b 65 (keys:target->ke
2090: 79 76 61 6c 20 6b 65 79 73 20 74 61 72 67 65 74 yval keys target
20a0: 29 29 0a 09 20 28 72 75 6e 2d 69 64 20 20 20 20 )).. (run-id
20b0: 20 20 28 63 64 62 3a 72 65 6d 6f 74 65 2d 72 75 (cdb:remote-ru
20c0: 6e 20 72 75 6e 73 3a 72 65 67 69 73 74 65 72 2d n runs:register-
20d0: 72 75 6e 20 23 66 20 6b 65 79 73 20 6b 65 79 76 run #f keys keyv
20e0: 61 6c 6c 73 74 20 72 75 6e 6e 61 6d 65 20 22 6e allst runname "n
20f0: 65 77 22 20 22 6e 2f 61 22 20 75 73 65 72 29 29 ew" "n/a" user))
2100: 20 20 3b 3b 20 20 74 65 73 74 2d 6e 61 6d 65 29 ;; test-name)
2110: 29 29 0a 09 20 28 64 65 66 65 72 72 65 64 20 20 )).. (deferred
2120: 20 20 27 28 29 29 20 3b 3b 20 64 65 6c 61 79 20 '()) ;; delay
2130: 72 75 6e 6e 69 6e 67 20 74 68 65 73 65 20 73 69 running these si
2140: 6e 63 65 20 74 68 65 79 20 68 61 76 65 20 61 20 nce they have a
2150: 77 61 69 74 6f 6e 20 63 6c 61 75 73 65 0a 09 20 waiton clause..
2160: 3b 3b 20 6b 65 65 70 67 6f 69 6e 67 20 69 73 20 ;; keepgoing is
2170: 74 68 65 20 64 65 66 61 63 74 6f 20 6d 6f 64 61 the defacto moda
2180: 6c 69 74 79 20 6e 6f 77 2c 20 77 69 6c 6c 20 61 lity now, will a
2190: 64 64 20 68 69 74 2d 6e 2d 72 75 6e 20 61 20 62 dd hit-n-run a b
21a0: 69 74 20 6c 61 74 65 72 0a 09 20 3b 3b 20 28 6b it later.. ;; (k
21b0: 65 65 70 67 6f 69 6e 67 20 20 20 28 68 61 73 68 eepgoing (hash
21c0: 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 -table-ref/defau
21d0: 6c 74 20 66 6c 61 67 73 20 22 2d 6b 65 65 70 67 lt flags "-keepg
21e0: 6f 69 6e 67 22 20 23 66 29 29 0a 09 20 28 72 75 oing" #f)).. (ru
21f0: 6e 63 6f 6e 66 69 67 66 20 20 20 28 63 6f 6e 63 nconfigf (conc
2200: 20 20 2a 74 6f 70 70 61 74 68 2a 20 22 2f 72 75 *toppath* "/ru
2210: 6e 63 6f 6e 66 69 67 73 2e 63 6f 6e 66 69 67 22 nconfigs.config"
2220: 29 29 0a 09 20 28 72 65 71 75 69 72 65 64 2d 74 )).. (required-t
2230: 65 73 74 73 20 27 28 29 29 0a 09 20 28 74 65 73 ests '()).. (tes
2240: 74 2d 72 65 63 6f 72 64 73 20 28 6d 61 6b 65 2d t-records (make-
2250: 68 61 73 68 2d 74 61 62 6c 65 29 29 29 0a 0a 20 hash-table)))..
2260: 20 20 20 28 73 65 74 2d 6d 65 67 61 74 65 73 74 (set-megatest
2270: 2d 65 6e 76 2d 76 61 72 73 20 72 75 6e 2d 69 64 -env-vars run-id
2280: 29 20 3b 3b 20 74 68 65 73 65 20 6d 61 79 20 62 ) ;; these may b
2290: 65 20 6e 65 65 64 65 64 20 62 79 20 74 68 65 20 e needed by the
22a0: 6c 61 75 6e 63 68 69 6e 67 20 70 72 6f 63 65 73 launching proces
22b0: 73 0a 0a 20 20 20 20 28 69 66 20 28 66 69 6c 65 s.. (if (file
22c0: 2d 65 78 69 73 74 73 3f 20 72 75 6e 63 6f 6e 66 -exists? runconf
22d0: 69 67 66 29 0a 09 28 6f 70 65 6e 2d 72 75 6e 2d igf)..(open-run-
22e0: 63 6c 6f 73 65 20 73 65 74 75 70 2d 65 6e 76 2d close setup-env-
22f0: 64 65 66 61 75 6c 74 73 20 64 62 20 72 75 6e 63 defaults db runc
2300: 6f 6e 66 69 67 66 20 72 75 6e 2d 69 64 20 2a 61 onfigf run-id *a
2310: 6c 72 65 61 64 79 2d 73 65 65 6e 2d 72 75 6e 63 lready-seen-runc
2320: 6f 6e 66 69 67 2d 69 6e 66 6f 2a 20 22 70 72 65 onfig-info* "pre
2330: 2d 6c 61 75 6e 63 68 2d 65 6e 76 2d 76 61 72 73 -launch-env-vars
2340: 22 29 0a 09 28 64 65 62 75 67 3a 70 72 69 6e 74 ")..(debug:print
2350: 20 30 20 22 57 41 52 4e 49 4e 47 3a 20 59 6f 75 0 "WARNING: You
2360: 20 64 6f 20 6e 6f 74 20 68 61 76 65 20 61 20 72 do not have a r
2370: 75 6e 20 63 6f 6e 66 69 67 20 66 69 6c 65 3a 20 un config file:
2380: 22 20 72 75 6e 63 6f 6e 66 69 67 66 29 29 0a 20 " runconfigf)).
2390: 20 20 20 0a 20 20 20 20 3b 3b 20 6c 6f 6f 6b 20 . ;; look
23a0: 75 70 20 61 6c 6c 20 74 65 73 74 73 20 6d 61 74 up all tests mat
23b0: 63 68 69 6e 67 20 74 68 65 20 63 6f 6d 6d 61 20 ching the comma
23c0: 73 65 70 61 72 61 74 65 64 20 6c 69 73 74 20 6f separated list o
23d0: 66 20 67 6c 6f 62 73 20 69 6e 0a 20 20 20 20 3b f globs in. ;
23e0: 3b 20 74 65 73 74 2d 70 61 74 74 73 20 28 75 73 ; test-patts (us
23f0: 69 6e 67 20 25 20 61 73 20 77 69 6c 64 63 61 72 ing % as wildcar
2400: 64 29 0a 0a 20 20 20 20 28 73 65 74 21 20 74 65 d).. (set! te
2410: 73 74 2d 6e 61 6d 65 73 20 28 74 65 73 74 73 3a st-names (tests:
2420: 67 65 74 2d 76 61 6c 69 64 2d 74 65 73 74 73 20 get-valid-tests
2430: 2a 74 6f 70 70 61 74 68 2a 20 74 65 73 74 2d 6e *toppath* test-n
2440: 61 6d 65 73 29 29 0a 20 20 20 20 28 73 65 74 21 ames)). (set!
2450: 20 74 65 73 74 2d 6e 61 6d 65 73 20 28 64 65 6c test-names (del
2460: 65 74 65 2d 64 75 70 6c 69 63 61 74 65 73 20 74 ete-duplicates t
2470: 65 73 74 2d 6e 61 6d 65 73 29 29 0a 0a 20 20 20 est-names))..
2480: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e (debug:print-in
2490: 66 6f 20 30 20 22 74 65 73 74 20 6e 61 6d 65 73 fo 0 "test names
24a0: 20 22 20 74 65 73 74 2d 6e 61 6d 65 73 29 0a 0a " test-names)..
24b0: 20 20 20 20 3b 3b 20 6f 6e 20 74 68 65 20 66 69 ;; on the fi
24c0: 72 73 74 20 70 61 73 73 20 6f 72 20 63 61 6c 6c rst pass or call
24d0: 20 74 6f 20 72 75 6e 2d 74 65 73 74 73 20 73 65 to run-tests se
24e0: 74 20 46 41 49 4c 53 20 74 6f 20 4e 4f 54 5f 53 t FAILS to NOT_S
24f0: 54 41 52 54 45 44 20 69 66 0a 20 20 20 20 3b 3b TARTED if. ;;
2500: 20 2d 6b 65 65 70 67 6f 69 6e 67 20 69 73 20 73 -keepgoing is s
2510: 70 65 63 69 66 69 65 64 0a 20 20 20 20 28 69 66 pecified. (if
2520: 20 28 65 71 3f 20 2a 70 61 73 73 6e 75 6d 2a 20 (eq? *passnum*
2530: 30 29 0a 09 28 62 65 67 69 6e 0a 09 20 20 3b 3b 0)..(begin.. ;;
2540: 20 68 61 76 65 20 74 6f 20 64 65 6c 65 74 65 20 have to delete
2550: 74 65 73 74 20 72 65 63 6f 72 64 73 20 77 68 65 test records whe
2560: 72 65 20 4e 4f 54 5f 53 54 41 52 54 45 44 20 73 re NOT_STARTED s
2570: 69 6e 63 65 20 74 68 65 79 20 63 61 6e 20 63 61 ince they can ca
2580: 75 73 65 20 2d 6b 65 65 70 67 6f 69 6e 67 20 74 use -keepgoing t
2590: 6f 20 0a 09 20 20 3b 3b 20 67 65 74 20 73 74 75 o .. ;; get stu
25a0: 63 6b 20 64 75 65 20 74 6f 20 62 65 63 6f 6d 69 ck due to becomi
25b0: 6e 67 20 69 6e 61 63 63 65 73 73 69 62 6c 65 20 ng inaccessible
25c0: 66 72 6f 6d 20 61 20 66 61 69 6c 65 64 20 74 65 from a failed te
25d0: 73 74 2e 20 49 2e 65 2e 20 69 66 20 74 65 73 74 st. I.e. if test
25e0: 20 42 20 64 65 70 65 6e 64 73 20 0a 09 20 20 3b B depends .. ;
25f0: 3b 20 6f 6e 20 74 65 73 74 20 41 20 62 75 74 20 ; on test A but
2600: 74 65 73 74 20 42 20 72 65 61 63 68 65 64 20 74 test B reached t
2610: 68 65 20 70 6f 69 6e 74 20 6f 6e 20 62 65 69 6e he point on bein
2620: 67 20 72 65 67 69 73 74 65 72 65 64 20 61 73 20 g registered as
2630: 4e 4f 54 5f 53 54 41 52 54 45 44 20 61 6e 64 20 NOT_STARTED and
2640: 74 65 73 74 0a 09 20 20 3b 3b 20 41 20 66 61 69 test.. ;; A fai
2650: 6c 65 64 20 66 6f 72 20 73 6f 6d 65 20 72 65 61 led for some rea
2660: 73 6f 6e 20 74 68 65 6e 20 6f 6e 20 72 65 2d 72 son then on re-r
2670: 75 6e 20 75 73 69 6e 67 20 2d 6b 65 65 70 67 6f un using -keepgo
2680: 69 6e 67 20 74 68 65 20 72 75 6e 20 63 61 6e 20 ing the run can
2690: 6e 65 76 65 72 20 63 6f 6d 70 6c 65 74 65 2e 0a never complete..
26a0: 09 20 20 28 63 64 62 3a 64 65 6c 65 74 65 2d 74 . (cdb:delete-t
26b0: 65 73 74 73 2d 69 6e 2d 73 74 61 74 65 20 2a 72 ests-in-state *r
26c0: 75 6e 72 65 6d 6f 74 65 2a 20 72 75 6e 2d 69 64 unremote* run-id
26d0: 20 22 4e 4f 54 5f 53 54 41 52 54 45 44 22 29 0a "NOT_STARTED").
26e0: 09 20 20 28 63 64 62 3a 72 65 6d 6f 74 65 2d 72 . (cdb:remote-r
26f0: 75 6e 20 64 62 3a 73 65 74 2d 74 65 73 74 73 2d un db:set-tests-
2700: 73 74 61 74 65 2d 73 74 61 74 75 73 20 23 66 20 state-status #f
2710: 72 75 6e 2d 69 64 20 74 65 73 74 2d 6e 61 6d 65 run-id test-name
2720: 73 20 23 66 20 22 46 41 49 4c 22 20 22 4e 4f 54 s #f "FAIL" "NOT
2730: 5f 53 54 41 52 54 45 44 22 20 22 46 41 49 4c 22 _STARTED" "FAIL"
2740: 29 29 29 0a 0a 20 20 20 20 3b 3b 20 66 72 6f 6d ))).. ;; from
2750: 20 68 65 72 65 20 6f 6e 20 6f 75 74 20 74 68 65 here on out the
2760: 20 64 62 20 77 69 6c 6c 20 62 65 20 6f 70 65 6e db will be open
2770: 65 64 20 61 6e 64 20 63 6c 6f 73 65 64 20 6f 6e ed and closed on
2780: 20 65 76 65 72 79 20 63 61 6c 6c 20 72 75 6e 73 every call runs
2790: 3a 72 75 6e 2d 74 65 73 74 73 2d 71 75 65 75 65 :run-tests-queue
27a0: 0a 20 20 20 20 3b 3b 20 28 73 71 6c 69 74 65 33 . ;; (sqlite3
27b0: 3a 66 69 6e 61 6c 69 7a 65 21 20 64 62 29 20 0a :finalize! db) .
27c0: 20 20 20 20 3b 3b 20 6e 6f 77 20 61 64 64 20 6e ;; now add n
27d0: 6f 6e 2d 64 69 72 65 63 74 6c 79 20 72 65 66 65 on-directly refe
27e0: 72 65 6e 63 65 64 20 64 65 70 65 6e 64 65 6e 63 renced dependenc
27f0: 69 65 73 20 28 69 2e 65 2e 20 77 61 69 74 6f 6e ies (i.e. waiton
2800: 29 0a 20 20 20 20 28 69 66 20 28 6e 6f 74 20 28 ). (if (not (
2810: 6e 75 6c 6c 3f 20 74 65 73 74 2d 6e 61 6d 65 73 null? test-names
2820: 29 29 0a 09 28 6c 65 74 20 6c 6f 6f 70 20 28 28 ))..(let loop ((
2830: 68 65 64 20 28 63 61 72 20 74 65 73 74 2d 6e 61 hed (car test-na
2840: 6d 65 73 29 29 0a 09 09 20 20 20 28 74 61 6c 20 mes))... (tal
2850: 28 63 64 72 20 74 65 73 74 2d 6e 61 6d 65 73 29 (cdr test-names)
2860: 29 29 20 20 20 20 20 20 20 20 20 3b 3b 20 27 72 )) ;; 'r
2870: 65 74 75 72 6e 2d 70 72 6f 63 73 20 74 65 6c 6c eturn-procs tell
2880: 73 20 74 68 65 20 63 6f 6e 66 69 67 20 72 65 61 s the config rea
2890: 64 65 72 20 74 6f 20 70 72 65 70 20 72 75 6e 6e der to prep runn
28a0: 69 6e 67 20 73 79 73 74 65 6d 20 62 75 74 20 72 ing system but r
28b0: 65 74 75 72 6e 20 61 20 70 72 6f 63 0a 09 20 20 eturn a proc..
28c0: 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 (debug:print-inf
28d0: 6f 20 34 20 22 68 65 64 3d 22 20 68 65 64 20 22 o 4 "hed=" hed "
28e0: 20 61 74 20 74 6f 70 20 6f 66 20 6c 6f 6f 70 22 at top of loop"
28f0: 29 0a 09 20 20 28 6c 65 74 2a 20 28 28 63 6f 6e ).. (let* ((con
2900: 66 69 67 20 20 28 74 65 73 74 73 3a 67 65 74 2d fig (tests:get-
2910: 74 65 73 74 63 6f 6e 66 69 67 20 68 65 64 20 27 testconfig hed '
2920: 72 65 74 75 72 6e 2d 70 72 6f 63 73 29 29 0a 09 return-procs))..
2930: 09 20 28 77 61 69 74 6f 6e 73 20 28 69 66 20 63 . (waitons (if c
2940: 6f 6e 66 69 67 20 28 73 74 72 69 6e 67 2d 73 70 onfig (string-sp
2950: 6c 69 74 20 28 6c 65 74 20 28 28 77 20 28 63 6f lit (let ((w (co
2960: 6e 66 69 67 2d 6c 6f 6f 6b 75 70 20 63 6f 6e 66 nfig-lookup conf
2970: 69 67 20 22 72 65 71 75 69 72 65 6d 65 6e 74 73 ig "requirements
2980: 22 20 22 77 61 69 74 6f 6e 22 29 29 29 0a 09 09 " "waiton")))...
2990: 09 09 09 09 20 20 20 20 20 28 69 66 20 77 20 77 .... (if w w
29a0: 20 22 22 29 29 29 0a 09 09 09 20 20 20 20 20 20 "")))....
29b0: 28 62 65 67 69 6e 0a 09 09 09 09 28 64 65 62 75 (begin.....(debu
29c0: 67 3a 70 72 69 6e 74 20 30 20 22 45 52 52 4f 52 g:print 0 "ERROR
29d0: 3a 20 6e 6f 6e 2d 65 78 69 73 74 65 6e 74 20 72 : non-existent r
29e0: 65 71 75 69 72 65 64 20 74 65 73 74 20 5c 22 22 equired test \""
29f0: 20 68 65 64 20 22 5c 22 22 29 0a 20 20 20 20 20 hed "\"").
2a00: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2a10: 20 20 20 20 20 20 20 20 20 20 20 28 69 66 20 64 (if d
2a20: 62 20 28 73 71 6c 69 74 65 33 3a 66 69 6e 61 6c b (sqlite3:final
2a30: 69 7a 65 21 20 64 62 29 29 0a 09 09 09 09 28 65 ize! db)).....(e
2a40: 78 69 74 20 31 29 29 29 29 29 0a 09 20 20 20 20 xit 1)))))..
2a50: 3b 3b 20 63 68 65 63 6b 20 66 6f 72 20 68 65 64 ;; check for hed
2a60: 20 69 6e 20 77 61 69 74 6f 6e 73 20 3d 3e 20 74 in waitons => t
2a70: 68 69 73 20 77 6f 75 6c 64 20 62 65 20 63 69 72 his would be cir
2a80: 63 75 6c 61 72 2c 20 72 65 6d 6f 76 65 20 69 74 cular, remove it
2a90: 20 61 6e 64 20 69 73 73 75 65 20 61 6e 0a 09 20 and issue an..
2aa0: 20 20 20 3b 3b 20 65 72 72 6f 72 0a 09 20 20 20 ;; error..
2ab0: 20 28 69 66 20 28 6d 65 6d 62 65 72 20 68 65 64 (if (member hed
2ac0: 20 77 61 69 74 6f 6e 73 29 0a 09 09 28 62 65 67 waitons)...(beg
2ad0: 69 6e 0a 09 09 20 20 28 64 65 62 75 67 3a 70 72 in... (debug:pr
2ae0: 69 6e 74 20 30 20 22 45 52 52 4f 52 3a 20 74 65 int 0 "ERROR: te
2af0: 73 74 20 22 20 68 65 64 20 22 20 68 61 73 20 6c st " hed " has l
2b00: 69 73 74 65 64 20 69 74 73 65 6c 66 20 61 73 20 isted itself as
2b10: 61 20 77 61 69 74 6f 6e 2c 20 70 6c 65 61 73 65 a waiton, please
2b20: 20 63 6f 72 72 65 63 74 20 74 68 69 73 21 22 29 correct this!")
2b30: 0a 09 09 20 20 28 73 65 74 21 20 77 61 69 74 6f ... (set! waito
2b40: 6e 73 20 28 66 69 6c 74 65 72 20 28 6c 61 6d 62 ns (filter (lamb
2b50: 64 61 20 28 78 29 28 6e 6f 74 20 28 65 71 75 61 da (x)(not (equa
2b60: 6c 3f 20 78 20 68 65 64 29 29 29 20 77 61 69 74 l? x hed))) wait
2b70: 6f 6e 73 29 29 29 29 0a 09 20 20 20 20 0a 09 20 ons)))).. ..
2b80: 20 20 20 3b 3b 20 28 69 74 65 6d 73 20 20 20 28 ;; (items (
2b90: 69 74 65 6d 73 3a 67 65 74 2d 69 74 65 6d 73 2d items:get-items-
2ba0: 66 72 6f 6d 2d 63 6f 6e 66 69 67 20 63 6f 6e 66 from-config conf
2bb0: 69 67 29 29 29 0a 09 20 20 20 20 28 69 66 20 28 ig))).. (if (
2bc0: 6e 6f 74 20 28 68 61 73 68 2d 74 61 62 6c 65 2d not (hash-table-
2bd0: 72 65 66 2f 64 65 66 61 75 6c 74 20 74 65 73 74 ref/default test
2be0: 2d 72 65 63 6f 72 64 73 20 68 65 64 20 23 66 29 -records hed #f)
2bf0: 29 0a 09 09 28 68 61 73 68 2d 74 61 62 6c 65 2d )...(hash-table-
2c00: 73 65 74 21 20 74 65 73 74 2d 72 65 63 6f 72 64 set! test-record
2c10: 73 0a 09 09 09 09 20 68 65 64 20 28 76 65 63 74 s..... hed (vect
2c20: 6f 72 20 68 65 64 20 20 20 20 20 3b 3b 20 30 0a or hed ;; 0.
2c30: 09 09 09 09 09 20 20 20 20 20 63 6f 6e 66 69 67 ..... config
2c40: 20 20 3b 3b 20 31 0a 09 09 09 09 09 20 20 20 20 ;; 1......
2c50: 20 77 61 69 74 6f 6e 73 20 3b 3b 20 32 0a 09 09 waitons ;; 2...
2c60: 09 09 09 20 20 20 20 20 28 63 6f 6e 66 69 67 2d ... (config-
2c70: 6c 6f 6f 6b 75 70 20 63 6f 6e 66 69 67 20 22 72 lookup config "r
2c80: 65 71 75 69 72 65 6d 65 6e 74 73 22 20 22 70 72 equirements" "pr
2c90: 69 6f 72 69 74 79 22 29 20 20 20 20 20 3b 3b 20 iority") ;;
2ca0: 70 72 69 6f 72 69 74 79 20 33 0a 09 09 09 09 09 priority 3......
2cb0: 20 20 20 20 20 28 6c 65 74 20 28 28 69 74 65 6d (let ((item
2cc0: 73 20 20 20 20 20 20 28 68 61 73 68 2d 74 61 62 s (hash-tab
2cd0: 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 63 le-ref/default c
2ce0: 6f 6e 66 69 67 20 22 69 74 65 6d 73 22 20 23 66 onfig "items" #f
2cf0: 29 29 20 3b 3b 20 69 74 65 6d 73 20 34 0a 09 09 )) ;; items 4...
2d00: 09 09 09 09 20 20 20 28 69 74 65 6d 73 74 61 62 .... (itemstab
2d10: 6c 65 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 le (hash-table-r
2d20: 65 66 2f 64 65 66 61 75 6c 74 20 63 6f 6e 66 69 ef/default confi
2d30: 67 20 22 69 74 65 6d 73 74 61 62 6c 65 22 20 23 g "itemstable" #
2d40: 66 29 29 29 20 0a 09 09 09 09 09 20 20 20 20 20 f))) ......
2d50: 20 20 3b 3b 20 69 66 20 65 69 74 68 65 72 20 69 ;; if either i
2d60: 74 65 6d 73 20 6f 72 20 69 74 65 6d 73 20 74 61 tems or items ta
2d70: 62 6c 65 20 69 73 20 61 20 70 72 6f 63 20 72 65 ble is a proc re
2d80: 74 75 72 6e 20 69 74 20 73 6f 20 74 65 73 74 20 turn it so test
2d90: 72 75 6e 6e 69 6e 67 0a 09 09 09 09 09 20 20 20 running......
2da0: 20 20 20 20 3b 3b 20 70 72 6f 63 65 73 73 20 63 ;; process c
2db0: 61 6e 20 6b 6e 6f 77 20 74 6f 20 63 61 6c 6c 20 an know to call
2dc0: 69 74 65 6d 73 3a 67 65 74 2d 69 74 65 6d 73 2d items:get-items-
2dd0: 66 72 6f 6d 2d 63 6f 6e 66 69 67 0a 09 09 09 09 from-config.....
2de0: 09 20 20 20 20 20 20 20 3b 3b 20 69 66 20 65 69 . ;; if ei
2df0: 74 68 65 72 20 69 73 20 61 20 6c 69 73 74 20 61 ther is a list a
2e00: 6e 64 20 6e 6f 6e 65 20 69 73 20 61 20 70 72 6f nd none is a pro
2e10: 63 20 67 6f 20 61 68 65 61 64 20 61 6e 64 20 63 c go ahead and c
2e20: 61 6c 6c 20 67 65 74 2d 69 74 65 6d 73 0a 09 09 all get-items...
2e30: 09 09 09 20 20 20 20 20 20 20 3b 3b 20 6f 74 68 ... ;; oth
2e40: 65 72 77 69 73 65 20 72 65 74 75 72 6e 20 23 66 erwise return #f
2e50: 20 2d 20 74 68 69 73 20 69 73 20 6e 6f 74 20 61 - this is not a
2e60: 6e 20 69 74 65 72 61 74 65 64 20 74 65 73 74 0a n iterated test.
2e70: 09 09 09 09 09 20 20 20 20 20 20 20 28 63 6f 6e ..... (con
2e80: 64 0a 09 09 09 09 09 09 28 28 70 72 6f 63 65 64 d.......((proced
2e90: 75 72 65 3f 20 69 74 65 6d 73 29 20 20 20 20 20 ure? items)
2ea0: 20 0a 09 09 09 09 09 09 20 28 64 65 62 75 67 3a ....... (debug:
2eb0: 70 72 69 6e 74 2d 69 6e 66 6f 20 34 20 22 69 74 print-info 4 "it
2ec0: 65 6d 73 20 69 73 20 61 20 70 72 6f 63 65 64 75 ems is a procedu
2ed0: 72 65 2c 20 77 69 6c 6c 20 63 61 6c 63 20 6c 61 re, will calc la
2ee0: 74 65 72 22 29 0a 09 09 09 09 09 09 20 69 74 65 ter")....... ite
2ef0: 6d 73 29 20 20 20 20 20 20 20 20 20 20 20 20 3b ms) ;
2f00: 3b 20 63 61 6c 63 20 6c 61 74 65 72 0a 09 09 09 ; calc later....
2f10: 09 09 09 28 28 70 72 6f 63 65 64 75 72 65 3f 20 ...((procedure?
2f20: 69 74 65 6d 73 74 61 62 6c 65 29 0a 09 09 09 09 itemstable).....
2f30: 09 09 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d .. (debug:print-
2f40: 69 6e 66 6f 20 34 20 22 69 74 65 6d 73 74 61 62 info 4 "itemstab
2f50: 6c 65 20 69 73 20 61 20 70 72 6f 63 65 64 75 72 le is a procedur
2f60: 65 2c 20 77 69 6c 6c 20 63 61 6c 63 20 6c 61 74 e, will calc lat
2f70: 65 72 22 29 0a 09 09 09 09 09 09 20 69 74 65 6d er")....... item
2f80: 73 74 61 62 6c 65 29 20 20 20 20 20 20 20 3b 3b stable) ;;
2f90: 20 63 61 6c 63 20 6c 61 74 65 72 0a 09 09 09 09 calc later.....
2fa0: 09 09 28 28 66 69 6c 74 65 72 20 28 6c 61 6d 62 ..((filter (lamb
2fb0: 64 61 20 28 78 29 0a 09 09 09 09 09 09 09 20 20 da (x)........
2fc0: 20 28 6c 65 74 20 28 28 76 61 6c 20 28 63 61 72 (let ((val (car
2fd0: 20 78 29 29 29 0a 09 09 09 09 09 09 09 20 20 20 x)))........
2fe0: 20 20 28 69 66 20 28 70 72 6f 63 65 64 75 72 65 (if (procedure
2ff0: 3f 20 76 61 6c 29 20 76 61 6c 20 23 66 29 29 29 ? val) val #f)))
3000: 0a 09 09 09 09 09 09 09 20 28 61 70 70 65 6e 64 ........ (append
3010: 20 28 69 66 20 28 6c 69 73 74 3f 20 69 74 65 6d (if (list? item
3020: 73 29 20 69 74 65 6d 73 20 27 28 29 29 0a 09 09 s) items '())...
3030: 09 09 09 09 09 09 20 28 69 66 20 28 6c 69 73 74 ...... (if (list
3040: 3f 20 69 74 65 6d 73 74 61 62 6c 65 29 20 69 74 ? itemstable) it
3050: 65 6d 73 74 61 62 6c 65 20 27 28 29 29 29 29 0a emstable '()))).
3060: 09 09 09 09 09 09 20 27 68 61 76 65 2d 70 72 6f ...... 'have-pro
3070: 63 65 64 75 72 65 29 0a 09 09 09 09 09 09 28 28 cedure).......((
3080: 6f 72 20 28 6c 69 73 74 3f 20 69 74 65 6d 73 29 or (list? items)
3090: 28 6c 69 73 74 3f 20 69 74 65 6d 73 74 61 62 6c (list? itemstabl
30a0: 65 29 29 20 3b 3b 20 63 61 6c 63 20 6e 6f 77 0a e)) ;; calc now.
30b0: 09 09 09 09 09 09 20 28 64 65 62 75 67 3a 70 72 ...... (debug:pr
30c0: 69 6e 74 2d 69 6e 66 6f 20 34 20 22 69 74 65 6d int-info 4 "item
30d0: 73 20 61 6e 64 20 69 74 65 6d 73 74 61 62 6c 65 s and itemstable
30e0: 20 61 72 65 20 6c 69 73 74 73 2c 20 63 61 6c 63 are lists, calc
30f0: 20 6e 6f 77 5c 6e 22 0a 09 09 09 09 09 09 09 20 now\n"........
3100: 20 20 20 20 20 22 20 20 20 20 69 74 65 6d 73 3a " items:
3110: 20 22 20 69 74 65 6d 73 20 22 20 69 74 65 6d 73 " items " items
3120: 74 61 62 6c 65 3a 20 22 20 69 74 65 6d 73 74 61 table: " itemsta
3130: 62 6c 65 29 0a 09 09 09 09 09 09 20 28 69 74 65 ble)....... (ite
3140: 6d 73 3a 67 65 74 2d 69 74 65 6d 73 2d 66 72 6f ms:get-items-fro
3150: 6d 2d 63 6f 6e 66 69 67 20 63 6f 6e 66 69 67 29 m-config config)
3160: 29 0a 09 09 09 09 09 09 28 65 6c 73 65 20 23 66 ).......(else #f
3170: 29 29 29 20 20 20 20 20 20 20 20 20 20 20 20 20 )))
3180: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 3b 3b ;;
3190: 20 6e 6f 74 20 69 74 65 72 61 74 65 64 0a 09 09 not iterated...
31a0: 09 09 09 20 20 20 20 20 23 66 20 20 20 20 20 20 ... #f
31b0: 3b 3b 20 69 74 65 6d 73 64 61 74 20 35 0a 09 09 ;; itemsdat 5...
31c0: 09 09 09 20 20 20 20 20 23 66 20 20 20 20 20 20 ... #f
31d0: 3b 3b 20 73 70 61 72 65 20 2d 20 75 73 65 64 20 ;; spare - used
31e0: 66 6f 72 20 69 74 65 6d 2d 70 61 74 68 0a 09 09 for item-path...
31f0: 09 09 09 20 20 20 20 20 29 29 29 0a 09 20 20 20 ... )))..
3200: 20 28 66 6f 72 2d 65 61 63 68 20 0a 09 20 20 20 (for-each ..
3210: 20 20 28 6c 61 6d 62 64 61 20 28 77 61 69 74 6f (lambda (waito
3220: 6e 29 0a 09 20 20 20 20 20 20 20 28 69 66 20 28 n).. (if (
3230: 61 6e 64 20 77 61 69 74 6f 6e 20 28 6e 6f 74 20 and waiton (not
3240: 28 6d 65 6d 62 65 72 20 77 61 69 74 6f 6e 20 74 (member waiton t
3250: 65 73 74 2d 6e 61 6d 65 73 29 29 29 0a 09 09 20 est-names)))...
3260: 20 20 28 62 65 67 69 6e 0a 09 09 20 20 20 20 20 (begin...
3270: 28 73 65 74 21 20 72 65 71 75 69 72 65 64 2d 74 (set! required-t
3280: 65 73 74 73 20 28 63 6f 6e 73 20 77 61 69 74 6f ests (cons waito
3290: 6e 20 72 65 71 75 69 72 65 64 2d 74 65 73 74 73 n required-tests
32a0: 29 29 0a 09 09 20 20 20 20 20 28 73 65 74 21 20 ))... (set!
32b0: 74 65 73 74 2d 6e 61 6d 65 73 20 28 63 6f 6e 73 test-names (cons
32c0: 20 77 61 69 74 6f 6e 20 74 65 73 74 2d 6e 61 6d waiton test-nam
32d0: 65 73 29 29 29 29 29 20 3b 3b 20 77 61 73 20 61 es))))) ;; was a
32e0: 6e 20 61 70 70 65 6e 64 2c 20 6e 6f 77 20 61 20 n append, now a
32f0: 63 6f 6e 73 0a 09 20 20 20 20 20 77 61 69 74 6f cons.. waito
3300: 6e 73 29 0a 09 20 20 20 20 28 6c 65 74 20 28 28 ns).. (let ((
3310: 72 65 6d 74 65 73 74 73 20 28 64 65 6c 65 74 65 remtests (delete
3320: 2d 64 75 70 6c 69 63 61 74 65 73 20 28 61 70 70 -duplicates (app
3330: 65 6e 64 20 77 61 69 74 6f 6e 73 20 74 61 6c 29 end waitons tal)
3340: 29 29 29 0a 09 20 20 20 20 20 20 28 69 66 20 28 ))).. (if (
3350: 6e 6f 74 20 28 6e 75 6c 6c 3f 20 72 65 6d 74 65 not (null? remte
3360: 73 74 73 29 29 0a 09 09 20 20 28 6c 6f 6f 70 20 sts))... (loop
3370: 28 63 61 72 20 72 65 6d 74 65 73 74 73 29 28 63 (car remtests)(c
3380: 64 72 20 72 65 6d 74 65 73 74 73 29 29 29 29 29 dr remtests)))))
3390: 29 29 0a 0a 20 20 20 20 28 69 66 20 28 6e 6f 74 )).. (if (not
33a0: 20 28 6e 75 6c 6c 3f 20 72 65 71 75 69 72 65 64 (null? required
33b0: 2d 74 65 73 74 73 29 29 0a 09 28 64 65 62 75 67 -tests))..(debug
33c0: 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 31 20 22 41 :print-info 1 "A
33d0: 64 64 69 6e 67 20 22 20 72 65 71 75 69 72 65 64 dding " required
33e0: 2d 74 65 73 74 73 20 22 20 74 6f 20 74 68 65 20 -tests " to the
33f0: 72 75 6e 20 71 75 65 75 65 22 29 29 0a 20 20 20 run queue")).
3400: 20 3b 3b 20 4e 4f 54 45 3a 20 74 68 65 73 65 20 ;; NOTE: these
3410: 61 72 65 20 61 6c 6c 20 70 61 72 65 6e 74 20 74 are all parent t
3420: 65 73 74 73 2c 20 69 74 65 6d 73 20 61 72 65 20 ests, items are
3430: 6e 6f 74 20 65 78 70 61 6e 64 65 64 20 79 65 74 not expanded yet
3440: 2e 0a 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 .. (debug:pri
3450: 6e 74 2d 69 6e 66 6f 20 34 20 22 74 65 73 74 2d nt-info 4 "test-
3460: 72 65 63 6f 72 64 73 3d 22 20 28 68 61 73 68 2d records=" (hash-
3470: 74 61 62 6c 65 2d 3e 61 6c 69 73 74 20 74 65 73 table->alist tes
3480: 74 2d 72 65 63 6f 72 64 73 29 29 0a 20 20 20 20 t-records)).
3490: 28 72 75 6e 73 3a 72 75 6e 2d 74 65 73 74 73 2d (runs:run-tests-
34a0: 71 75 65 75 65 20 72 75 6e 2d 69 64 20 72 75 6e queue run-id run
34b0: 6e 61 6d 65 20 74 65 73 74 2d 72 65 63 6f 72 64 name test-record
34c0: 73 20 6b 65 79 76 61 6c 6c 73 74 20 66 6c 61 67 s keyvallst flag
34d0: 73 20 74 65 73 74 2d 70 61 74 74 73 29 0a 20 20 s test-patts).
34e0: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 (debug:print-i
34f0: 6e 66 6f 20 34 20 22 41 6c 6c 20 64 6f 6e 65 20 nfo 4 "All done
3500: 62 79 20 68 65 72 65 22 29 29 29 0a 0a 28 64 65 by here")))..(de
3510: 66 69 6e 65 20 28 72 75 6e 73 3a 63 61 6c 63 2d fine (runs:calc-
3520: 66 61 69 6c 73 20 70 72 65 72 65 71 73 2d 6e 6f fails prereqs-no
3530: 74 2d 6d 65 74 29 0a 20 20 28 66 69 6c 74 65 72 t-met). (filter
3540: 20 28 6c 61 6d 62 64 61 20 28 74 65 73 74 29 0a (lambda (test).
3550: 09 20 20 20 20 28 61 6e 64 20 28 76 65 63 74 6f . (and (vecto
3560: 72 3f 20 74 65 73 74 29 20 3b 3b 20 6e 6f 74 20 r? test) ;; not
3570: 28 73 74 72 69 6e 67 3f 20 74 65 73 74 29 29 0a (string? test)).
3580: 09 09 20 28 65 71 75 61 6c 3f 20 28 64 62 3a 74 .. (equal? (db:t
3590: 65 73 74 2d 67 65 74 2d 73 74 61 74 65 20 74 65 est-get-state te
35a0: 73 74 29 20 22 43 4f 4d 50 4c 45 54 45 44 22 29 st) "COMPLETED")
35b0: 0a 09 09 20 28 6e 6f 74 20 28 6d 65 6d 62 65 72 ... (not (member
35c0: 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 73 74 (db:test-get-st
35d0: 61 74 75 73 20 74 65 73 74 29 0a 09 09 09 20 20 atus test)....
35e0: 20 20 20 20 27 28 22 50 41 53 53 22 20 22 57 41 '("PASS" "WA
35f0: 52 4e 22 20 22 43 48 45 43 4b 22 20 22 57 41 49 RN" "CHECK" "WAI
3600: 56 45 44 22 29 29 29 29 29 0a 09 20 20 70 72 65 VED"))))).. pre
3610: 72 65 71 73 2d 6e 6f 74 2d 6d 65 74 29 29 0a 0a reqs-not-met))..
3620: 28 64 65 66 69 6e 65 20 28 72 75 6e 73 3a 63 61 (define (runs:ca
3630: 6c 63 2d 6e 6f 74 2d 63 6f 6d 70 6c 65 74 65 64 lc-not-completed
3640: 20 70 72 65 72 65 71 73 2d 6e 6f 74 2d 6d 65 74 prereqs-not-met
3650: 29 0a 20 20 28 66 69 6c 74 65 72 0a 20 20 20 28 ). (filter. (
3660: 6c 61 6d 62 64 61 20 28 74 29 0a 20 20 20 20 20 lambda (t).
3670: 28 6f 72 20 28 6e 6f 74 20 28 76 65 63 74 6f 72 (or (not (vector
3680: 3f 20 74 29 29 0a 09 20 28 6e 6f 74 20 28 65 71 ? t)).. (not (eq
3690: 75 61 6c 3f 20 22 43 4f 4d 50 4c 45 54 45 44 22 ual? "COMPLETED"
36a0: 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 73 74 (db:test-get-st
36b0: 61 74 65 20 74 29 29 29 29 29 0a 20 20 20 70 72 ate t))))). pr
36c0: 65 72 65 71 73 2d 6e 6f 74 2d 6d 65 74 29 29 0a ereqs-not-met)).
36d0: 0a 28 64 65 66 69 6e 65 20 28 72 75 6e 73 3a 70 .(define (runs:p
36e0: 72 65 74 74 79 2d 73 74 72 69 6e 67 20 6c 73 74 retty-string lst
36f0: 29 0a 20 20 28 6d 61 70 20 28 6c 61 6d 62 64 61 ). (map (lambda
3700: 20 28 74 29 0a 09 20 28 69 66 20 28 6e 6f 74 20 (t).. (if (not
3710: 28 76 65 63 74 6f 72 3f 20 74 29 29 0a 09 20 20 (vector? t))..
3720: 20 20 20 28 63 6f 6e 63 20 74 29 0a 09 20 20 20 (conc t)..
3730: 20 20 28 63 6f 6e 63 20 28 64 62 3a 74 65 73 74 (conc (db:test
3740: 2d 67 65 74 2d 74 65 73 74 6e 61 6d 65 20 74 29 -get-testname t)
3750: 20 22 3a 22 20 28 64 62 3a 74 65 73 74 2d 67 65 ":" (db:test-ge
3760: 74 2d 73 74 61 74 65 20 74 29 20 22 2f 22 20 28 t-state t) "/" (
3770: 64 62 3a 74 65 73 74 2d 67 65 74 2d 73 74 61 74 db:test-get-stat
3780: 75 73 20 74 29 29 29 29 0a 20 20 20 20 20 20 20 us t)))).
3790: 6c 73 74 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 lst))..(define (
37a0: 72 75 6e 73 3a 6d 61 6b 65 2d 66 75 6c 6c 2d 74 runs:make-full-t
37b0: 65 73 74 2d 6e 61 6d 65 20 74 65 73 74 6e 61 6d est-name testnam
37c0: 65 20 69 74 65 6d 70 61 74 68 29 0a 20 20 28 69 e itempath). (i
37d0: 66 20 28 65 71 75 61 6c 3f 20 69 74 65 6d 70 61 f (equal? itempa
37e0: 74 68 20 22 22 29 20 74 65 73 74 6e 61 6d 65 20 th "") testname
37f0: 28 63 6f 6e 63 20 74 65 73 74 6e 61 6d 65 20 22 (conc testname "
3800: 2f 22 20 69 74 65 6d 70 61 74 68 29 29 29 0a 0a /" itempath)))..
3810: 3b 3b 20 74 65 73 74 2d 72 65 63 6f 72 64 73 20 ;; test-records
3820: 69 73 20 61 20 68 61 73 68 20 74 61 62 6c 65 20 is a hash table
3830: 74 65 73 74 6e 61 6d 65 3a 69 74 65 6d 5f 70 61 testname:item_pa
3840: 74 68 20 3d 3e 20 76 65 63 74 6f 72 20 3c 20 74 th => vector < t
3850: 65 73 74 6e 61 6d 65 20 74 65 73 74 63 6f 6e 66 estname testconf
3860: 69 67 20 77 61 69 74 6f 6e 73 20 70 72 69 6f 72 ig waitons prior
3870: 69 74 79 20 69 74 65 6d 73 2d 69 6e 66 6f 20 2e ity items-info .
3880: 2e 2e 20 3e 0a 28 64 65 66 69 6e 65 20 28 72 75 .. >.(define (ru
3890: 6e 73 3a 72 75 6e 2d 74 65 73 74 73 2d 71 75 65 ns:run-tests-que
38a0: 75 65 20 72 75 6e 2d 69 64 20 72 75 6e 6e 61 6d ue run-id runnam
38b0: 65 20 74 65 73 74 2d 72 65 63 6f 72 64 73 20 6b e test-records k
38c0: 65 79 76 61 6c 6c 73 74 20 66 6c 61 67 73 20 74 eyvallst flags t
38d0: 65 73 74 2d 70 61 74 74 73 29 0a 20 20 20 20 3b est-patts). ;
38e0: 3b 20 41 74 20 74 68 69 73 20 70 6f 69 6e 74 20 ; At this point
38f0: 74 68 65 20 6c 69 73 74 20 6f 66 20 70 61 72 65 the list of pare
3900: 6e 74 20 74 65 73 74 73 20 69 73 20 65 78 70 61 nt tests is expa
3910: 6e 64 65 64 20 0a 20 20 20 20 3b 3b 20 4e 42 2f nded . ;; NB/
3920: 2f 20 53 68 6f 75 6c 64 20 65 78 70 61 6e 64 20 / Should expand
3930: 69 74 65 6d 73 20 68 65 72 65 20 61 6e 64 20 74 items here and t
3940: 68 65 6e 20 69 6e 73 65 72 74 20 69 6e 74 6f 20 hen insert into
3950: 74 68 65 20 72 75 6e 20 71 75 65 75 65 2e 0a 20 the run queue..
3960: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 35 20 (debug:print 5
3970: 22 74 65 73 74 2d 72 65 63 6f 72 64 73 3a 20 22 "test-records: "
3980: 20 74 65 73 74 2d 72 65 63 6f 72 64 73 20 22 2c test-records ",
3990: 20 6b 65 79 76 61 6c 6c 73 74 3a 20 22 20 6b 65 keyvallst: " ke
39a0: 79 76 61 6c 6c 73 74 20 22 20 66 6c 61 67 73 3a yvallst " flags:
39b0: 20 22 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 3e " (hash-table->
39c0: 61 6c 69 73 74 20 66 6c 61 67 73 29 29 0a 20 20 alist flags)).
39d0: 28 6c 65 74 20 28 28 73 6f 72 74 65 64 2d 74 65 (let ((sorted-te
39e0: 73 74 2d 6e 61 6d 65 73 20 28 74 65 73 74 73 3a st-names (tests:
39f0: 73 6f 72 74 2d 62 79 2d 70 72 69 6f 72 69 74 79 sort-by-priority
3a00: 2d 61 6e 64 2d 77 61 69 74 6f 6e 20 74 65 73 74 -and-waiton test
3a10: 2d 72 65 63 6f 72 64 73 29 29 0a 09 28 74 65 73 -records))..(tes
3a20: 74 2d 72 65 67 69 73 74 65 72 79 20 20 20 20 28 t-registery (
3a30: 6d 61 6b 65 2d 68 61 73 68 2d 74 61 62 6c 65 29 make-hash-table)
3a40: 29 0a 09 28 6e 75 6d 2d 72 65 74 72 69 65 73 20 )..(num-retries
3a50: 20 20 20 20 20 20 20 30 29 0a 09 28 6d 61 78 2d 0)..(max-
3a60: 72 65 74 72 69 65 73 20 20 20 20 20 20 20 28 63 retries (c
3a70: 6f 6e 66 69 67 2d 6c 6f 6f 6b 75 70 20 2a 63 6f onfig-lookup *co
3a80: 6e 66 69 67 64 61 74 2a 20 22 73 65 74 75 70 22 nfigdat* "setup"
3a90: 20 22 6d 61 78 72 65 74 72 69 65 73 22 29 29 29 "maxretries")))
3aa0: 0a 20 20 20 20 28 73 65 74 21 20 6d 61 78 2d 72 . (set! max-r
3ab0: 65 74 72 69 65 73 20 28 69 66 20 28 61 6e 64 20 etries (if (and
3ac0: 6d 61 78 2d 72 65 74 72 69 65 73 20 28 73 74 72 max-retries (str
3ad0: 69 6e 67 2d 3e 6e 75 6d 62 65 72 20 6d 61 78 2d ing->number max-
3ae0: 72 65 74 72 69 65 73 29 29 28 73 74 72 69 6e 67 retries))(string
3af0: 2d 3e 6e 75 6d 62 65 72 20 6d 61 78 2d 72 65 74 ->number max-ret
3b00: 72 69 65 73 29 20 31 30 30 29 29 0a 20 20 20 20 ries) 100)).
3b10: 28 69 66 20 28 6e 6f 74 20 28 6e 75 6c 6c 3f 20 (if (not (null?
3b20: 73 6f 72 74 65 64 2d 74 65 73 74 2d 6e 61 6d 65 sorted-test-name
3b30: 73 29 29 0a 09 28 6c 65 74 20 6c 6f 6f 70 20 28 s))..(let loop (
3b40: 28 68 65 64 20 20 20 20 20 20 20 20 20 28 63 61 (hed (ca
3b50: 72 20 73 6f 72 74 65 64 2d 74 65 73 74 2d 6e 61 r sorted-test-na
3b60: 6d 65 73 29 29 0a 09 09 20 20 20 28 74 61 6c 20 mes))... (tal
3b70: 20 20 20 20 20 20 20 20 28 63 64 72 20 73 6f 72 (cdr sor
3b80: 74 65 64 2d 74 65 73 74 2d 6e 61 6d 65 73 29 29 ted-test-names))
3b90: 0a 09 09 20 20 20 28 72 65 72 75 6e 73 20 20 20 ... (reruns
3ba0: 20 20 20 27 28 29 29 29 0a 09 20 20 28 69 66 20 '())).. (if
3bb0: 28 6e 6f 74 20 28 6e 75 6c 6c 3f 20 72 65 72 75 (not (null? reru
3bc0: 6e 73 29 29 28 64 65 62 75 67 3a 70 72 69 6e 74 ns))(debug:print
3bd0: 2d 69 6e 66 6f 20 34 20 22 72 65 72 75 6e 73 3d -info 4 "reruns=
3be0: 22 20 72 65 72 75 6e 73 29 29 0a 09 20 20 3b 3b " reruns)).. ;;
3bf0: 20 28 70 72 69 6e 74 20 22 54 6f 70 20 6f 66 20 (print "Top of
3c00: 6c 6f 6f 70 2c 20 68 65 64 3d 22 20 68 65 64 20 loop, hed=" hed
3c10: 22 2c 20 74 61 6c 3d 22 20 74 61 6c 20 22 20 2c ", tal=" tal " ,
3c20: 72 65 72 75 6e 73 3d 22 20 72 65 72 75 6e 73 29 reruns=" reruns)
3c30: 0a 09 20 20 28 6c 65 74 2a 20 28 28 74 65 73 74 .. (let* ((test
3c40: 2d 72 65 63 6f 72 64 20 28 68 61 73 68 2d 74 61 -record (hash-ta
3c50: 62 6c 65 2d 72 65 66 20 74 65 73 74 2d 72 65 63 ble-ref test-rec
3c60: 6f 72 64 73 20 68 65 64 29 29 0a 09 09 20 28 74 ords hed))... (t
3c70: 65 73 74 2d 6e 61 6d 65 20 20 20 28 74 65 73 74 est-name (test
3c80: 73 3a 74 65 73 74 71 75 65 75 65 2d 67 65 74 2d s:testqueue-get-
3c90: 74 65 73 74 6e 61 6d 65 20 74 65 73 74 2d 72 65 testname test-re
3ca0: 63 6f 72 64 29 29 0a 09 09 20 28 74 63 6f 6e 66 cord))... (tconf
3cb0: 69 67 20 20 20 20 20 28 74 65 73 74 73 3a 74 65 ig (tests:te
3cc0: 73 74 71 75 65 75 65 2d 67 65 74 2d 74 65 73 74 stqueue-get-test
3cd0: 63 6f 6e 66 69 67 20 74 65 73 74 2d 72 65 63 6f config test-reco
3ce0: 72 64 29 29 0a 09 09 20 28 74 65 73 74 6d 6f 64 rd))... (testmod
3cf0: 65 20 20 20 20 28 6c 65 74 20 28 28 6d 20 28 63 e (let ((m (c
3d00: 6f 6e 66 69 67 2d 6c 6f 6f 6b 75 70 20 74 63 6f onfig-lookup tco
3d10: 6e 66 69 67 20 22 72 65 71 75 69 72 65 6d 65 6e nfig "requiremen
3d20: 74 73 22 20 22 6d 6f 64 65 22 29 29 29 0a 09 09 ts" "mode")))...
3d30: 09 09 28 69 66 20 6d 20 28 73 74 72 69 6e 67 2d ..(if m (string-
3d40: 3e 73 79 6d 62 6f 6c 20 6d 29 20 27 6e 6f 72 6d >symbol m) 'norm
3d50: 61 6c 29 29 29 0a 09 09 20 28 77 61 69 74 6f 6e al)))... (waiton
3d60: 73 20 20 20 20 20 28 74 65 73 74 73 3a 74 65 73 s (tests:tes
3d70: 74 71 75 65 75 65 2d 67 65 74 2d 77 61 69 74 6f tqueue-get-waito
3d80: 6e 73 20 20 20 20 74 65 73 74 2d 72 65 63 6f 72 ns test-recor
3d90: 64 29 29 0a 09 09 20 28 70 72 69 6f 72 69 74 79 d))... (priority
3da0: 20 20 20 20 28 74 65 73 74 73 3a 74 65 73 74 71 (tests:testq
3db0: 75 65 75 65 2d 67 65 74 2d 70 72 69 6f 72 69 74 ueue-get-priorit
3dc0: 79 20 20 20 74 65 73 74 2d 72 65 63 6f 72 64 29 y test-record)
3dd0: 29 0a 09 09 20 28 69 74 65 6d 64 61 74 20 20 20 )... (itemdat
3de0: 20 20 28 74 65 73 74 73 3a 74 65 73 74 71 75 65 (tests:testque
3df0: 75 65 2d 67 65 74 2d 69 74 65 6d 64 61 74 20 20 ue-get-itemdat
3e00: 20 20 74 65 73 74 2d 72 65 63 6f 72 64 29 29 20 test-record))
3e10: 3b 3b 20 69 74 65 6d 64 61 74 20 63 61 6e 20 62 ;; itemdat can b
3e20: 65 20 61 20 73 74 72 69 6e 67 2c 20 6c 69 73 74 e a string, list
3e30: 20 6f 72 20 23 66 0a 09 09 20 28 69 74 65 6d 73 or #f... (items
3e40: 20 20 20 20 20 20 20 28 74 65 73 74 73 3a 74 65 (tests:te
3e50: 73 74 71 75 65 75 65 2d 67 65 74 2d 69 74 65 6d stqueue-get-item
3e60: 73 20 20 20 20 20 20 74 65 73 74 2d 72 65 63 6f s test-reco
3e70: 72 64 29 29 0a 09 09 20 28 69 74 65 6d 2d 70 61 rd))... (item-pa
3e80: 74 68 20 20 20 28 69 74 65 6d 2d 6c 69 73 74 2d th (item-list-
3e90: 3e 70 61 74 68 20 69 74 65 6d 64 61 74 29 29 0a >path itemdat)).
3ea0: 09 09 20 28 6e 65 77 74 61 6c 20 20 20 20 20 20 .. (newtal
3eb0: 28 61 70 70 65 6e 64 20 74 61 6c 20 28 6c 69 73 (append tal (lis
3ec0: 74 20 68 65 64 29 29 29 29 0a 09 20 20 20 20 0a t hed)))).. .
3ed0: 09 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e . (debug:prin
3ee0: 74 20 36 0a 09 09 09 20 22 74 65 73 74 2d 6e 61 t 6.... "test-na
3ef0: 6d 65 3a 20 22 20 74 65 73 74 2d 6e 61 6d 65 0a me: " test-name.
3f00: 09 09 09 20 22 5c 6e 20 20 68 65 64 3a 20 20 20 ... "\n hed:
3f10: 20 20 20 20 20 20 22 20 68 65 64 0a 09 09 09 20 " hed....
3f20: 22 5c 6e 20 20 69 74 65 6d 64 61 74 3a 20 20 20 "\n itemdat:
3f30: 20 20 22 20 69 74 65 6d 64 61 74 0a 09 09 09 20 " itemdat....
3f40: 22 5c 6e 20 20 69 74 65 6d 73 3a 20 20 20 20 20 "\n items:
3f50: 20 20 22 20 69 74 65 6d 73 0a 09 09 09 20 22 5c " items.... "\
3f60: 6e 20 20 69 74 65 6d 2d 70 61 74 68 3a 20 20 20 n item-path:
3f70: 22 20 69 74 65 6d 2d 70 61 74 68 0a 09 09 09 20 " item-path....
3f80: 22 5c 6e 20 20 77 61 69 74 6f 6e 73 3a 20 20 20 "\n waitons:
3f90: 20 20 22 20 77 61 69 74 6f 6e 73 0a 09 09 09 20 " waitons....
3fa0: 22 5c 6e 20 20 6e 75 6d 2d 72 65 74 72 69 65 73 "\n num-retries
3fb0: 3a 20 22 20 6e 75 6d 2d 72 65 74 72 69 65 73 0a : " num-retries.
3fc0: 09 09 09 20 22 5c 6e 20 20 74 61 6c 3a 20 20 20 ... "\n tal:
3fd0: 20 20 20 20 20 20 22 20 74 61 6c 0a 09 09 09 20 " tal....
3fe0: 22 5c 6e 20 20 72 65 72 75 6e 73 3a 20 20 20 20 "\n reruns:
3ff0: 20 20 22 20 72 65 72 75 6e 73 29 0a 0a 09 20 20 " reruns)...
4000: 20 20 3b 3b 20 63 68 65 63 6b 20 66 6f 72 20 68 ;; check for h
4010: 65 64 20 69 6e 20 77 61 69 74 6f 6e 73 20 3d 3e ed in waitons =>
4020: 20 74 68 69 73 20 77 6f 75 6c 64 20 62 65 20 63 this would be c
4030: 69 72 63 75 6c 61 72 2c 20 72 65 6d 6f 76 65 20 ircular, remove
4040: 69 74 20 61 6e 64 20 69 73 73 75 65 20 61 6e 0a it and issue an.
4050: 09 20 20 20 20 3b 3b 20 65 72 72 6f 72 0a 09 20 . ;; error..
4060: 20 20 20 28 69 66 20 28 6d 65 6d 62 65 72 20 74 (if (member t
4070: 65 73 74 2d 6e 61 6d 65 20 77 61 69 74 6f 6e 73 est-name waitons
4080: 29 0a 09 09 28 62 65 67 69 6e 0a 09 09 20 20 28 )...(begin... (
4090: 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 22 45 debug:print 0 "E
40a0: 52 52 4f 52 3a 20 74 65 73 74 20 22 20 74 65 73 RROR: test " tes
40b0: 74 2d 6e 61 6d 65 20 22 20 68 61 73 20 6c 69 73 t-name " has lis
40c0: 74 65 64 20 69 74 73 65 6c 66 20 61 73 20 61 20 ted itself as a
40d0: 77 61 69 74 6f 6e 2c 20 70 6c 65 61 73 65 20 63 waiton, please c
40e0: 6f 72 72 65 63 74 20 74 68 69 73 21 22 29 0a 09 orrect this!")..
40f0: 09 20 20 28 73 65 74 21 20 77 61 69 74 6f 6e 20 . (set! waiton
4100: 28 66 69 6c 74 65 72 20 28 6c 61 6d 62 64 61 20 (filter (lambda
4110: 28 78 29 28 6e 6f 74 20 28 65 71 75 61 6c 3f 20 (x)(not (equal?
4120: 78 20 68 65 64 29 29 29 20 77 61 69 74 6f 6e 73 x hed))) waitons
4130: 29 29 29 29 0a 0a 09 20 20 20 20 28 63 6f 6e 64 ))))... (cond
4140: 20 3b 3b 20 4f 55 54 45 52 20 43 4f 4e 44 0a 09 ;; OUTER COND..
4150: 20 20 20 20 20 28 28 6e 6f 74 20 69 74 65 6d 73 ((not items
4160: 29 20 3b 3b 20 77 68 65 6e 20 66 61 6c 73 65 20 ) ;; when false
4170: 74 68 65 20 74 65 73 74 20 69 73 20 6f 6b 20 74 the test is ok t
4180: 6f 20 62 65 20 68 61 6e 64 65 64 20 6f 66 66 20 o be handed off
4190: 74 6f 20 6c 61 75 6e 63 68 20 28 62 75 74 20 6e to launch (but n
41a0: 6f 74 20 62 65 66 6f 72 65 29 0a 09 20 20 20 20 ot before)..
41b0: 20 20 28 6c 65 74 2a 20 28 28 72 75 6e 2d 6c 69 (let* ((run-li
41c0: 6d 69 74 73 2d 69 6e 66 6f 20 20 20 20 20 20 20 mits-info
41d0: 20 20 28 6f 70 65 6e 2d 72 75 6e 2d 63 6c 6f 73 (open-run-clos
41e0: 65 20 72 75 6e 73 3a 63 61 6e 2d 72 75 6e 2d 6d e runs:can-run-m
41f0: 6f 72 65 2d 74 65 73 74 73 20 74 65 73 74 2d 72 ore-tests test-r
4200: 65 63 6f 72 64 29 29 20 3b 3b 20 6c 6f 6f 6b 20 ecord)) ;; look
4210: 61 74 20 74 68 65 20 74 65 73 74 20 6a 6f 62 67 at the test jobg
4220: 72 6f 75 70 20 61 6e 64 20 74 6f 74 20 6a 6f 62 roup and tot job
4230: 73 20 72 75 6e 6e 69 6e 67 0a 09 09 20 20 20 20 s running...
4240: 20 28 68 61 76 65 2d 72 65 73 6f 75 72 63 65 73 (have-resources
4250: 20 20 20 20 20 20 20 20 20 20 28 63 61 72 20 72 (car r
4260: 75 6e 2d 6c 69 6d 69 74 73 2d 69 6e 66 6f 29 29 un-limits-info))
4270: 0a 09 09 20 20 20 20 20 28 6e 75 6d 2d 72 75 6e ... (num-run
4280: 6e 69 6e 67 20 20 20 20 20 20 20 20 20 20 20 20 ning
4290: 20 28 6c 69 73 74 2d 72 65 66 20 72 75 6e 2d 6c (list-ref run-l
42a0: 69 6d 69 74 73 2d 69 6e 66 6f 20 31 29 29 0a 09 imits-info 1))..
42b0: 09 20 20 20 20 20 28 6e 75 6d 2d 72 75 6e 6e 69 . (num-runni
42c0: 6e 67 2d 69 6e 2d 6a 6f 62 67 72 6f 75 70 20 28 ng-in-jobgroup (
42d0: 6c 69 73 74 2d 72 65 66 20 72 75 6e 2d 6c 69 6d list-ref run-lim
42e0: 69 74 73 2d 69 6e 66 6f 20 32 29 29 0a 09 09 20 its-info 2))...
42f0: 20 20 20 20 28 6d 61 78 2d 63 6f 6e 63 75 72 72 (max-concurr
4300: 65 6e 74 2d 6a 6f 62 73 20 20 20 20 20 28 6c 69 ent-jobs (li
4310: 73 74 2d 72 65 66 20 72 75 6e 2d 6c 69 6d 69 74 st-ref run-limit
4320: 73 2d 69 6e 66 6f 20 33 29 29 0a 09 09 20 20 20 s-info 3))...
4330: 20 20 28 6a 6f 62 2d 67 72 6f 75 70 2d 6c 69 6d (job-group-lim
4340: 69 74 20 20 20 20 20 20 20 20 20 28 6c 69 73 74 it (list
4350: 2d 72 65 66 20 72 75 6e 2d 6c 69 6d 69 74 73 2d -ref run-limits-
4360: 69 6e 66 6f 20 34 29 29 0a 09 09 20 20 20 20 20 info 4))...
4370: 28 70 72 65 72 65 71 73 2d 6e 6f 74 2d 6d 65 74 (prereqs-not-met
4380: 20 20 20 20 20 20 20 20 20 28 6f 70 65 6e 2d 72 (open-r
4390: 75 6e 2d 63 6c 6f 73 65 20 64 62 3a 67 65 74 2d un-close db:get-
43a0: 70 72 65 72 65 71 73 2d 6e 6f 74 2d 6d 65 74 20 prereqs-not-met
43b0: 23 66 20 72 75 6e 2d 69 64 20 77 61 69 74 6f 6e #f run-id waiton
43c0: 73 20 69 74 65 6d 2d 70 61 74 68 20 6d 6f 64 65 s item-path mode
43d0: 3a 20 74 65 73 74 6d 6f 64 65 29 29 0a 09 09 20 : testmode))...
43e0: 20 20 20 20 28 66 61 69 6c 73 20 20 20 20 20 20 (fails
43f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 72 75 (ru
4400: 6e 73 3a 63 61 6c 63 2d 66 61 69 6c 73 20 70 72 ns:calc-fails pr
4410: 65 72 65 71 73 2d 6e 6f 74 2d 6d 65 74 29 29 0a ereqs-not-met)).
4420: 09 09 20 20 20 20 20 28 6e 6f 6e 2d 63 6f 6d 70 .. (non-comp
4430: 6c 65 74 65 64 20 20 20 20 20 20 20 20 20 20 20 leted
4440: 28 72 75 6e 73 3a 63 61 6c 63 2d 6e 6f 74 2d 63 (runs:calc-not-c
4450: 6f 6d 70 6c 65 74 65 64 20 70 72 65 72 65 71 73 ompleted prereqs
4460: 2d 6e 6f 74 2d 6d 65 74 29 29 29 0a 09 09 28 64 -not-met)))...(d
4470: 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 ebug:print-info
4480: 38 20 22 68 61 76 65 2d 72 65 73 6f 75 72 63 65 8 "have-resource
4490: 73 3a 20 22 20 68 61 76 65 2d 72 65 73 6f 75 72 s: " have-resour
44a0: 63 65 73 20 22 20 70 72 65 72 65 71 73 2d 6e 6f ces " prereqs-no
44b0: 74 2d 6d 65 74 3a 20 22 20 0a 09 09 09 20 20 20 t-met: " ....
44c0: 20 20 28 73 74 72 69 6e 67 2d 69 6e 74 65 72 73 (string-inters
44d0: 70 65 72 73 65 20 0a 09 09 09 20 20 20 20 20 20 perse ....
44e0: 28 6d 61 70 20 28 6c 61 6d 62 64 61 20 28 74 29 (map (lambda (t)
44f0: 0a 09 09 09 09 20 20 20 20 20 28 69 66 20 28 76 ..... (if (v
4500: 65 63 74 6f 72 3f 20 74 29 0a 09 09 09 09 09 20 ector? t)......
4510: 28 63 6f 6e 63 20 28 64 62 3a 74 65 73 74 2d 67 (conc (db:test-g
4520: 65 74 2d 73 74 61 74 65 20 74 29 20 22 2f 22 20 et-state t) "/"
4530: 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 73 74 61 (db:test-get-sta
4540: 74 75 73 20 74 29 29 0a 09 09 09 09 09 20 28 63 tus t))...... (c
4550: 6f 6e 63 20 22 20 57 41 52 4e 49 4e 47 3a 20 74 onc " WARNING: t
4560: 20 69 73 20 6e 6f 74 20 61 20 76 65 63 74 6f 72 is not a vector
4570: 3d 22 20 74 20 29 29 29 0a 09 09 09 09 20 20 20 =" t ))).....
4580: 70 72 65 72 65 71 73 2d 6e 6f 74 2d 6d 65 74 29 prereqs-not-met)
4590: 20 22 2c 20 22 29 20 22 20 66 61 69 6c 73 3a 20 ", ") " fails:
45a0: 22 20 66 61 69 6c 73 29 0a 09 09 28 64 65 62 75 " fails)...(debu
45b0: 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 34 20 22 g:print-info 4 "
45c0: 68 65 64 3d 22 20 68 65 64 20 22 5c 6e 20 20 74 hed=" hed "\n t
45d0: 65 73 74 2d 72 65 63 6f 72 64 3d 22 20 74 65 73 est-record=" tes
45e0: 74 2d 72 65 63 6f 72 64 20 22 5c 6e 20 20 74 65 t-record "\n te
45f0: 73 74 2d 6e 61 6d 65 3a 20 22 20 74 65 73 74 2d st-name: " test-
4600: 6e 61 6d 65 20 22 5c 6e 20 20 69 74 65 6d 2d 70 name "\n item-p
4610: 61 74 68 3a 20 22 20 69 74 65 6d 2d 70 61 74 68 ath: " item-path
4620: 20 22 5c 6e 20 20 74 65 73 74 2d 70 61 74 74 73 "\n test-patts
4630: 3a 20 22 20 74 65 73 74 2d 70 61 74 74 73 29 0a : " test-patts).
4640: 0a 09 09 3b 3b 20 44 6f 6e 27 74 20 6b 6e 6f 77 ...;; Don't know
4650: 20 61 74 20 74 68 69 73 20 74 69 6d 65 20 69 66 at this time if
4660: 20 74 68 65 20 74 65 73 74 20 68 61 76 65 20 62 the test have b
4670: 65 65 6e 20 6c 61 75 6e 63 68 65 64 20 61 74 20 een launched at
4680: 73 6f 6d 65 20 74 69 6d 65 20 69 6e 20 74 68 65 some time in the
4690: 20 70 61 73 74 0a 09 09 3b 3b 20 69 2e 65 2e 20 past...;; i.e.
46a0: 69 73 20 74 68 69 73 20 61 20 72 65 2d 6c 61 75 is this a re-lau
46b0: 6e 63 68 3f 0a 09 09 28 64 65 62 75 67 3a 70 72 nch?...(debug:pr
46c0: 69 6e 74 2d 69 6e 66 6f 20 34 20 22 72 75 6e 2d int-info 4 "run-
46d0: 6c 69 6d 69 74 73 2d 69 6e 66 6f 20 3d 20 22 20 limits-info = "
46e0: 72 75 6e 2d 6c 69 6d 69 74 73 2d 69 6e 66 6f 29 run-limits-info)
46f0: 0a 09 09 28 63 6f 6e 64 20 3b 3b 20 49 4e 4e 45 ...(cond ;; INNE
4700: 52 20 43 4f 4e 44 20 23 31 20 66 6f 72 20 61 20 R COND #1 for a
4710: 6c 61 75 6e 63 68 61 62 6c 65 20 74 65 73 74 0a launchable test.
4720: 09 09 20 3b 3b 20 43 68 65 63 6b 20 69 74 65 6d .. ;; Check item
4730: 20 70 61 74 68 20 61 67 61 69 6e 73 74 20 69 74 path against it
4740: 65 6d 2d 70 61 74 74 73 0a 09 09 20 28 28 6e 6f em-patts... ((no
4750: 74 20 28 74 65 73 74 73 3a 6d 61 74 63 68 20 74 t (tests:match t
4760: 65 73 74 2d 70 61 74 74 73 20 28 74 65 73 74 73 est-patts (tests
4770: 3a 74 65 73 74 71 75 65 75 65 2d 67 65 74 2d 74 :testqueue-get-t
4780: 65 73 74 6e 61 6d 65 20 74 65 73 74 2d 72 65 63 estname test-rec
4790: 6f 72 64 29 20 69 74 65 6d 2d 70 61 74 68 29 29 ord) item-path))
47a0: 20 3b 3b 20 54 68 69 73 20 74 65 73 74 2f 69 74 ;; This test/it
47b0: 65 6d 70 61 74 68 20 69 73 20 6e 6f 74 20 74 6f empath is not to
47c0: 20 62 65 20 72 75 6e 0a 09 09 20 20 3b 3b 20 65 be run... ;; e
47d0: 6c 73 65 20 74 68 65 20 72 75 6e 20 69 73 20 73 lse the run is s
47e0: 74 75 63 6b 2c 20 74 65 6d 70 6f 72 61 72 69 6c tuck, temporaril
47f0: 79 20 6f 72 20 70 65 72 6d 61 6e 65 6e 74 6c 79 y or permanently
4800: 0a 09 09 20 20 3b 3b 20 62 75 74 20 73 68 6f 75 ... ;; but shou
4810: 6c 64 20 63 68 65 63 6b 20 69 66 20 69 74 20 69 ld check if it i
4820: 73 20 64 75 65 20 74 6f 20 6c 61 63 6b 20 6f 66 s due to lack of
4830: 20 72 65 73 6f 75 72 63 65 73 20 76 73 2e 20 70 resources vs. p
4840: 72 65 72 65 71 75 69 73 69 74 65 73 0a 09 09 20 rerequisites...
4850: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e (debug:print-in
4860: 66 6f 20 31 20 22 53 6b 69 70 70 69 6e 67 20 22 fo 1 "Skipping "
4870: 20 28 74 65 73 74 73 3a 74 65 73 74 71 75 65 75 (tests:testqueu
4880: 65 2d 67 65 74 2d 74 65 73 74 6e 61 6d 65 20 74 e-get-testname t
4890: 65 73 74 2d 72 65 63 6f 72 64 29 20 22 20 22 20 est-record) " "
48a0: 69 74 65 6d 2d 70 61 74 68 20 22 20 61 73 20 69 item-path " as i
48b0: 74 20 64 6f 65 73 6e 27 74 20 6d 61 74 63 68 20 t doesn't match
48c0: 22 20 74 65 73 74 2d 70 61 74 74 73 29 0a 09 09 " test-patts)...
48d0: 20 20 28 74 68 72 65 61 64 2d 73 6c 65 65 70 21 (thread-sleep!
48e0: 20 2a 67 6c 6f 62 61 6c 2d 64 65 6c 74 61 2a 29 *global-delta*)
48f0: 0a 09 09 20 20 28 69 66 20 28 6e 6f 74 20 28 6e ... (if (not (n
4900: 75 6c 6c 3f 20 74 61 6c 29 29 0a 09 09 20 20 20 ull? tal))...
4910: 20 20 20 28 6c 6f 6f 70 20 28 63 61 72 20 74 61 (loop (car ta
4920: 6c 29 28 63 64 72 20 74 61 6c 29 20 72 65 72 75 l)(cdr tal) reru
4930: 6e 73 29 29 29 0a 09 09 20 28 20 3b 3b 20 28 61 ns)))... ( ;; (a
4940: 6e 64 0a 09 09 20 20 28 6e 6f 74 20 28 68 61 73 nd... (not (has
4950: 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 h-table-ref/defa
4960: 75 6c 74 20 74 65 73 74 2d 72 65 67 69 73 74 65 ult test-registe
4970: 72 79 20 28 72 75 6e 73 3a 6d 61 6b 65 2d 66 75 ry (runs:make-fu
4980: 6c 6c 2d 74 65 73 74 2d 6e 61 6d 65 20 74 65 73 ll-test-name tes
4990: 74 2d 6e 61 6d 65 20 69 74 65 6d 2d 70 61 74 68 t-name item-path
49a0: 29 20 23 66 29 29 0a 09 09 20 20 20 20 20 20 3b ) #f))... ;
49b0: 3b 20 28 61 6e 64 20 6d 61 78 2d 63 6f 6e 63 75 ; (and max-concu
49c0: 72 72 65 6e 74 2d 6a 6f 62 73 20 28 3e 20 28 2d rrent-jobs (> (-
49d0: 20 6d 61 78 2d 63 6f 6e 63 75 72 72 65 6e 74 2d max-concurrent-
49e0: 6a 6f 62 73 20 6e 75 6d 2d 72 75 6e 6e 69 6e 67 jobs num-running
49f0: 29 20 35 29 29 29 0a 09 09 20 20 28 64 65 62 75 ) 5)))... (debu
4a00: 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 34 20 22 g:print-info 4 "
4a10: 50 72 65 2d 72 65 67 69 73 74 65 72 69 6e 67 20 Pre-registering
4a20: 74 65 73 74 20 22 20 74 65 73 74 2d 6e 61 6d 65 test " test-name
4a30: 20 22 2f 22 20 69 74 65 6d 2d 70 61 74 68 20 22 "/" item-path "
4a40: 20 74 6f 20 63 72 65 61 74 65 20 70 6c 61 63 65 to create place
4a50: 68 6f 6c 64 65 72 22 20 29 0a 09 09 20 20 28 6f holder" )... (o
4a60: 70 65 6e 2d 72 75 6e 2d 63 6c 6f 73 65 20 64 62 pen-run-close db
4a70: 3a 74 65 73 74 73 2d 72 65 67 69 73 74 65 72 2d :tests-register-
4a80: 74 65 73 74 20 23 66 20 72 75 6e 2d 69 64 20 74 test #f run-id t
4a90: 65 73 74 2d 6e 61 6d 65 20 69 74 65 6d 2d 70 61 est-name item-pa
4aa0: 74 68 29 0a 09 09 20 20 28 68 61 73 68 2d 74 61 th)... (hash-ta
4ab0: 62 6c 65 2d 73 65 74 21 20 74 65 73 74 2d 72 65 ble-set! test-re
4ac0: 67 69 73 74 65 72 79 20 28 72 75 6e 73 3a 6d 61 gistery (runs:ma
4ad0: 6b 65 2d 66 75 6c 6c 2d 74 65 73 74 2d 6e 61 6d ke-full-test-nam
4ae0: 65 20 74 65 73 74 2d 6e 61 6d 65 20 69 74 65 6d e test-name item
4af0: 2d 70 61 74 68 29 20 23 74 29 0a 09 09 20 20 28 -path) #t)... (
4b00: 74 68 72 65 61 64 2d 73 6c 65 65 70 21 20 2a 67 thread-sleep! *g
4b10: 6c 6f 62 61 6c 2d 64 65 6c 74 61 2a 29 0a 09 09 lobal-delta*)...
4b20: 20 20 28 6c 6f 6f 70 20 28 63 61 72 20 6e 65 77 (loop (car new
4b30: 74 61 6c 29 28 63 64 72 20 6e 65 77 74 61 6c 29 tal)(cdr newtal)
4b40: 20 72 65 72 75 6e 73 29 29 0a 09 09 20 28 28 6e reruns))... ((n
4b50: 6f 74 20 68 61 76 65 2d 72 65 73 6f 75 72 63 65 ot have-resource
4b60: 73 29 20 3b 3b 20 73 69 6d 70 6c 79 20 74 72 79 s) ;; simply try
4b70: 20 61 67 61 69 6e 20 61 66 74 65 72 20 77 61 69 again after wai
4b80: 74 69 6e 67 20 61 20 73 65 63 6f 6e 64 0a 09 09 ting a second...
4b90: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 (debug:print-i
4ba0: 6e 66 6f 20 31 20 22 6e 6f 20 72 65 73 6f 75 72 nfo 1 "no resour
4bb0: 63 65 73 20 74 6f 20 72 75 6e 20 6e 65 77 20 74 ces to run new t
4bc0: 65 73 74 73 2c 20 77 61 69 74 69 6e 67 20 2e 2e ests, waiting ..
4bd0: 2e 22 29 0a 09 09 20 20 28 74 68 72 65 61 64 2d .")... (thread-
4be0: 73 6c 65 65 70 21 20 28 2b 20 32 20 2a 67 6c 6f sleep! (+ 2 *glo
4bf0: 62 61 6c 2d 64 65 6c 74 61 2a 29 29 0a 09 09 20 bal-delta*))...
4c00: 20 3b 3b 20 63 6f 75 6c 64 20 68 61 76 65 20 64 ;; could have d
4c10: 6f 6e 65 20 68 65 64 20 74 61 6c 20 68 65 72 65 one hed tal here
4c20: 20 62 75 74 20 64 6f 69 6e 67 20 63 61 72 2f 63 but doing car/c
4c30: 64 72 20 6f 66 20 6e 65 77 74 61 6c 20 74 6f 20 dr of newtal to
4c40: 72 6f 74 61 74 65 20 74 65 73 74 73 0a 09 09 20 rotate tests...
4c50: 20 28 6c 6f 6f 70 20 28 63 61 72 20 6e 65 77 74 (loop (car newt
4c60: 61 6c 29 28 63 64 72 20 6e 65 77 74 61 6c 29 20 al)(cdr newtal)
4c70: 72 65 72 75 6e 73 29 29 0a 09 09 20 28 28 61 6e reruns))... ((an
4c80: 64 20 68 61 76 65 2d 72 65 73 6f 75 72 63 65 73 d have-resources
4c90: 0a 09 09 20 20 20 20 20 20 20 28 6f 72 20 28 6e ... (or (n
4ca0: 75 6c 6c 3f 20 70 72 65 72 65 71 73 2d 6e 6f 74 ull? prereqs-not
4cb0: 2d 6d 65 74 29 0a 09 09 09 20 20 20 28 61 6e 64 -met).... (and
4cc0: 20 28 65 71 3f 20 74 65 73 74 6d 6f 64 65 20 27 (eq? testmode '
4cd0: 74 6f 70 6c 65 76 65 6c 29 0a 09 09 09 09 28 6e toplevel).....(n
4ce0: 75 6c 6c 3f 20 6e 6f 6e 2d 63 6f 6d 70 6c 65 74 ull? non-complet
4cf0: 65 64 29 29 29 29 0a 09 09 20 20 28 72 75 6e 3a ed))))... (run:
4d00: 74 65 73 74 20 72 75 6e 2d 69 64 20 72 75 6e 6e test run-id runn
4d10: 61 6d 65 20 6b 65 79 76 61 6c 6c 73 74 20 74 65 ame keyvallst te
4d20: 73 74 2d 72 65 63 6f 72 64 20 66 6c 61 67 73 20 st-record flags
4d30: 23 66 29 0a 09 09 20 20 28 74 68 72 65 61 64 2d #f)... (thread-
4d40: 73 6c 65 65 70 21 20 2a 67 6c 6f 62 61 6c 2d 64 sleep! *global-d
4d50: 65 6c 74 61 2a 29 0a 09 09 20 20 28 69 66 20 28 elta*)... (if (
4d60: 6e 6f 74 20 28 6e 75 6c 6c 3f 20 74 61 6c 29 29 not (null? tal))
4d70: 0a 09 09 20 20 20 20 20 20 28 6c 6f 6f 70 20 28 ... (loop (
4d80: 63 61 72 20 74 61 6c 29 28 63 64 72 20 74 61 6c car tal)(cdr tal
4d90: 29 20 72 65 72 75 6e 73 29 29 29 0a 09 09 20 28 ) reruns)))... (
4da0: 65 6c 73 65 20 3b 3b 20 6d 75 73 74 20 62 65 20 else ;; must be
4db0: 77 65 20 68 61 76 65 20 75 6e 6d 65 74 20 70 72 we have unmet pr
4dc0: 65 72 65 71 75 69 73 69 74 65 73 0a 09 09 20 20 erequisites...
4dd0: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 34 (debug:print 4
4de0: 20 22 46 41 49 4c 53 3a 20 22 20 66 61 69 6c 73 "FAILS: " fails
4df0: 29 0a 09 09 20 20 20 20 3b 3b 20 49 66 20 6f 6e )... ;; If on
4e00: 65 20 6f 72 20 6d 6f 72 65 20 6f 66 20 74 68 65 e or more of the
4e10: 20 70 72 65 72 65 71 73 2d 6e 6f 74 2d 6d 65 74 prereqs-not-met
4e20: 20 61 72 65 20 46 41 49 4c 20 74 68 65 6e 20 77 are FAIL then w
4e30: 65 20 63 61 6e 20 69 73 73 75 65 0a 09 09 20 20 e can issue...
4e40: 20 20 3b 3b 20 61 20 6d 65 73 73 61 67 65 20 61 ;; a message a
4e50: 6e 64 20 64 72 6f 70 20 68 65 64 20 66 72 6f 6d nd drop hed from
4e60: 20 74 68 65 20 69 74 65 6d 73 20 74 6f 20 62 65 the items to be
4e70: 20 70 72 6f 63 65 73 73 65 64 2e 0a 09 09 20 20 processed....
4e80: 20 20 28 69 66 20 28 6e 75 6c 6c 3f 20 66 61 69 (if (null? fai
4e90: 6c 73 29 0a 09 09 09 28 62 65 67 69 6e 0a 09 09 ls)....(begin...
4ea0: 09 20 20 3b 3b 20 63 6f 75 6c 64 6e 27 74 20 72 . ;; couldn't r
4eb0: 75 6e 2c 20 74 61 6b 65 20 61 20 62 72 65 61 74 un, take a breat
4ec0: 68 65 72 0a 09 09 09 20 20 28 64 65 62 75 67 3a her.... (debug:
4ed0: 70 72 69 6e 74 2d 69 6e 66 6f 20 34 20 22 53 68 print-info 4 "Sh
4ee0: 6f 75 6c 64 6e 27 74 20 72 65 61 6c 6c 79 20 67 ouldn't really g
4ef0: 65 74 20 68 65 72 65 2c 20 72 61 63 65 20 63 6f et here, race co
4f00: 6e 64 69 74 69 6f 6e 3f 20 55 6e 61 62 6c 65 20 ndition? Unable
4f10: 74 6f 20 6c 61 75 6e 63 68 20 6d 6f 72 65 20 74 to launch more t
4f20: 65 73 74 73 20 61 74 20 74 68 69 73 20 6d 6f 6d ests at this mom
4f30: 65 6e 74 2c 20 6b 69 6c 6c 69 6e 67 20 74 69 6d ent, killing tim
4f40: 65 20 2e 2e 2e 22 29 0a 09 09 09 20 20 28 74 68 e ...").... (th
4f50: 72 65 61 64 2d 73 6c 65 65 70 21 20 28 2b 20 30 read-sleep! (+ 0
4f60: 2e 30 31 20 2a 67 6c 6f 62 61 6c 2d 64 65 6c 74 .01 *global-delt
4f70: 61 2a 29 29 20 3b 3b 20 6c 6f 6e 67 20 73 6c 65 a*)) ;; long sle
4f80: 65 70 20 68 65 72 65 20 2d 20 6e 6f 20 72 65 73 ep here - no res
4f90: 6f 75 72 63 65 73 2c 20 6d 61 79 20 61 73 20 77 ources, may as w
4fa0: 65 6c 6c 20 62 65 20 70 61 74 69 65 6e 74 0a 09 ell be patient..
4fb0: 09 09 20 20 3b 3b 20 77 65 20 6d 61 64 65 20 6e .. ;; we made n
4fc0: 65 77 20 74 61 6c 20 62 79 20 73 74 69 63 6b 69 ew tal by sticki
4fd0: 6e 67 20 68 65 64 20 61 74 20 74 68 65 20 62 61 ng hed at the ba
4fe0: 63 6b 20 6f 66 20 74 68 65 20 6c 69 73 74 0a 09 ck of the list..
4ff0: 09 09 20 20 28 6c 6f 6f 70 20 28 63 61 72 20 6e .. (loop (car n
5000: 65 77 74 61 6c 29 28 63 64 72 20 6e 65 77 74 61 ewtal)(cdr newta
5010: 6c 29 20 72 65 72 75 6e 73 29 29 0a 09 09 09 3b l) reruns))....;
5020: 3b 20 74 68 65 20 77 61 69 74 6f 6e 20 69 73 20 ; the waiton is
5030: 46 41 49 4c 20 73 6f 20 6e 6f 20 70 6f 69 6e 74 FAIL so no point
5040: 20 69 6e 20 74 72 79 69 6e 67 20 74 6f 20 72 75 in trying to ru
5050: 6e 20 68 65 64 20 65 76 65 72 20 61 67 61 69 6e n hed ever again
5060: 0a 09 09 09 28 69 66 20 28 6e 6f 74 20 28 6e 75 ....(if (not (nu
5070: 6c 6c 3f 20 74 61 6c 29 29 0a 09 09 09 20 20 20 ll? tal))....
5080: 20 28 69 66 20 28 76 65 63 74 6f 72 3f 20 68 65 (if (vector? he
5090: 64 29 0a 09 09 09 09 28 62 65 67 69 6e 20 28 64 d).....(begin (d
50a0: 65 62 75 67 3a 70 72 69 6e 74 20 31 20 22 57 41 ebug:print 1 "WA
50b0: 52 4e 3a 20 44 72 6f 70 70 69 6e 67 20 74 65 73 RN: Dropping tes
50c0: 74 20 22 20 28 64 62 3a 74 65 73 74 2d 67 65 74 t " (db:test-get
50d0: 2d 74 65 73 74 6e 61 6d 65 20 68 65 64 29 20 22 -testname hed) "
50e0: 2f 22 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d /" (db:test-get-
50f0: 69 74 65 6d 2d 70 61 74 68 20 68 65 64 29 0a 09 item-path hed)..
5100: 09 09 09 09 09 20 20 20 20 22 20 66 72 6f 6d 20 ..... " from
5110: 74 68 65 20 6c 61 75 6e 63 68 20 6c 69 73 74 20 the launch list
5120: 61 73 20 69 74 20 68 61 73 20 70 72 65 72 65 71 as it has prereq
5130: 75 69 73 74 65 73 20 74 68 61 74 20 61 72 65 20 uistes that are
5140: 46 41 49 4c 22 29 0a 09 09 09 09 20 20 20 20 20 FAIL").....
5150: 20 20 28 74 68 72 65 61 64 2d 73 6c 65 65 70 21 (thread-sleep!
5160: 20 2a 67 6c 6f 62 61 6c 2d 64 65 6c 74 61 2a 29 *global-delta*)
5170: 0a 09 09 09 09 20 20 20 20 20 20 20 28 6c 6f 6f ..... (loo
5180: 70 20 28 63 61 72 20 74 61 6c 29 28 63 64 72 20 p (car tal)(cdr
5190: 74 61 6c 29 20 28 63 6f 6e 73 20 68 65 64 20 72 tal) (cons hed r
51a0: 65 72 75 6e 73 29 29 29 0a 09 09 09 09 28 62 65 eruns))).....(be
51b0: 67 69 6e 0a 09 09 09 09 20 20 28 64 65 62 75 67 gin..... (debug
51c0: 3a 70 72 69 6e 74 20 31 20 22 57 41 52 4e 3a 20 :print 1 "WARN:
51d0: 54 65 73 74 20 6e 6f 74 20 70 72 6f 63 65 73 73 Test not process
51e0: 65 64 20 63 6f 72 72 65 63 74 6c 79 2e 20 43 6f ed correctly. Co
51f0: 75 6c 64 20 62 65 20 61 20 72 61 63 65 20 63 6f uld be a race co
5200: 6e 64 69 74 69 6f 6e 20 69 6e 20 79 6f 75 72 20 ndition in your
5210: 74 65 73 74 20 69 6d 70 6c 65 6d 65 6e 74 61 74 test implementat
5220: 69 6f 6e 3f 20 22 20 68 65 64 29 20 3b 3b 20 20 ion? " hed) ;;
5230: 22 20 61 73 20 69 74 20 68 61 73 20 70 72 65 72 " as it has prer
5240: 65 71 75 69 73 74 65 73 20 74 68 61 74 20 61 72 equistes that ar
5250: 65 20 46 41 49 4c 2e 20 28 4e 4f 54 45 3a 20 68 e FAIL. (NOTE: h
5260: 65 64 20 69 73 20 6e 6f 74 20 61 20 76 65 63 74 ed is not a vect
5270: 6f 72 29 22 29 0a 09 09 09 09 20 20 28 74 68 72 or)")..... (thr
5280: 65 61 64 2d 73 6c 65 65 70 21 20 28 2b 20 30 2e ead-sleep! (+ 0.
5290: 30 31 20 2a 67 6c 6f 62 61 6c 2d 64 65 6c 74 61 01 *global-delta
52a0: 2a 29 29 0a 09 09 09 09 20 20 28 6c 6f 6f 70 20 *))..... (loop
52b0: 68 65 64 20 74 61 6c 20 72 65 72 75 6e 73 29 29 hed tal reruns))
52c0: 29 29 29 29 29 29 29 20 3b 3b 20 45 4e 44 20 4f ))))))) ;; END O
52d0: 46 20 49 4e 4e 45 52 20 43 4f 4e 44 0a 09 20 20 F INNER COND..
52e0: 20 20 20 0a 09 20 20 20 20 20 3b 3b 20 63 61 73 .. ;; cas
52f0: 65 20 77 68 65 72 65 20 61 6e 20 69 74 65 6d 73 e where an items
5300: 20 63 61 6d 65 20 69 6e 20 61 73 20 61 20 6c 69 came in as a li
5310: 73 74 20 62 65 65 6e 20 70 72 6f 63 65 73 73 65 st been processe
5320: 64 0a 09 20 20 20 20 20 28 28 61 6e 64 20 28 6c d.. ((and (l
5330: 69 73 74 3f 20 69 74 65 6d 73 29 20 20 20 20 20 ist? items)
5340: 3b 3b 20 74 68 75 73 20 77 65 20 6b 6e 6f 77 20 ;; thus we know
5350: 6f 75 72 20 69 74 65 6d 73 20 61 72 65 20 61 6c our items are al
5360: 72 65 61 64 79 20 63 61 6c 63 75 6c 61 74 65 64 ready calculated
5370: 0a 09 09 20 20 20 28 6e 6f 74 20 20 20 69 74 65 ... (not ite
5380: 6d 64 61 74 29 29 20 3b 3b 20 61 6e 64 20 6e 6f mdat)) ;; and no
5390: 74 20 79 65 74 20 65 78 70 61 6e 64 65 64 20 69 t yet expanded i
53a0: 6e 74 6f 20 74 68 65 20 6c 69 73 74 20 6f 66 20 nto the list of
53b0: 74 68 69 6e 67 73 20 74 6f 20 62 65 20 64 6f 6e things to be don
53c0: 65 0a 09 20 20 20 20 20 20 28 69 66 20 28 61 6e e.. (if (an
53d0: 64 20 28 64 65 62 75 67 3a 64 65 62 75 67 2d 6d d (debug:debug-m
53e0: 6f 64 65 20 31 29 20 3b 3b 20 28 3e 3d 20 2a 76 ode 1) ;; (>= *v
53f0: 65 72 62 6f 73 69 74 79 2a 20 31 29 0a 09 09 20 erbosity* 1)...
5400: 20 20 20 20 20 20 28 3e 20 28 6c 65 6e 67 74 68 (> (length
5410: 20 69 74 65 6d 73 29 20 30 29 0a 09 09 20 20 20 items) 0)...
5420: 20 20 20 20 28 3e 20 28 6c 65 6e 67 74 68 20 28 (> (length (
5430: 63 61 72 20 69 74 65 6d 73 29 29 20 30 29 29 0a car items)) 0)).
5440: 09 09 20 20 28 70 70 20 69 74 65 6d 73 29 29 0a .. (pp items)).
5450: 09 20 20 20 20 20 20 28 66 6f 72 2d 65 61 63 68 . (for-each
5460: 0a 09 20 20 20 20 20 20 20 28 6c 61 6d 62 64 61 .. (lambda
5470: 20 28 6d 79 2d 69 74 65 6d 64 61 74 29 0a 09 09 (my-itemdat)...
5480: 20 28 6c 65 74 2a 20 28 28 6e 65 77 2d 74 65 73 (let* ((new-tes
5490: 74 2d 72 65 63 6f 72 64 20 28 6c 65 74 20 28 28 t-record (let ((
54a0: 6e 65 77 72 65 63 20 28 6d 61 6b 65 2d 74 65 73 newrec (make-tes
54b0: 74 73 3a 74 65 73 74 71 75 65 75 65 29 29 29 0a ts:testqueue))).
54c0: 09 09 09 09 09 20 20 20 28 76 65 63 74 6f 72 2d ..... (vector-
54d0: 63 6f 70 79 21 20 74 65 73 74 2d 72 65 63 6f 72 copy! test-recor
54e0: 64 20 6e 65 77 72 65 63 29 0a 09 09 09 09 09 20 d newrec)......
54f0: 20 20 6e 65 77 72 65 63 29 29 0a 09 09 09 28 6d newrec))....(m
5500: 79 2d 69 74 65 6d 2d 70 61 74 68 20 28 69 74 65 y-item-path (ite
5510: 6d 2d 6c 69 73 74 2d 3e 70 61 74 68 20 6d 79 2d m-list->path my-
5520: 69 74 65 6d 64 61 74 29 29 29 0a 09 09 20 20 20 itemdat)))...
5530: 28 69 66 20 28 74 65 73 74 73 3a 6d 61 74 63 68 (if (tests:match
5540: 20 74 65 73 74 2d 70 61 74 74 73 20 68 65 64 20 test-patts hed
5550: 6d 79 2d 69 74 65 6d 2d 70 61 74 68 29 20 3b 3b my-item-path) ;;
5560: 20 28 70 61 74 74 2d 6c 69 73 74 2d 6d 61 74 63 (patt-list-matc
5570: 68 20 6d 79 2d 69 74 65 6d 2d 70 61 74 68 20 69 h my-item-path i
5580: 74 65 6d 2d 70 61 74 74 73 29 20 20 20 20 20 20 tem-patts)
5590: 20 20 20 20 20 3b 3b 20 79 65 73 2c 20 77 65 20 ;; yes, we
55a0: 77 61 6e 74 20 74 6f 20 70 72 6f 63 65 73 73 20 want to process
55b0: 74 68 69 73 20 69 74 65 6d 2c 20 4e 4f 54 45 3a this item, NOTE:
55c0: 20 53 68 6f 75 6c 64 20 6e 6f 74 20 6e 65 65 64 Should not need
55d0: 20 74 68 69 73 20 63 68 65 63 6b 20 68 65 72 65 this check here
55e0: 21 0a 09 09 20 20 20 20 20 20 20 28 6c 65 74 20 !... (let
55f0: 28 28 6e 65 77 74 65 73 74 6e 61 6d 65 20 28 72 ((newtestname (r
5600: 75 6e 73 3a 6d 61 6b 65 2d 66 75 6c 6c 2d 74 65 uns:make-full-te
5610: 73 74 2d 6e 61 6d 65 20 68 65 64 20 6d 79 2d 69 st-name hed my-i
5620: 74 65 6d 2d 70 61 74 68 29 29 29 20 20 20 20 3b tem-path))) ;
5630: 3b 20 74 65 73 74 20 6e 61 6d 65 73 20 61 72 65 ; test names are
5640: 20 75 6e 69 71 75 65 20 6f 6e 20 74 65 73 74 6e unique on testn
5650: 61 6d 65 2f 69 74 65 6d 2d 70 61 74 68 0a 09 09 ame/item-path...
5660: 09 20 28 74 65 73 74 73 3a 74 65 73 74 71 75 65 . (tests:testque
5670: 75 65 2d 73 65 74 2d 69 74 65 6d 73 21 20 20 20 ue-set-items!
5680: 20 20 6e 65 77 2d 74 65 73 74 2d 72 65 63 6f 72 new-test-recor
5690: 64 20 23 66 29 0a 09 09 09 20 28 74 65 73 74 73 d #f).... (tests
56a0: 3a 74 65 73 74 71 75 65 75 65 2d 73 65 74 2d 69 :testqueue-set-i
56b0: 74 65 6d 64 61 74 21 20 20 20 6e 65 77 2d 74 65 temdat! new-te
56c0: 73 74 2d 72 65 63 6f 72 64 20 6d 79 2d 69 74 65 st-record my-ite
56d0: 6d 64 61 74 29 0a 09 09 09 20 28 74 65 73 74 73 mdat).... (tests
56e0: 3a 74 65 73 74 71 75 65 75 65 2d 73 65 74 2d 69 :testqueue-set-i
56f0: 74 65 6d 5f 70 61 74 68 21 20 6e 65 77 2d 74 65 tem_path! new-te
5700: 73 74 2d 72 65 63 6f 72 64 20 6d 79 2d 69 74 65 st-record my-ite
5710: 6d 2d 70 61 74 68 29 0a 09 09 09 20 28 68 61 73 m-path).... (has
5720: 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 74 65 73 h-table-set! tes
5730: 74 2d 72 65 63 6f 72 64 73 20 6e 65 77 74 65 73 t-records newtes
5740: 74 6e 61 6d 65 20 6e 65 77 2d 74 65 73 74 2d 72 tname new-test-r
5750: 65 63 6f 72 64 29 0a 09 09 09 20 28 73 65 74 21 ecord).... (set!
5760: 20 74 61 6c 20 28 63 6f 6e 73 20 6e 65 77 74 65 tal (cons newte
5770: 73 74 6e 61 6d 65 20 74 61 6c 29 29 29 29 29 29 stname tal))))))
5780: 20 3b 3b 20 73 69 6e 63 65 20 74 68 65 73 65 20 ;; since these
5790: 61 72 65 20 69 74 65 6d 69 7a 65 64 20 63 72 65 are itemized cre
57a0: 61 74 65 20 6e 65 77 20 74 65 73 74 20 6e 61 6d ate new test nam
57b0: 65 73 20 74 65 73 74 6e 61 6d 65 2f 69 74 65 6d es testname/item
57c0: 70 61 74 68 0a 09 20 20 20 20 20 20 20 69 74 65 path.. ite
57d0: 6d 73 29 0a 09 20 20 20 20 20 20 28 69 66 20 28 ms).. (if (
57e0: 6e 6f 74 20 28 6e 75 6c 6c 3f 20 74 61 6c 29 29 not (null? tal))
57f0: 0a 09 09 20 20 28 62 65 67 69 6e 0a 09 09 20 20 ... (begin...
5800: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 (debug:print-i
5810: 6e 66 6f 20 34 20 22 45 6e 64 20 6f 66 20 69 74 nfo 4 "End of it
5820: 65 6d 73 20 6c 69 73 74 2c 20 6c 6f 6f 70 69 6e ems list, loopin
5830: 67 20 77 69 74 68 20 6e 65 78 74 20 61 66 74 65 g with next afte
5840: 72 20 73 68 6f 72 74 20 64 65 6c 61 79 22 29 0a r short delay").
5850: 09 09 20 20 20 20 28 74 68 72 65 61 64 2d 73 6c .. (thread-sl
5860: 65 65 70 21 20 28 2b 20 30 2e 30 31 20 2a 67 6c eep! (+ 0.01 *gl
5870: 6f 62 61 6c 2d 64 65 6c 74 61 2a 29 29 0a 09 09 obal-delta*))...
5880: 20 20 20 20 28 6c 6f 6f 70 20 28 63 61 72 20 74 (loop (car t
5890: 61 6c 29 28 63 64 72 20 74 61 6c 29 20 72 65 72 al)(cdr tal) rer
58a0: 75 6e 73 29 29 29 29 0a 0a 09 20 20 20 20 20 3b uns))))... ;
58b0: 3b 20 69 66 20 69 74 65 6d 73 20 69 73 20 61 20 ; if items is a
58c0: 70 72 6f 63 20 74 68 65 6e 20 6e 65 65 64 20 74 proc then need t
58d0: 6f 20 72 75 6e 20 69 74 65 6d 73 3a 67 65 74 2d o run items:get-
58e0: 69 74 65 6d 73 2d 66 72 6f 6d 2d 63 6f 6e 66 69 items-from-confi
58f0: 67 2c 20 67 65 74 20 74 68 65 20 6c 69 73 74 20 g, get the list
5900: 61 6e 64 20 6c 6f 6f 70 20 0a 09 20 20 20 20 20 and loop ..
5910: 3b 3b 20 20 20 20 2d 20 62 75 74 20 6f 6e 6c 79 ;; - but only
5920: 20 64 6f 20 74 68 61 74 20 69 66 20 72 65 73 6f do that if reso
5930: 75 72 63 65 73 20 65 78 69 73 74 20 74 6f 20 6b urces exist to k
5940: 69 63 6b 20 6f 66 66 20 74 68 65 20 6a 6f 62 0a ick off the job.
5950: 09 20 20 20 20 20 28 28 6f 72 20 28 70 72 6f 63 . ((or (proc
5960: 65 64 75 72 65 3f 20 69 74 65 6d 73 29 28 65 71 edure? items)(eq
5970: 3f 20 69 74 65 6d 73 20 27 68 61 76 65 2d 70 72 ? items 'have-pr
5980: 6f 63 65 64 75 72 65 29 29 0a 09 20 20 20 20 20 ocedure))..
5990: 20 28 6c 65 74 20 28 28 63 61 6e 2d 72 75 6e 2d (let ((can-run-
59a0: 6d 6f 72 65 20 20 20 20 28 72 75 6e 73 3a 63 61 more (runs:ca
59b0: 6e 2d 72 75 6e 2d 6d 6f 72 65 2d 74 65 73 74 73 n-run-more-tests
59c0: 20 74 65 73 74 2d 72 65 63 6f 72 64 29 29 29 0a test-record))).
59d0: 09 09 28 69 66 20 28 61 6e 64 20 28 6c 69 73 74 ..(if (and (list
59e0: 3f 20 63 61 6e 2d 72 75 6e 2d 6d 6f 72 65 29 0a ? can-run-more).
59f0: 09 09 09 20 28 63 61 72 20 63 61 6e 2d 72 75 6e ... (car can-run
5a00: 2d 6d 6f 72 65 29 29 0a 09 09 20 20 20 20 28 6c -more))... (l
5a10: 65 74 2a 20 28 28 70 72 65 72 65 71 73 2d 6e 6f et* ((prereqs-no
5a20: 74 2d 6d 65 74 20 28 6f 70 65 6e 2d 72 75 6e 2d t-met (open-run-
5a30: 63 6c 6f 73 65 20 64 62 3a 67 65 74 2d 70 72 65 close db:get-pre
5a40: 72 65 71 73 2d 6e 6f 74 2d 6d 65 74 20 23 66 20 reqs-not-met #f
5a50: 72 75 6e 2d 69 64 20 77 61 69 74 6f 6e 73 20 69 run-id waitons i
5a60: 74 65 6d 2d 70 61 74 68 20 6d 6f 64 65 3a 20 74 tem-path mode: t
5a70: 65 73 74 6d 6f 64 65 29 29 0a 09 09 09 20 20 20 estmode))....
5a80: 28 66 61 69 6c 73 20 20 20 20 20 20 20 20 20 20 (fails
5a90: 20 28 72 75 6e 73 3a 63 61 6c 63 2d 66 61 69 6c (runs:calc-fail
5aa0: 73 20 70 72 65 72 65 71 73 2d 6e 6f 74 2d 6d 65 s prereqs-not-me
5ab0: 74 29 29 0a 09 09 09 20 20 20 28 6e 6f 6e 2d 63 t)).... (non-c
5ac0: 6f 6d 70 6c 65 74 65 64 20 20 20 28 72 75 6e 73 ompleted (runs
5ad0: 3a 63 61 6c 63 2d 6e 6f 74 2d 63 6f 6d 70 6c 65 :calc-not-comple
5ae0: 74 65 64 20 70 72 65 72 65 71 73 2d 6e 6f 74 2d ted prereqs-not-
5af0: 6d 65 74 29 29 29 0a 09 09 20 20 20 20 20 20 28 met)))... (
5b00: 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f debug:print-info
5b10: 20 38 20 22 63 61 6e 2d 72 75 6e 2d 6d 6f 72 65 8 "can-run-more
5b20: 3a 20 22 20 63 61 6e 2d 72 75 6e 2d 6d 6f 72 65 : " can-run-more
5b30: 0a 09 09 09 09 20 20 20 22 5c 6e 20 74 65 73 74 ..... "\n test
5b40: 6e 61 6d 65 3a 20 20 20 20 20 20 20 20 22 20 68 name: " h
5b50: 65 64 0a 09 09 09 09 20 20 20 22 5c 6e 20 70 72 ed..... "\n pr
5b60: 65 72 65 71 73 2d 6e 6f 74 2d 6d 65 74 3a 20 22 ereqs-not-met: "
5b70: 20 28 72 75 6e 73 3a 70 72 65 74 74 79 2d 73 74 (runs:pretty-st
5b80: 72 69 6e 67 20 70 72 65 72 65 71 73 2d 6e 6f 74 ring prereqs-not
5b90: 2d 6d 65 74 29 0a 09 09 09 09 20 20 20 22 5c 6e -met)..... "\n
5ba0: 20 6e 6f 6e 2d 63 6f 6d 70 6c 65 74 65 64 3a 20 non-completed:
5bb0: 20 20 22 20 28 72 75 6e 73 3a 70 72 65 74 74 79 " (runs:pretty
5bc0: 2d 73 74 72 69 6e 67 20 6e 6f 6e 2d 63 6f 6d 70 -string non-comp
5bd0: 6c 65 74 65 64 29 20 0a 09 09 09 09 20 20 20 22 leted) ..... "
5be0: 5c 6e 20 66 61 69 6c 73 3a 20 20 20 20 20 20 20 \n fails:
5bf0: 20 20 20 20 22 20 28 72 75 6e 73 3a 70 72 65 74 " (runs:pret
5c00: 74 79 2d 73 74 72 69 6e 67 20 66 61 69 6c 73 29 ty-string fails)
5c10: 0a 09 09 09 09 20 20 20 22 5c 6e 20 74 65 73 74 ..... "\n test
5c20: 6d 6f 64 65 3a 20 20 20 20 20 20 20 20 22 20 74 mode: " t
5c30: 65 73 74 6d 6f 64 65 0a 09 09 09 09 20 20 20 22 estmode..... "
5c40: 5c 6e 20 6e 75 6d 2d 72 65 74 72 69 65 73 3a 20 \n num-retries:
5c50: 20 20 20 20 22 20 6e 75 6d 2d 72 65 74 72 69 65 " num-retrie
5c60: 73 0a 09 09 09 09 20 20 20 22 5c 6e 20 28 65 71 s..... "\n (eq
5c70: 3f 20 74 65 73 74 6d 6f 64 65 20 27 74 6f 70 6c ? testmode 'topl
5c80: 65 76 65 6c 29 3a 20 22 20 28 65 71 3f 20 74 65 evel): " (eq? te
5c90: 73 74 6d 6f 64 65 20 27 74 6f 70 6c 65 76 65 6c stmode 'toplevel
5ca0: 29 0a 09 09 09 09 20 20 20 22 5c 6e 20 28 6e 75 )..... "\n (nu
5cb0: 6c 6c 3f 20 6e 6f 6e 2d 63 6f 6d 70 6c 65 74 65 ll? non-complete
5cc0: 64 29 3a 20 20 20 20 22 20 28 6e 75 6c 6c 3f 20 d): " (null?
5cd0: 6e 6f 6e 2d 63 6f 6d 70 6c 65 74 65 64 29 0a 09 non-completed)..
5ce0: 09 09 09 20 20 20 22 5c 6e 20 72 65 72 75 6e 73 ... "\n reruns
5cf0: 3a 20 20 20 20 20 20 20 20 20 20 22 20 72 65 72 : " rer
5d00: 75 6e 73 0a 09 09 09 09 20 20 20 22 5c 6e 20 69 uns..... "\n i
5d10: 74 65 6d 73 3a 20 20 20 20 20 20 20 20 20 20 20 tems:
5d20: 22 20 69 74 65 6d 73 0a 09 09 09 09 20 20 20 22 " items..... "
5d30: 5c 6e 20 63 61 6e 2d 72 75 6e 2d 6d 6f 72 65 3a \n can-run-more:
5d40: 20 20 20 20 22 20 63 61 6e 2d 72 75 6e 2d 6d 6f " can-run-mo
5d50: 72 65 29 0a 09 09 20 20 20 20 20 20 3b 3b 20 28 re)... ;; (
5d60: 74 68 72 65 61 64 2d 73 6c 65 65 70 21 20 28 2b thread-sleep! (+
5d70: 20 30 2e 30 31 20 2a 67 6c 6f 62 61 6c 2d 64 65 0.01 *global-de
5d80: 6c 74 61 2a 29 29 0a 09 09 20 20 20 20 20 20 28 lta*))... (
5d90: 63 6f 6e 64 20 3b 3b 20 49 4e 4e 45 52 20 43 4f cond ;; INNER CO
5da0: 4e 44 20 23 32 0a 09 09 20 20 20 20 20 20 20 28 ND #2... (
5db0: 28 6f 72 20 28 6e 75 6c 6c 3f 20 70 72 65 72 65 (or (null? prere
5dc0: 71 73 2d 6e 6f 74 2d 6d 65 74 29 20 3b 3b 20 61 qs-not-met) ;; a
5dd0: 6c 6c 20 70 72 65 72 65 71 73 20 6d 65 74 2c 20 ll prereqs met,
5de0: 66 69 72 65 20 6f 66 66 20 74 68 65 20 74 65 73 fire off the tes
5df0: 74 0a 09 09 09 20 20 20 20 3b 3b 20 6f 72 2c 20 t.... ;; or,
5e00: 69 66 20 69 74 20 69 73 20 61 20 27 74 6f 70 6c if it is a 'topl
5e10: 65 76 65 6c 20 74 65 73 74 20 61 6e 64 20 61 6c evel test and al
5e20: 6c 20 70 72 65 72 65 71 73 20 6e 6f 74 20 6d 65 l prereqs not me
5e30: 74 20 61 72 65 20 43 4f 4d 50 4c 45 54 45 44 20 t are COMPLETED
5e40: 74 68 65 6e 20 6c 61 75 6e 63 68 0a 09 09 09 20 then launch....
5e50: 20 20 20 28 61 6e 64 20 28 65 71 3f 20 74 65 73 (and (eq? tes
5e60: 74 6d 6f 64 65 20 27 74 6f 70 6c 65 76 65 6c 29 tmode 'toplevel)
5e70: 0a 09 09 09 09 20 28 6e 75 6c 6c 3f 20 6e 6f 6e ..... (null? non
5e80: 2d 63 6f 6d 70 6c 65 74 65 64 29 29 29 0a 09 09 -completed)))...
5e90: 09 28 6c 65 74 20 28 28 74 65 73 74 2d 6e 61 6d .(let ((test-nam
5ea0: 65 20 28 74 65 73 74 73 3a 74 65 73 74 71 75 65 e (tests:testque
5eb0: 75 65 2d 67 65 74 2d 74 65 73 74 6e 61 6d 65 20 ue-get-testname
5ec0: 74 65 73 74 2d 72 65 63 6f 72 64 29 29 29 0a 09 test-record)))..
5ed0: 09 09 20 20 28 73 65 74 65 6e 76 20 22 4d 54 5f .. (setenv "MT_
5ee0: 54 45 53 54 5f 4e 41 4d 45 22 20 74 65 73 74 2d TEST_NAME" test-
5ef0: 6e 61 6d 65 29 20 3b 3b 20 0a 09 09 09 20 20 28 name) ;; .... (
5f00: 73 65 74 65 6e 76 20 22 4d 54 5f 52 55 4e 4e 41 setenv "MT_RUNNA
5f10: 4d 45 22 20 20 20 72 75 6e 6e 61 6d 65 29 0a 09 ME" runname)..
5f20: 09 09 20 20 28 73 65 74 2d 6d 65 67 61 74 65 73 .. (set-megates
5f30: 74 2d 65 6e 76 2d 76 61 72 73 20 72 75 6e 2d 69 t-env-vars run-i
5f40: 64 29 20 3b 3b 20 74 68 65 73 65 20 6d 61 79 20 d) ;; these may
5f50: 62 65 20 6e 65 65 64 65 64 20 62 79 20 74 68 65 be needed by the
5f60: 20 6c 61 75 6e 63 68 69 6e 67 20 70 72 6f 63 65 launching proce
5f70: 73 73 0a 09 09 09 20 20 28 6c 65 74 20 28 28 69 ss.... (let ((i
5f80: 74 65 6d 73 2d 6c 69 73 74 20 28 69 74 65 6d 73 tems-list (items
5f90: 3a 67 65 74 2d 69 74 65 6d 73 2d 66 72 6f 6d 2d :get-items-from-
5fa0: 63 6f 6e 66 69 67 20 74 63 6f 6e 66 69 67 29 29 config tconfig))
5fb0: 29 0a 09 09 09 20 20 20 20 28 69 66 20 28 6c 69 ).... (if (li
5fc0: 73 74 3f 20 69 74 65 6d 73 2d 6c 69 73 74 29 0a st? items-list).
5fd0: 09 09 09 09 28 62 65 67 69 6e 0a 09 09 09 09 20 ....(begin.....
5fe0: 20 28 74 65 73 74 73 3a 74 65 73 74 71 75 65 75 (tests:testqueu
5ff0: 65 2d 73 65 74 2d 69 74 65 6d 73 21 20 74 65 73 e-set-items! tes
6000: 74 2d 72 65 63 6f 72 64 20 69 74 65 6d 73 2d 6c t-record items-l
6010: 69 73 74 29 0a 09 09 09 09 20 20 28 74 68 72 65 ist)..... (thre
6020: 61 64 2d 73 6c 65 65 70 21 20 2a 67 6c 6f 62 61 ad-sleep! *globa
6030: 6c 2d 64 65 6c 74 61 2a 29 0a 09 09 09 09 20 20 l-delta*).....
6040: 28 6c 6f 6f 70 20 68 65 64 20 74 61 6c 20 72 65 (loop hed tal re
6050: 72 75 6e 73 29 29 0a 09 09 09 09 28 62 65 67 69 runs)).....(begi
6060: 6e 0a 09 09 09 09 20 20 28 64 65 62 75 67 3a 70 n..... (debug:p
6070: 72 69 6e 74 20 30 20 22 45 52 52 4f 52 3a 20 54 rint 0 "ERROR: T
6080: 68 65 20 70 72 6f 63 20 66 72 6f 6d 20 72 65 61 he proc from rea
6090: 64 69 6e 67 20 74 68 65 20 73 65 74 75 70 20 64 ding the setup d
60a0: 69 64 20 6e 6f 74 20 79 69 65 6c 64 20 61 20 6c id not yield a l
60b0: 69 73 74 20 2d 20 70 6c 65 61 73 65 20 72 65 70 ist - please rep
60c0: 6f 72 74 20 74 68 69 73 22 29 0a 09 09 09 09 20 ort this").....
60d0: 20 28 65 78 69 74 20 31 29 29 29 29 29 29 0a 09 (exit 1))))))..
60e0: 09 20 20 20 20 20 20 20 28 28 6e 75 6c 6c 3f 20 . ((null?
60f0: 66 61 69 6c 73 29 0a 09 09 09 28 64 65 62 75 67 fails)....(debug
6100: 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 34 20 22 66 :print-info 4 "f
6110: 61 69 6c 73 20 69 73 20 6e 75 6c 6c 2c 20 6d 6f ails is null, mo
6120: 76 69 6e 67 20 6f 6e 20 69 6e 20 74 68 65 20 71 ving on in the q
6130: 75 65 75 65 20 62 75 74 20 6b 65 65 70 69 6e 67 ueue but keeping
6140: 20 22 20 68 65 64 20 22 20 66 6f 72 20 6e 6f 77 " hed " for now
6150: 22 29 0a 09 09 09 3b 3b 20 6f 6e 6c 79 20 69 6e ")....;; only in
6160: 63 72 65 6d 65 6e 74 20 6e 75 6d 2d 72 65 74 72 crement num-retr
6170: 69 65 73 20 77 68 65 6e 20 74 68 65 72 65 20 61 ies when there a
6180: 72 65 20 6e 6f 20 74 65 73 74 73 20 72 75 6e 69 re no tests runi
6190: 6e 67 0a 09 09 09 28 69 66 20 28 65 71 3f 20 30 ng....(if (eq? 0
61a0: 20 28 6c 69 73 74 2d 72 65 66 20 63 61 6e 2d 72 (list-ref can-r
61b0: 75 6e 2d 6d 6f 72 65 20 31 29 29 0a 09 09 09 20 un-more 1))....
61c0: 20 20 20 28 62 65 67 69 6e 0a 09 09 09 20 20 20 (begin....
61d0: 20 20 20 28 69 66 20 28 3e 20 6e 75 6d 2d 72 65 (if (> num-re
61e0: 74 72 69 65 73 20 31 30 30 29 20 3b 3b 20 66 69 tries 100) ;; fi
61f0: 72 73 74 20 31 30 30 20 72 65 74 72 69 65 73 20 rst 100 retries
6200: 61 72 65 20 6c 6f 77 20 74 69 6d 65 20 63 6f 73 are low time cos
6210: 74 0a 09 09 09 09 20 20 28 74 68 72 65 61 64 2d t..... (thread-
6220: 73 6c 65 65 70 21 20 28 2b 20 32 20 2a 67 6c 6f sleep! (+ 2 *glo
6230: 62 61 6c 2d 64 65 6c 74 61 2a 29 29 0a 09 09 09 bal-delta*))....
6240: 09 20 20 28 74 68 72 65 61 64 2d 73 6c 65 65 70 . (thread-sleep
6250: 21 20 28 2b 20 30 2e 30 31 20 2a 67 6c 6f 62 61 ! (+ 0.01 *globa
6260: 6c 2d 64 65 6c 74 61 2a 29 29 29 0a 09 09 09 20 l-delta*)))....
6270: 20 20 20 20 20 28 73 65 74 21 20 6e 75 6d 2d 72 (set! num-r
6280: 65 74 72 69 65 73 20 28 2b 20 6e 75 6d 2d 72 65 etries (+ num-re
6290: 74 72 69 65 73 20 31 29 29 29 29 0a 09 09 09 28 tries 1))))....(
62a0: 69 66 20 28 3e 20 6e 75 6d 2d 72 65 74 72 69 65 if (> num-retrie
62b0: 73 20 20 6d 61 78 2d 72 65 74 72 69 65 73 29 0a s max-retries).
62c0: 09 09 09 20 20 20 20 28 69 66 20 28 6e 6f 74 20 ... (if (not
62d0: 28 6e 75 6c 6c 3f 20 74 61 6c 29 29 0a 09 09 09 (null? tal))....
62e0: 09 28 6c 6f 6f 70 20 28 63 61 72 20 74 61 6c 29 .(loop (car tal)
62f0: 28 63 64 72 20 74 61 6c 29 20 72 65 72 75 6e 73 (cdr tal) reruns
6300: 29 29 0a 09 09 09 20 20 20 20 28 6c 6f 6f 70 20 )).... (loop
6310: 28 63 61 72 20 6e 65 77 74 61 6c 29 28 63 64 72 (car newtal)(cdr
6320: 20 6e 65 77 74 61 6c 29 20 72 65 72 75 6e 73 29 newtal) reruns)
6330: 29 29 20 3b 3b 20 61 6e 20 69 73 73 75 65 20 77 )) ;; an issue w
6340: 69 74 68 20 70 72 65 72 65 71 73 20 6e 6f 74 20 ith prereqs not
6350: 79 65 74 20 6d 65 74 3f 0a 09 09 20 20 20 20 20 yet met?...
6360: 20 20 28 28 61 6e 64 20 28 6e 6f 74 20 28 6e 75 ((and (not (nu
6370: 6c 6c 3f 20 66 61 69 6c 73 29 29 28 65 71 3f 20 ll? fails))(eq?
6380: 74 65 73 74 6d 6f 64 65 20 27 6e 6f 72 6d 61 6c testmode 'normal
6390: 29 29 0a 09 09 09 28 64 65 62 75 67 3a 70 72 69 ))....(debug:pri
63a0: 6e 74 2d 69 6e 66 6f 20 31 20 22 74 65 73 74 20 nt-info 1 "test
63b0: 22 20 20 68 65 64 20 22 20 28 6d 6f 64 65 3d 22 " hed " (mode="
63c0: 20 74 65 73 74 6d 6f 64 65 20 22 29 20 68 61 73 testmode ") has
63d0: 20 66 61 69 6c 65 64 20 70 72 65 72 65 71 75 69 failed prerequi
63e0: 73 69 74 65 28 73 29 3b 20 22 0a 09 09 09 09 20 site(s); ".....
63f0: 20 20 20 20 28 73 74 72 69 6e 67 2d 69 6e 74 65 (string-inte
6400: 72 73 70 65 72 73 65 20 28 6d 61 70 20 28 6c 61 rsperse (map (la
6410: 6d 62 64 61 20 28 74 29 28 63 6f 6e 63 20 28 64 mbda (t)(conc (d
6420: 62 3a 74 65 73 74 2d 67 65 74 2d 74 65 73 74 6e b:test-get-testn
6430: 61 6d 65 20 74 29 20 22 3a 22 20 28 64 62 3a 74 ame t) ":" (db:t
6440: 65 73 74 2d 67 65 74 2d 73 74 61 74 65 20 74 29 est-get-state t)
6450: 22 2f 22 28 64 62 3a 74 65 73 74 2d 67 65 74 2d "/"(db:test-get-
6460: 73 74 61 74 75 73 20 74 29 29 29 20 66 61 69 6c status t))) fail
6470: 73 29 20 22 2c 20 22 29 0a 09 09 09 09 20 20 20 s) ", ").....
6480: 20 20 22 2c 20 72 65 6d 6f 76 69 6e 67 20 69 74 ", removing it
6490: 20 66 72 6f 6d 20 74 6f 2d 64 6f 20 6c 69 73 74 from to-do list
64a0: 22 29 0a 09 09 09 28 69 66 20 28 6e 6f 74 20 28 ")....(if (not (
64b0: 6e 75 6c 6c 3f 20 74 61 6c 29 29 0a 09 09 09 20 null? tal))....
64c0: 20 20 20 28 62 65 67 69 6e 0a 09 09 09 20 20 20 (begin....
64d0: 20 20 20 28 74 68 72 65 61 64 2d 73 6c 65 65 70 (thread-sleep
64e0: 21 20 2a 67 6c 6f 62 61 6c 2d 64 65 6c 74 61 2a ! *global-delta*
64f0: 29 0a 09 09 09 20 20 20 20 20 20 28 6c 6f 6f 70 ).... (loop
6500: 20 28 63 61 72 20 74 61 6c 29 28 63 64 72 20 74 (car tal)(cdr t
6510: 61 6c 29 28 63 6f 6e 73 20 68 65 64 20 72 65 72 al)(cons hed rer
6520: 75 6e 73 29 29 29 29 29 0a 09 09 20 20 20 20 20 uns)))))...
6530: 20 20 28 65 6c 73 65 0a 09 09 09 28 64 65 62 75 (else....(debu
6540: 67 3a 70 72 69 6e 74 20 38 20 22 45 52 52 4f 52 g:print 8 "ERROR
6550: 3a 20 4e 6f 20 68 61 6e 64 6c 65 72 20 66 6f 72 : No handler for
6560: 20 74 68 69 73 20 63 6f 6e 64 69 74 69 6f 6e 2e this condition.
6570: 22 29 0a 09 09 09 28 74 68 72 65 61 64 2d 73 6c ")....(thread-sl
6580: 65 65 70 21 20 28 2b 20 31 20 2a 67 6c 6f 62 61 eep! (+ 1 *globa
6590: 6c 2d 64 65 6c 74 61 2a 29 29 0a 09 09 09 28 6c l-delta*))....(l
65a0: 6f 6f 70 20 28 63 61 72 20 6e 65 77 74 61 6c 29 oop (car newtal)
65b0: 28 63 64 72 20 6e 65 77 74 61 6c 29 20 72 65 72 (cdr newtal) rer
65c0: 75 6e 73 29 29 29 29 20 3b 3b 20 45 4e 44 20 4f uns)))) ;; END O
65d0: 46 20 49 46 20 43 41 4e 20 52 55 4e 20 4d 4f 52 F IF CAN RUN MOR
65e0: 45 0a 0a 09 09 20 20 20 20 3b 3b 20 69 66 20 63 E.... ;; if c
65f0: 61 6e 27 74 20 72 75 6e 20 6d 6f 72 65 20 6a 75 an't run more ju
6600: 73 74 20 6c 6f 6f 70 20 77 69 74 68 20 6e 65 78 st loop with nex
6610: 74 20 70 6f 73 73 69 62 6c 65 20 74 65 73 74 0a t possible test.
6620: 09 09 20 20 20 20 28 62 65 67 69 6e 0a 09 09 20 .. (begin...
6630: 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e (debug:prin
6640: 74 2d 69 6e 66 6f 20 34 20 22 70 72 6f 63 65 73 t-info 4 "proces
6650: 73 69 6e 67 20 74 68 65 20 63 61 73 65 20 77 69 sing the case wi
6660: 74 68 20 61 20 6c 61 6d 62 64 61 20 66 6f 72 20 th a lambda for
6670: 69 74 65 6d 73 20 6f 72 20 27 68 61 76 65 2d 70 items or 'have-p
6680: 72 6f 63 65 64 75 72 65 2e 20 4d 6f 76 69 6e 67 rocedure. Moving
6690: 20 74 68 72 6f 75 67 68 20 74 68 65 20 71 75 65 through the que
66a0: 75 65 20 77 69 74 68 6f 75 74 20 64 72 6f 70 70 ue without dropp
66b0: 69 6e 67 20 22 20 68 65 64 29 0a 09 09 20 20 20 ing " hed)...
66c0: 20 20 20 28 74 68 72 65 61 64 2d 73 6c 65 65 70 (thread-sleep
66d0: 21 20 28 2b 20 32 20 2a 67 6c 6f 62 61 6c 2d 64 ! (+ 2 *global-d
66e0: 65 6c 74 61 2a 29 29 0a 09 09 20 20 20 20 20 20 elta*))...
66f0: 28 6c 6f 6f 70 20 28 63 61 72 20 6e 65 77 74 61 (loop (car newta
6700: 6c 29 28 63 64 72 20 6e 65 77 74 61 6c 29 20 72 l)(cdr newtal) r
6710: 65 72 75 6e 73 29 29 29 29 29 20 3b 3b 20 45 4e eruns))))) ;; EN
6720: 44 20 4f 46 20 28 6f 72 20 28 70 72 6f 63 65 64 D OF (or (proced
6730: 75 72 65 3f 20 69 74 65 6d 73 29 28 65 71 3f 20 ure? items)(eq?
6740: 69 74 65 6d 73 20 27 68 61 76 65 2d 70 72 6f 63 items 'have-proc
6750: 65 64 75 72 65 29 29 0a 09 20 20 20 20 20 0a 09 edure)).. ..
6760: 20 20 20 20 20 3b 3b 20 74 68 69 73 20 63 61 73 ;; this cas
6770: 65 20 73 68 6f 75 6c 64 20 6e 6f 74 20 68 61 70 e should not hap
6780: 70 65 6e 2c 20 61 64 64 65 64 20 74 6f 20 68 65 pen, added to he
6790: 6c 70 20 63 61 74 63 68 20 61 6e 79 20 62 75 67 lp catch any bug
67a0: 73 0a 09 20 20 20 20 20 28 28 61 6e 64 20 28 6c s.. ((and (l
67b0: 69 73 74 3f 20 69 74 65 6d 73 29 20 69 74 65 6d ist? items) item
67c0: 64 61 74 29 0a 09 20 20 20 20 20 20 28 64 65 62 dat).. (deb
67d0: 75 67 3a 70 72 69 6e 74 20 30 20 22 45 52 52 4f ug:print 0 "ERRO
67e0: 52 3a 20 53 68 6f 75 6c 64 20 6e 6f 74 20 68 61 R: Should not ha
67f0: 76 65 20 61 20 6c 69 73 74 20 6f 66 20 69 74 65 ve a list of ite
6800: 6d 73 20 69 6e 20 61 20 74 65 73 74 20 61 6e 64 ms in a test and
6810: 20 74 68 65 20 69 74 65 6d 73 70 61 74 68 20 73 the itemspath s
6820: 65 74 20 2d 20 70 6c 65 61 73 65 20 72 65 70 6f et - please repo
6830: 72 74 20 74 68 69 73 22 29 0a 09 20 20 20 20 20 rt this")..
6840: 20 28 65 78 69 74 20 31 29 29 0a 09 20 20 20 20 (exit 1))..
6850: 20 28 28 6e 6f 74 20 28 6e 75 6c 6c 3f 20 72 65 ((not (null? re
6860: 72 75 6e 73 29 29 0a 09 20 20 20 20 20 20 28 6c runs)).. (l
6870: 65 74 2a 20 28 28 6e 65 77 6c 73 74 20 28 74 65 et* ((newlst (te
6880: 73 74 73 3a 66 69 6c 74 65 72 2d 6e 6f 6e 2d 72 sts:filter-non-r
6890: 75 6e 6e 61 62 6c 65 20 72 75 6e 2d 69 64 20 74 unnable run-id t
68a0: 61 6c 20 74 65 73 74 2d 72 65 63 6f 72 64 73 29 al test-records)
68b0: 29 20 3b 3b 20 69 2e 65 2e 20 6e 6f 74 20 46 41 ) ;; i.e. not FA
68c0: 49 4c 2c 20 57 41 49 56 45 44 2c 20 49 4e 43 4f IL, WAIVED, INCO
68d0: 4d 50 4c 45 54 45 2c 20 50 41 53 53 2c 20 4b 49 MPLETE, PASS, KI
68e0: 4c 4c 45 44 2c 0a 09 09 20 20 20 20 20 28 6a 75 LLED,... (ju
68f0: 6e 6b 65 64 20 28 6c 73 65 74 2d 64 69 66 66 65 nked (lset-diffe
6900: 72 65 6e 63 65 20 65 71 75 61 6c 3f 20 74 61 6c rence equal? tal
6910: 20 6e 65 77 6c 73 74 29 29 29 0a 09 09 28 64 65 newlst)))...(de
6920: 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 34 bug:print-info 4
6930: 20 22 66 75 6c 6c 20 64 72 6f 70 20 74 68 72 6f "full drop thro
6940: 75 67 68 2c 20 69 66 20 72 65 72 75 6e 73 20 69 ugh, if reruns i
6950: 73 20 6c 65 73 73 20 74 68 61 6e 20 31 30 30 20 s less than 100
6960: 77 65 20 77 69 6c 6c 20 66 6f 72 63 65 20 72 65 we will force re
6970: 74 72 79 20 74 68 65 6d 2c 20 72 65 72 75 6e 73 try them, reruns
6980: 3d 22 20 72 65 72 75 6e 73 20 22 2c 20 74 61 6c =" reruns ", tal
6990: 3d 22 20 74 61 6c 29 0a 09 09 28 69 66 20 28 3c =" tal)...(if (<
69a0: 20 6e 75 6d 2d 72 65 74 72 69 65 73 20 6d 61 78 num-retries max
69b0: 2d 72 65 74 72 69 65 73 29 0a 09 09 20 20 20 20 -retries)...
69c0: 28 73 65 74 21 20 6e 65 77 6c 73 74 20 28 61 70 (set! newlst (ap
69d0: 70 65 6e 64 20 72 65 72 75 6e 73 20 6e 65 77 6c pend reruns newl
69e0: 73 74 29 29 29 0a 09 09 28 73 65 74 21 20 6e 75 st)))...(set! nu
69f0: 6d 2d 72 65 74 72 69 65 73 20 28 2b 20 6e 75 6d m-retries (+ num
6a00: 2d 72 65 74 72 69 65 73 20 31 29 29 0a 09 09 28 -retries 1))...(
6a10: 74 68 72 65 61 64 2d 73 6c 65 65 70 21 20 28 2b thread-sleep! (+
6a20: 20 31 20 2a 67 6c 6f 62 61 6c 2d 64 65 6c 74 61 1 *global-delta
6a30: 2a 29 29 0a 09 09 28 69 66 20 28 6e 6f 74 20 28 *))...(if (not (
6a40: 6e 75 6c 6c 3f 20 6e 65 77 6c 73 74 29 29 0a 09 null? newlst))..
6a50: 09 20 20 20 20 3b 3b 20 73 69 6e 63 65 20 72 65 . ;; since re
6a60: 72 75 6e 73 20 68 61 76 65 20 62 65 65 6e 20 74 runs have been t
6a70: 61 63 6b 65 64 20 6f 6e 20 74 6f 20 6e 65 77 6c acked on to newl
6a80: 73 74 20 63 72 65 61 74 65 20 6e 65 77 20 72 65 st create new re
6a90: 72 75 6e 73 20 66 72 6f 6d 20 6a 75 6e 6b 65 64 runs from junked
6aa0: 0a 09 09 20 20 20 20 28 6c 6f 6f 70 20 28 63 61 ... (loop (ca
6ab0: 72 20 6e 65 77 6c 73 74 29 28 63 64 72 20 6e 65 r newlst)(cdr ne
6ac0: 77 6c 73 74 29 28 64 65 6c 65 74 65 2d 64 75 70 wlst)(delete-dup
6ad0: 6c 69 63 61 74 65 73 20 6a 75 6e 6b 65 64 29 29 licates junked))
6ae0: 29 29 29 0a 09 20 20 20 20 20 28 28 6e 6f 74 20 ))).. ((not
6af0: 28 6e 75 6c 6c 3f 20 74 61 6c 29 29 0a 09 20 20 (null? tal))..
6b00: 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 (debug:print
6b10: 2d 69 6e 66 6f 20 34 20 22 49 27 6d 20 70 72 65 -info 4 "I'm pre
6b20: 74 74 79 20 73 75 72 65 20 49 20 73 68 6f 75 6c tty sure I shoul
6b30: 64 6e 27 74 20 67 65 74 20 68 65 72 65 2e 22 29 dn't get here.")
6b40: 29 0a 09 20 20 20 20 20 28 65 6c 73 65 0a 09 20 ).. (else..
6b50: 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e (debug:prin
6b60: 74 2d 69 6e 66 6f 20 34 20 22 45 78 69 74 69 6e t-info 4 "Exitin
6b70: 67 20 6c 6f 6f 70 20 77 69 74 68 2e 2e 2e 5c 6e g loop with...\n
6b80: 20 20 68 65 64 3d 22 20 68 65 64 20 22 5c 6e 20 hed=" hed "\n
6b90: 20 74 61 6c 3d 22 20 74 61 6c 20 22 5c 6e 20 20 tal=" tal "\n
6ba0: 72 65 72 75 6e 73 3d 22 20 72 65 72 75 6e 73 29 reruns=" reruns)
6bb0: 29 0a 09 20 20 20 20 20 29 29 29 29 20 3b 3b 20 ).. )))) ;;
6bc0: 4c 45 54 2a 20 28 28 74 65 73 74 2d 72 65 63 6f LET* ((test-reco
6bd0: 72 64 0a 0a 20 20 20 20 3b 3b 20 77 65 20 67 65 rd.. ;; we ge
6be0: 74 20 68 65 72 65 20 6f 6e 20 22 64 72 6f 70 20 t here on "drop
6bf0: 74 68 72 6f 75 67 68 22 20 2d 20 6c 6f 6f 70 20 through" - loop
6c00: 66 6f 72 20 6e 65 78 74 20 74 65 73 74 20 69 6e for next test in
6c10: 20 71 75 65 75 65 0a 20 20 20 20 3b 3b 20 46 49 queue. ;; FI
6c20: 58 4d 45 21 21 21 21 20 54 48 49 53 20 53 48 4f XME!!!! THIS SHO
6c30: 55 4c 44 20 4e 4f 54 20 52 45 51 55 49 52 45 20 ULD NOT REQUIRE
6c40: 41 4e 20 45 58 49 54 21 21 21 21 21 21 21 0a 20 AN EXIT!!!!!!!.
6c50: 20 20 20 0a 20 20 20 20 28 64 65 62 75 67 3a 70 . (debug:p
6c60: 72 69 6e 74 2d 69 6e 66 6f 20 31 20 22 41 6c 6c rint-info 1 "All
6c70: 20 74 65 73 74 73 20 6c 61 75 6e 63 68 65 64 22 tests launched"
6c80: 29 0a 20 20 20 20 28 74 68 72 65 61 64 2d 73 6c ). (thread-sl
6c90: 65 65 70 21 20 30 2e 35 29 0a 20 20 20 20 3b 3b eep! 0.5). ;;
6ca0: 20 46 49 58 4d 45 21 20 54 68 69 73 20 68 61 72 FIXME! This har
6cb0: 73 68 20 65 78 69 74 20 73 68 6f 75 6c 64 20 6e sh exit should n
6cc0: 6f 74 20 62 65 20 6e 65 63 65 73 73 61 72 79 2e ot be necessary.
6cd0: 2e 2e 2e 0a 20 20 20 20 3b 3b 20 28 69 66 20 28 .... ;; (if (
6ce0: 6e 6f 74 20 2a 72 75 6e 72 65 6d 6f 74 65 2a 29 not *runremote*)
6cf0: 28 65 78 69 74 29 29 20 3b 3b 20 0a 20 20 20 20 (exit)) ;; .
6d00: 23 66 29 29 20 3b 3b 20 72 65 74 75 72 6e 20 61 #f)) ;; return a
6d10: 20 23 66 20 61 73 20 61 20 68 69 6e 74 20 74 68 #f as a hint th
6d20: 61 74 20 77 65 20 61 72 65 20 64 6f 6e 65 0a 20 at we are done.
6d30: 20 3b 3b 20 48 65 72 65 20 77 65 20 6e 65 65 64 ;; Here we need
6d40: 20 74 6f 20 63 68 65 63 6b 20 74 68 61 74 20 61 to check that a
6d50: 6c 6c 20 74 68 65 20 74 65 73 74 73 20 72 65 6d ll the tests rem
6d60: 61 69 6e 69 6e 67 20 74 6f 20 62 65 20 72 75 6e aining to be run
6d70: 20 61 72 65 20 65 6c 69 67 69 62 6c 65 20 74 6f are eligible to
6d80: 20 72 75 6e 0a 20 20 3b 3b 20 61 6e 64 20 61 72 run. ;; and ar
6d90: 65 20 6e 6f 74 20 62 6c 6f 63 6b 65 64 20 62 79 e not blocked by
6da0: 20 66 61 69 6c 65 64 0a 20 20 0a 0a 3b 3b 20 70 failed. ..;; p
6db0: 61 72 65 6e 74 2d 74 65 73 74 20 69 73 20 74 68 arent-test is th
6dc0: 65 72 65 20 61 73 20 61 20 70 6c 61 63 65 68 6f ere as a placeho
6dd0: 6c 64 65 72 20 66 6f 72 20 77 68 65 6e 20 70 61 lder for when pa
6de0: 72 65 6e 74 2d 74 65 73 74 73 20 63 61 6e 20 62 rent-tests can b
6df0: 65 20 72 75 6e 20 61 73 20 61 20 73 65 74 75 70 e run as a setup
6e00: 20 73 74 65 70 0a 28 64 65 66 69 6e 65 20 28 72 step.(define (r
6e10: 75 6e 3a 74 65 73 74 20 72 75 6e 2d 69 64 20 72 un:test run-id r
6e20: 75 6e 6e 61 6d 65 20 6b 65 79 76 61 6c 6c 73 74 unname keyvallst
6e30: 20 74 65 73 74 2d 72 65 63 6f 72 64 20 66 6c 61 test-record fla
6e40: 67 73 20 70 61 72 65 6e 74 2d 74 65 73 74 29 0a gs parent-test).
6e50: 20 20 3b 3b 20 41 6c 6c 20 74 68 65 73 65 20 76 ;; All these v
6e60: 61 72 73 20 6d 69 67 68 74 20 62 65 20 72 65 66 ars might be ref
6e70: 65 72 65 6e 63 65 64 20 62 79 20 74 68 65 20 74 erenced by the t
6e80: 65 73 74 63 6f 6e 66 69 67 20 66 69 6c 65 20 72 estconfig file r
6e90: 65 61 64 65 72 0a 20 20 28 6c 65 74 2a 20 28 28 eader. (let* ((
6ea0: 74 65 73 74 2d 6e 61 6d 65 20 20 20 20 28 74 65 test-name (te
6eb0: 73 74 73 3a 74 65 73 74 71 75 65 75 65 2d 67 65 sts:testqueue-ge
6ec0: 74 2d 74 65 73 74 6e 61 6d 65 20 20 20 74 65 73 t-testname tes
6ed0: 74 2d 72 65 63 6f 72 64 29 29 0a 09 20 28 74 65 t-record)).. (te
6ee0: 73 74 2d 77 61 69 74 6f 6e 73 20 28 74 65 73 74 st-waitons (test
6ef0: 73 3a 74 65 73 74 71 75 65 75 65 2d 67 65 74 2d s:testqueue-get-
6f00: 77 61 69 74 6f 6e 73 20 20 20 20 74 65 73 74 2d waitons test-
6f10: 72 65 63 6f 72 64 29 29 0a 09 20 28 74 65 73 74 record)).. (test
6f20: 2d 63 6f 6e 66 20 20 20 20 28 74 65 73 74 73 3a -conf (tests:
6f30: 74 65 73 74 71 75 65 75 65 2d 67 65 74 2d 74 65 testqueue-get-te
6f40: 73 74 63 6f 6e 66 69 67 20 74 65 73 74 2d 72 65 stconfig test-re
6f50: 63 6f 72 64 29 29 0a 09 20 28 69 74 65 6d 64 61 cord)).. (itemda
6f60: 74 20 20 20 20 20 20 28 74 65 73 74 73 3a 74 65 t (tests:te
6f70: 73 74 71 75 65 75 65 2d 67 65 74 2d 69 74 65 6d stqueue-get-item
6f80: 64 61 74 20 20 20 20 74 65 73 74 2d 72 65 63 6f dat test-reco
6f90: 72 64 29 29 0a 09 20 28 74 65 73 74 2d 70 61 74 rd)).. (test-pat
6fa0: 68 20 20 20 20 28 63 6f 6e 63 20 2a 74 6f 70 70 h (conc *topp
6fb0: 61 74 68 2a 20 22 2f 74 65 73 74 73 2f 22 20 74 ath* "/tests/" t
6fc0: 65 73 74 2d 6e 61 6d 65 29 29 20 3b 3b 20 63 6f est-name)) ;; co
6fd0: 75 6c 64 20 75 73 65 20 74 65 73 74 73 3a 67 65 uld use tests:ge
6fe0: 74 2d 74 65 73 74 63 6f 6e 66 69 67 20 68 65 72 t-testconfig her
6ff0: 65 20 2e 2e 2e 0a 09 20 28 66 6f 72 63 65 20 20 e ..... (force
7000: 20 20 20 20 20 20 28 68 61 73 68 2d 74 61 62 6c (hash-tabl
7010: 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 66 6c e-ref/default fl
7020: 61 67 73 20 22 2d 66 6f 72 63 65 22 20 23 66 29 ags "-force" #f)
7030: 29 0a 09 20 28 72 65 72 75 6e 20 20 20 20 20 20 ).. (rerun
7040: 20 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 (hash-table-re
7050: 66 2f 64 65 66 61 75 6c 74 20 66 6c 61 67 73 20 f/default flags
7060: 22 2d 72 65 72 75 6e 22 20 23 66 29 29 0a 09 20 "-rerun" #f))..
7070: 28 6b 65 65 70 67 6f 69 6e 67 20 20 20 20 28 68 (keepgoing (h
7080: 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 ash-table-ref/de
7090: 66 61 75 6c 74 20 66 6c 61 67 73 20 22 2d 6b 65 fault flags "-ke
70a0: 65 70 67 6f 69 6e 67 22 20 23 66 29 29 0a 09 20 epgoing" #f))..
70b0: 28 69 74 65 6d 2d 70 61 74 68 20 20 20 20 20 22 (item-path "
70c0: 22 29 0a 09 20 28 64 62 20 20 20 20 20 20 20 20 ").. (db
70d0: 20 20 20 23 66 29 29 0a 20 20 20 20 28 64 65 62 #f)). (deb
70e0: 75 67 3a 70 72 69 6e 74 20 34 0a 09 09 20 22 74 ug:print 4... "t
70f0: 65 73 74 2d 63 6f 6e 66 69 67 3a 20 22 20 28 68 est-config: " (h
7100: 61 73 68 2d 74 61 62 6c 65 2d 3e 61 6c 69 73 74 ash-table->alist
7110: 20 74 65 73 74 2d 63 6f 6e 66 29 0a 09 09 20 22 test-conf)... "
7120: 5c 6e 20 20 20 69 74 65 6d 64 61 74 3a 20 22 20 \n itemdat: "
7130: 69 74 65 6d 64 61 74 0a 09 09 20 29 0a 20 20 20 itemdat... ).
7140: 20 3b 3b 20 73 65 74 74 69 6e 67 20 69 74 65 6d ;; setting item
7150: 64 61 74 20 74 6f 20 61 20 6c 69 73 74 20 69 66 dat to a list if
7160: 20 69 74 20 69 73 20 23 66 0a 20 20 20 20 28 69 it is #f. (i
7170: 66 20 28 6e 6f 74 20 69 74 65 6d 64 61 74 29 28 f (not itemdat)(
7180: 73 65 74 21 20 69 74 65 6d 64 61 74 20 27 28 29 set! itemdat '()
7190: 29 29 0a 20 20 20 20 28 73 65 74 21 20 69 74 65 )). (set! ite
71a0: 6d 2d 70 61 74 68 20 28 69 74 65 6d 2d 6c 69 73 m-path (item-lis
71b0: 74 2d 3e 70 61 74 68 20 69 74 65 6d 64 61 74 29 t->path itemdat)
71c0: 29 0a 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 ). (debug:pri
71d0: 6e 74 20 32 20 22 41 74 74 65 6d 70 74 69 6e 67 nt 2 "Attempting
71e0: 20 74 6f 20 6c 61 75 6e 63 68 20 74 65 73 74 20 to launch test
71f0: 22 20 74 65 73 74 2d 6e 61 6d 65 20 28 69 66 20 " test-name (if
7200: 28 65 71 75 61 6c 3f 20 69 74 65 6d 2d 70 61 74 (equal? item-pat
7210: 68 20 22 2f 22 29 20 22 2f 22 20 69 74 65 6d 2d h "/") "/" item-
7220: 70 61 74 68 29 29 0a 20 20 20 20 28 73 65 74 65 path)). (sete
7230: 6e 76 20 22 4d 54 5f 54 45 53 54 5f 4e 41 4d 45 nv "MT_TEST_NAME
7240: 22 20 74 65 73 74 2d 6e 61 6d 65 29 20 3b 3b 20 " test-name) ;;
7250: 0a 20 20 20 20 28 73 65 74 65 6e 76 20 22 4d 54 . (setenv "MT
7260: 5f 52 55 4e 4e 41 4d 45 22 20 20 20 72 75 6e 6e _RUNNAME" runn
7270: 61 6d 65 29 0a 20 20 20 20 28 73 65 74 2d 6d 65 ame). (set-me
7280: 67 61 74 65 73 74 2d 65 6e 76 2d 76 61 72 73 20 gatest-env-vars
7290: 72 75 6e 2d 69 64 29 20 3b 3b 20 74 68 65 73 65 run-id) ;; these
72a0: 20 6d 61 79 20 62 65 20 6e 65 65 64 65 64 20 62 may be needed b
72b0: 79 20 74 68 65 20 6c 61 75 6e 63 68 69 6e 67 20 y the launching
72c0: 70 72 6f 63 65 73 73 0a 20 20 20 20 28 63 68 61 process. (cha
72d0: 6e 67 65 2d 64 69 72 65 63 74 6f 72 79 20 2a 74 nge-directory *t
72e0: 6f 70 70 61 74 68 2a 29 0a 0a 20 20 20 20 3b 3b oppath*).. ;;
72f0: 20 48 65 72 65 20 69 73 20 77 68 65 72 65 20 74 Here is where t
7300: 68 65 20 74 65 73 74 5f 6d 65 74 61 20 74 61 62 he test_meta tab
7310: 6c 65 20 69 73 20 62 65 73 74 20 75 70 64 61 74 le is best updat
7320: 65 64 0a 20 20 20 20 3b 3b 20 59 65 73 2c 20 61 ed. ;; Yes, a
7330: 6e 6f 74 68 65 72 20 75 73 65 20 6f 66 20 61 20 nother use of a
7340: 67 6c 6f 62 61 6c 20 66 6f 72 20 63 61 63 68 69 global for cachi
7350: 6e 67 2e 20 4e 65 65 64 20 61 20 62 65 74 74 65 ng. Need a bette
7360: 72 20 77 61 79 3f 0a 20 20 20 20 28 69 66 20 28 r way?. (if (
7370: 6e 6f 74 20 28 68 61 73 68 2d 74 61 62 6c 65 2d not (hash-table-
7380: 72 65 66 2f 64 65 66 61 75 6c 74 20 2a 74 65 73 ref/default *tes
7390: 74 2d 6d 65 74 61 2d 75 70 64 61 74 65 64 2a 20 t-meta-updated*
73a0: 74 65 73 74 2d 6e 61 6d 65 20 23 66 29 29 0a 20 test-name #f)).
73b0: 20 20 20 20 20 20 20 28 62 65 67 69 6e 0a 09 20 (begin..
73c0: 20 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 (hash-table-se
73d0: 74 21 20 2a 74 65 73 74 2d 6d 65 74 61 2d 75 70 t! *test-meta-up
73e0: 64 61 74 65 64 2a 20 74 65 73 74 2d 6e 61 6d 65 dated* test-name
73f0: 20 23 74 29 0a 20 20 20 20 20 20 20 20 20 20 20 #t).
7400: 28 6f 70 65 6e 2d 72 75 6e 2d 63 6c 6f 73 65 20 (open-run-close
7410: 72 75 6e 73 3a 75 70 64 61 74 65 2d 74 65 73 74 runs:update-test
7420: 5f 6d 65 74 61 20 64 62 20 74 65 73 74 2d 6e 61 _meta db test-na
7430: 6d 65 20 74 65 73 74 2d 63 6f 6e 66 29 29 29 0a me test-conf))).
7440: 20 20 20 20 0a 20 20 20 20 3b 3b 20 28 6c 61 6d . ;; (lam
7450: 62 64 61 20 28 69 74 65 6d 64 61 74 29 20 3b 3b bda (itemdat) ;;
7460: 3b 20 28 28 72 69 70 65 6e 65 73 73 20 22 6f 76 ; ((ripeness "ov
7470: 65 72 72 69 70 65 22 29 20 28 74 65 6d 70 65 72 erripe") (temper
7480: 61 74 75 72 65 20 22 63 6f 6f 6c 22 29 20 28 73 ature "cool") (s
7490: 65 61 73 6f 6e 20 22 73 75 6d 6d 65 72 22 29 29 eason "summer"))
74a0: 0a 20 20 20 20 28 6c 65 74 2a 20 28 28 6e 65 77 . (let* ((new
74b0: 2d 74 65 73 74 2d 70 61 74 68 20 28 73 74 72 69 -test-path (stri
74c0: 6e 67 2d 69 6e 74 65 72 73 70 65 72 73 65 20 28 ng-intersperse (
74d0: 63 6f 6e 73 20 74 65 73 74 2d 70 61 74 68 20 28 cons test-path (
74e0: 6d 61 70 20 63 61 64 72 20 69 74 65 6d 64 61 74 map cadr itemdat
74f0: 29 29 20 22 2f 22 29 29 0a 09 20 20 20 28 6e 65 )) "/")).. (ne
7500: 77 2d 74 65 73 74 2d 6e 61 6d 65 20 28 69 66 20 w-test-name (if
7510: 28 65 71 75 61 6c 3f 20 69 74 65 6d 2d 70 61 74 (equal? item-pat
7520: 68 20 22 22 29 20 74 65 73 74 2d 6e 61 6d 65 20 h "") test-name
7530: 28 63 6f 6e 63 20 74 65 73 74 2d 6e 61 6d 65 20 (conc test-name
7540: 22 2f 22 20 69 74 65 6d 2d 70 61 74 68 29 29 29 "/" item-path)))
7550: 20 3b 3b 20 6a 75 73 74 20 6e 65 65 64 20 69 74 ;; just need it
7560: 20 74 6f 20 62 65 20 75 6e 69 71 75 65 0a 09 20 to be unique..
7570: 20 20 28 74 65 73 74 2d 69 64 20 20 20 20 20 20 (test-id
7580: 20 28 63 64 62 3a 72 65 6d 6f 74 65 2d 72 75 6e (cdb:remote-run
7590: 20 64 62 3a 67 65 74 2d 74 65 73 74 2d 69 64 20 db:get-test-id
75a0: 23 66 20 20 72 75 6e 2d 69 64 20 74 65 73 74 2d #f run-id test-
75b0: 6e 61 6d 65 20 69 74 65 6d 2d 70 61 74 68 29 29 name item-path))
75c0: 0a 09 20 20 20 28 74 65 73 74 64 61 74 20 20 20 .. (testdat
75d0: 20 20 20 20 28 63 64 62 3a 67 65 74 2d 74 65 73 (cdb:get-tes
75e0: 74 2d 69 6e 66 6f 2d 62 79 2d 69 64 20 2a 72 75 t-info-by-id *ru
75f0: 6e 72 65 6d 6f 74 65 2a 20 74 65 73 74 2d 69 64 nremote* test-id
7600: 29 29 29 0a 20 20 20 20 20 20 28 69 66 20 28 6e ))). (if (n
7610: 6f 74 20 74 65 73 74 64 61 74 29 0a 09 20 20 28 ot testdat).. (
7620: 62 65 67 69 6e 0a 09 20 20 20 20 3b 3b 20 65 6e begin.. ;; en
7630: 73 75 72 65 20 74 68 61 74 20 74 68 65 20 70 61 sure that the pa
7640: 74 68 20 65 78 69 73 74 73 20 62 65 66 6f 72 65 th exists before
7650: 20 72 65 67 69 73 74 65 72 69 6e 67 20 74 68 65 registering the
7660: 20 74 65 73 74 0a 09 20 20 20 20 3b 3b 20 4e 4f test.. ;; NO
7670: 50 45 3a 20 43 61 6e 6e 6f 74 21 20 44 6f 6e 27 PE: Cannot! Don'
7680: 74 20 6b 6e 6f 77 20 79 65 74 20 77 68 69 63 68 t know yet which
7690: 20 64 69 73 6b 20 61 72 65 61 20 77 69 6c 6c 20 disk area will
76a0: 62 65 20 61 73 73 69 67 6e 65 64 2e 2e 2e 2e 0a be assigned.....
76b0: 09 20 20 20 20 3b 3b 20 28 73 79 73 74 65 6d 20 . ;; (system
76c0: 28 63 6f 6e 63 20 22 6d 6b 64 69 72 20 2d 70 20 (conc "mkdir -p
76d0: 22 20 6e 65 77 2d 74 65 73 74 2d 70 61 74 68 29 " new-test-path)
76e0: 29 0a 09 20 20 20 20 3b 3b 0a 09 20 20 20 20 3b ).. ;;.. ;
76f0: 3b 20 28 6f 70 65 6e 2d 72 75 6e 2d 63 6c 6f 73 ; (open-run-clos
7700: 65 20 74 65 73 74 73 3a 72 65 67 69 73 74 65 72 e tests:register
7710: 2d 74 65 73 74 20 64 62 20 72 75 6e 2d 69 64 20 -test db run-id
7720: 74 65 73 74 2d 6e 61 6d 65 20 69 74 65 6d 2d 70 test-name item-p
7730: 61 74 68 29 0a 09 20 20 20 20 3b 3b 0a 09 20 20 ath).. ;;..
7740: 20 20 3b 3b 20 4e 42 2f 2f 20 66 6f 72 20 74 68 ;; NB// for th
7750: 65 20 61 62 6f 76 65 20 6c 69 6e 65 2e 20 49 20 e above line. I
7760: 77 61 6e 74 20 74 68 65 20 74 65 73 74 20 74 6f want the test to
7770: 20 62 65 20 72 65 67 69 73 74 65 72 65 64 20 6c be registered l
7780: 6f 6e 67 20 62 65 66 6f 72 65 20 74 68 69 73 20 ong before this
7790: 72 6f 75 74 69 6e 65 20 67 65 74 73 20 63 61 6c routine gets cal
77a0: 6c 65 64 21 0a 09 20 20 20 20 3b 3b 0a 09 20 20 led!.. ;;..
77b0: 20 20 28 73 65 74 21 20 74 65 73 74 2d 69 64 20 (set! test-id
77c0: 28 6f 70 65 6e 2d 72 75 6e 2d 63 6c 6f 73 65 20 (open-run-close
77d0: 64 62 3a 67 65 74 2d 74 65 73 74 2d 69 64 20 64 db:get-test-id d
77e0: 62 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 6e 61 b run-id test-na
77f0: 6d 65 20 69 74 65 6d 2d 70 61 74 68 29 29 0a 09 me item-path))..
7800: 20 20 20 20 28 69 66 20 28 6e 6f 74 20 74 65 73 (if (not tes
7810: 74 2d 69 64 29 0a 09 09 28 62 65 67 69 6e 0a 09 t-id)...(begin..
7820: 09 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 . (debug:print
7830: 32 20 22 57 41 52 4e 3a 20 54 65 73 74 20 6e 6f 2 "WARN: Test no
7840: 74 20 70 72 65 2d 63 72 65 61 74 65 64 3f 20 74 t pre-created? t
7850: 65 73 74 2d 6e 61 6d 65 3d 22 20 74 65 73 74 2d est-name=" test-
7860: 6e 61 6d 65 20 22 2c 20 69 74 65 6d 2d 70 61 74 name ", item-pat
7870: 68 3d 22 20 69 74 65 6d 2d 70 61 74 68 20 22 2c h=" item-path ",
7880: 20 72 75 6e 2d 69 64 3d 22 20 72 75 6e 2d 69 64 run-id=" run-id
7890: 29 0a 09 09 20 20 28 6f 70 65 6e 2d 72 75 6e 2d )... (open-run-
78a0: 63 6c 6f 73 65 20 64 62 3a 74 65 73 74 73 2d 72 close db:tests-r
78b0: 65 67 69 73 74 65 72 2d 74 65 73 74 20 23 66 20 egister-test #f
78c0: 72 75 6e 2d 69 64 20 74 65 73 74 2d 6e 61 6d 65 run-id test-name
78d0: 20 69 74 65 6d 2d 70 61 74 68 29 0a 09 09 20 20 item-path)...
78e0: 28 73 65 74 21 20 74 65 73 74 2d 69 64 20 28 6f (set! test-id (o
78f0: 70 65 6e 2d 72 75 6e 2d 63 6c 6f 73 65 20 64 62 pen-run-close db
7900: 3a 67 65 74 2d 74 65 73 74 2d 69 64 20 64 62 20 :get-test-id db
7910: 72 75 6e 2d 69 64 20 74 65 73 74 2d 6e 61 6d 65 run-id test-name
7920: 20 69 74 65 6d 2d 70 61 74 68 29 29 29 29 0a 09 item-path))))..
7930: 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 (debug:print
7940: 2d 69 6e 66 6f 20 34 20 22 74 65 73 74 2d 69 64 -info 4 "test-id
7950: 3d 22 20 74 65 73 74 2d 69 64 20 22 2c 20 72 75 =" test-id ", ru
7960: 6e 2d 69 64 3d 22 20 72 75 6e 2d 69 64 20 22 2c n-id=" run-id ",
7970: 20 74 65 73 74 2d 6e 61 6d 65 3d 22 20 74 65 73 test-name=" tes
7980: 74 2d 6e 61 6d 65 20 22 2c 20 69 74 65 6d 2d 70 t-name ", item-p
7990: 61 74 68 3d 5c 22 22 20 69 74 65 6d 2d 70 61 74 ath=\"" item-pat
79a0: 68 20 22 5c 22 22 29 0a 09 20 20 20 20 28 73 65 h "\"").. (se
79b0: 74 21 20 74 65 73 74 64 61 74 20 28 63 64 62 3a t! testdat (cdb:
79c0: 67 65 74 2d 74 65 73 74 2d 69 6e 66 6f 2d 62 79 get-test-info-by
79d0: 2d 69 64 20 2a 72 75 6e 72 65 6d 6f 74 65 2a 20 -id *runremote*
79e0: 74 65 73 74 2d 69 64 29 29 29 29 0a 20 20 20 20 test-id)))).
79f0: 20 20 28 73 65 74 21 20 74 65 73 74 2d 69 64 20 (set! test-id
7a00: 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 69 64 20 (db:test-get-id
7a10: 74 65 73 74 64 61 74 29 29 0a 20 20 20 20 20 20 testdat)).
7a20: 28 63 68 61 6e 67 65 2d 64 69 72 65 63 74 6f 72 (change-director
7a30: 79 20 74 65 73 74 2d 70 61 74 68 29 0a 20 20 20 y test-path).
7a40: 20 20 20 28 63 61 73 65 20 28 69 66 20 66 6f 72 (case (if for
7a50: 63 65 20 3b 3b 20 28 61 72 67 73 3a 67 65 74 2d ce ;; (args:get-
7a60: 61 72 67 20 22 2d 66 6f 72 63 65 22 29 0a 09 09 arg "-force")...
7a70: 27 4e 4f 54 5f 53 54 41 52 54 45 44 0a 09 09 28 'NOT_STARTED...(
7a80: 69 66 20 74 65 73 74 64 61 74 0a 09 09 20 20 20 if testdat...
7a90: 20 28 73 74 72 69 6e 67 2d 3e 73 79 6d 62 6f 6c (string->symbol
7aa0: 20 28 74 65 73 74 3a 67 65 74 2d 73 74 61 74 65 (test:get-state
7ab0: 20 74 65 73 74 64 61 74 29 29 0a 09 09 20 20 20 testdat))...
7ac0: 20 27 66 61 69 6c 65 64 2d 74 6f 2d 69 6e 73 65 'failed-to-inse
7ad0: 72 74 29 29 0a 09 28 28 66 61 69 6c 65 64 2d 74 rt))..((failed-t
7ae0: 6f 2d 69 6e 73 65 72 74 29 0a 09 20 28 64 65 62 o-insert).. (deb
7af0: 75 67 3a 70 72 69 6e 74 20 30 20 22 45 52 52 4f ug:print 0 "ERRO
7b00: 52 3a 20 46 61 69 6c 65 64 20 74 6f 20 69 6e 73 R: Failed to ins
7b10: 65 72 74 20 74 68 65 20 72 65 63 6f 72 64 20 69 ert the record i
7b20: 6e 74 6f 20 74 68 65 20 64 62 22 29 29 0a 09 28 nto the db"))..(
7b30: 28 4e 4f 54 5f 53 54 41 52 54 45 44 20 43 4f 4d (NOT_STARTED COM
7b40: 50 4c 45 54 45 44 20 44 45 4c 45 54 45 44 29 0a PLETED DELETED).
7b50: 09 20 28 6c 65 74 20 28 28 72 75 6e 66 6c 61 67 . (let ((runflag
7b60: 20 23 66 29 29 0a 09 20 20 20 28 63 6f 6e 64 0a #f)).. (cond.
7b70: 09 20 20 20 20 3b 3b 20 2d 66 6f 72 63 65 2c 20 . ;; -force,
7b80: 72 75 6e 20 6e 6f 20 6d 61 74 74 65 72 20 77 68 run no matter wh
7b90: 61 74 0a 09 20 20 20 20 28 66 6f 72 63 65 20 28 at.. (force (
7ba0: 73 65 74 21 20 72 75 6e 66 6c 61 67 20 23 74 29 set! runflag #t)
7bb0: 29 0a 09 20 20 20 20 3b 3b 20 4e 4f 54 5f 53 54 ).. ;; NOT_ST
7bc0: 41 52 54 45 44 2c 20 72 75 6e 20 6e 6f 20 6d 61 ARTED, run no ma
7bd0: 74 74 65 72 20 77 68 61 74 0a 09 20 20 20 20 28 tter what.. (
7be0: 28 6d 65 6d 62 65 72 20 28 74 65 73 74 3a 67 65 (member (test:ge
7bf0: 74 2d 73 74 61 74 65 20 74 65 73 74 64 61 74 29 t-state testdat)
7c00: 20 27 28 22 44 45 4c 45 54 45 44 22 20 22 4e 4f '("DELETED" "NO
7c10: 54 5f 53 54 41 52 54 45 44 22 29 29 28 73 65 74 T_STARTED"))(set
7c20: 21 20 72 75 6e 66 6c 61 67 20 23 74 29 29 0a 09 ! runflag #t))..
7c30: 20 20 20 20 3b 3b 20 6e 6f 74 20 2d 72 65 72 75 ;; not -reru
7c40: 6e 20 61 6e 64 20 50 41 53 53 2c 20 57 41 52 4e n and PASS, WARN
7c50: 20 6f 72 20 43 48 45 43 4b 2c 20 64 6f 20 6e 6f or CHECK, do no
7c60: 20 72 75 6e 0a 09 20 20 20 20 28 28 61 6e 64 20 run.. ((and
7c70: 28 6f 72 20 28 6e 6f 74 20 72 65 72 75 6e 29 0a (or (not rerun).
7c80: 09 09 20 20 20 20 20 20 6b 65 65 70 67 6f 69 6e .. keepgoin
7c90: 67 29 0a 09 09 20 20 3b 3b 20 52 65 71 75 69 72 g)... ;; Requir
7ca0: 65 20 74 6f 20 66 6f 72 63 65 20 72 65 2d 72 75 e to force re-ru
7cb0: 6e 20 66 6f 72 20 43 4f 4d 50 4c 45 54 45 44 20 n for COMPLETED
7cc0: 6f 72 20 2a 61 6e 79 74 68 69 6e 67 2a 20 2b 20 or *anything* +
7cd0: 50 41 53 53 2c 57 41 52 4e 20 6f 72 20 43 48 45 PASS,WARN or CHE
7ce0: 43 4b 0a 09 09 20 20 28 6f 72 20 28 6d 65 6d 62 CK... (or (memb
7cf0: 65 72 20 28 74 65 73 74 3a 67 65 74 2d 73 74 61 er (test:get-sta
7d00: 74 75 73 20 74 65 73 74 64 61 74 29 20 27 28 22 tus testdat) '("
7d10: 50 41 53 53 22 20 22 57 41 52 4e 22 20 22 43 48 PASS" "WARN" "CH
7d20: 45 43 4b 22 29 29 0a 09 09 20 20 20 20 20 20 28 ECK"))... (
7d30: 6d 65 6d 62 65 72 20 28 74 65 73 74 3a 67 65 74 member (test:get
7d40: 2d 73 74 61 74 65 20 20 74 65 73 74 64 61 74 29 -state testdat)
7d50: 20 27 28 22 43 4f 4d 50 4c 45 54 45 44 22 29 29 '("COMPLETED"))
7d60: 29 29 20 0a 09 20 20 20 20 20 28 64 65 62 75 67 )) .. (debug
7d70: 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 32 20 22 72 :print-info 2 "r
7d80: 75 6e 6e 69 6e 67 20 74 65 73 74 20 22 20 74 65 unning test " te
7d90: 73 74 2d 6e 61 6d 65 20 22 2f 22 20 69 74 65 6d st-name "/" item
7da0: 2d 70 61 74 68 20 22 20 73 75 70 70 72 65 73 73 -path " suppress
7db0: 65 64 20 61 73 20 69 74 20 69 73 20 22 20 28 74 ed as it is " (t
7dc0: 65 73 74 3a 67 65 74 2d 73 74 61 74 65 20 74 65 est:get-state te
7dd0: 73 74 64 61 74 29 20 22 20 61 6e 64 20 22 20 28 stdat) " and " (
7de0: 74 65 73 74 3a 67 65 74 2d 73 74 61 74 75 73 20 test:get-status
7df0: 74 65 73 74 64 61 74 29 29 0a 09 20 20 20 20 20 testdat))..
7e00: 28 73 65 74 21 20 72 75 6e 66 6c 61 67 20 23 66 (set! runflag #f
7e10: 29 29 0a 09 20 20 20 20 3b 3b 20 2d 72 65 72 75 )).. ;; -reru
7e20: 6e 20 61 6e 64 20 73 74 61 74 75 73 20 69 73 20 n and status is
7e30: 6f 6e 65 20 6f 66 20 74 68 65 20 73 70 65 63 69 one of the speci
7e40: 66 65 64 2c 20 72 75 6e 20 69 74 0a 09 20 20 20 fed, run it..
7e50: 20 28 28 61 6e 64 20 72 65 72 75 6e 0a 09 09 20 ((and rerun...
7e60: 20 28 6c 65 74 2a 20 28 28 72 65 72 75 6e 6c 73 (let* ((rerunls
7e70: 74 20 20 20 28 73 74 72 69 6e 67 2d 73 70 6c 69 t (string-spli
7e80: 74 20 72 65 72 75 6e 20 22 2c 22 29 29 0a 09 09 t rerun ","))...
7e90: 09 20 28 6d 75 73 74 2d 72 65 72 75 6e 20 28 6d . (must-rerun (m
7ea0: 65 6d 62 65 72 20 28 74 65 73 74 3a 67 65 74 2d ember (test:get-
7eb0: 73 74 61 74 75 73 20 74 65 73 74 64 61 74 29 20 status testdat)
7ec0: 72 65 72 75 6e 6c 73 74 29 29 29 0a 09 09 20 20 rerunlst)))...
7ed0: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 (debug:print-i
7ee0: 6e 66 6f 20 33 20 22 2d 72 65 72 75 6e 20 6c 69 nfo 3 "-rerun li
7ef0: 73 74 3a 20 22 20 72 65 72 75 6e 20 22 2c 20 74 st: " rerun ", t
7f00: 65 73 74 2d 73 74 61 74 75 73 3a 20 22 20 28 74 est-status: " (t
7f10: 65 73 74 3a 67 65 74 2d 73 74 61 74 75 73 20 74 est:get-status t
7f20: 65 73 74 64 61 74 29 22 2c 20 6d 75 73 74 2d 72 estdat)", must-r
7f30: 65 72 75 6e 3a 20 22 20 6d 75 73 74 2d 72 65 72 erun: " must-rer
7f40: 75 6e 29 0a 09 09 20 20 20 20 6d 75 73 74 2d 72 un)... must-r
7f50: 65 72 75 6e 29 29 0a 09 20 20 20 20 20 28 64 65 erun)).. (de
7f60: 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 32 bug:print-info 2
7f70: 20 22 52 65 72 75 6e 20 66 6f 72 63 65 64 20 66 "Rerun forced f
7f80: 6f 72 20 74 65 73 74 20 22 20 74 65 73 74 2d 6e or test " test-n
7f90: 61 6d 65 20 22 2f 22 20 69 74 65 6d 2d 70 61 74 ame "/" item-pat
7fa0: 68 29 0a 09 20 20 20 20 20 28 73 65 74 21 20 72 h).. (set! r
7fb0: 75 6e 66 6c 61 67 20 23 74 29 29 0a 09 20 20 20 unflag #t))..
7fc0: 20 3b 3b 20 2d 6b 65 65 70 67 6f 69 6e 67 2c 20 ;; -keepgoing,
7fd0: 64 6f 20 6e 6f 74 20 72 65 72 75 6e 20 46 41 49 do not rerun FAI
7fe0: 4c 0a 09 20 20 20 20 28 28 61 6e 64 20 6b 65 65 L.. ((and kee
7ff0: 70 67 6f 69 6e 67 0a 09 09 20 20 28 6d 65 6d 62 pgoing... (memb
8000: 65 72 20 28 74 65 73 74 3a 67 65 74 2d 73 74 61 er (test:get-sta
8010: 74 75 73 20 74 65 73 74 64 61 74 29 20 27 28 22 tus testdat) '("
8020: 46 41 49 4c 22 29 29 29 0a 09 20 20 20 20 20 28 FAIL"))).. (
8030: 73 65 74 21 20 72 75 6e 66 6c 61 67 20 23 66 29 set! runflag #f)
8040: 29 0a 09 20 20 20 20 28 28 61 6e 64 20 28 6e 6f ).. ((and (no
8050: 74 20 72 65 72 75 6e 29 0a 09 09 20 20 28 6d 65 t rerun)... (me
8060: 6d 62 65 72 20 28 74 65 73 74 3a 67 65 74 2d 73 mber (test:get-s
8070: 74 61 74 75 73 20 74 65 73 74 64 61 74 29 20 27 tatus testdat) '
8080: 28 22 46 41 49 4c 22 20 22 6e 2f 61 22 29 29 29 ("FAIL" "n/a")))
8090: 0a 09 20 20 20 20 20 28 73 65 74 21 20 72 75 6e .. (set! run
80a0: 66 6c 61 67 20 23 74 29 29 0a 09 20 20 20 20 28 flag #t)).. (
80b0: 65 6c 73 65 20 28 73 65 74 21 20 72 75 6e 66 6c else (set! runfl
80c0: 61 67 20 23 66 29 29 29 0a 09 20 20 20 28 64 65 ag #f))).. (de
80d0: 62 75 67 3a 70 72 69 6e 74 20 36 20 22 52 55 4e bug:print 6 "RUN
80e0: 4e 49 4e 47 20 3d 3e 20 72 75 6e 66 6c 61 67 3a NING => runflag:
80f0: 20 22 20 72 75 6e 66 6c 61 67 20 22 20 53 54 41 " runflag " STA
8100: 54 45 3a 20 22 20 28 74 65 73 74 3a 67 65 74 2d TE: " (test:get-
8110: 73 74 61 74 65 20 74 65 73 74 64 61 74 29 20 22 state testdat) "
8120: 20 53 54 41 54 55 53 3a 20 22 20 28 74 65 73 74 STATUS: " (test
8130: 3a 67 65 74 2d 73 74 61 74 75 73 20 74 65 73 74 :get-status test
8140: 64 61 74 29 29 0a 09 20 20 20 28 69 66 20 28 6e dat)).. (if (n
8150: 6f 74 20 72 75 6e 66 6c 61 67 29 0a 09 20 20 20 ot runflag)..
8160: 20 20 20 20 28 69 66 20 28 6e 6f 74 20 70 61 72 (if (not par
8170: 65 6e 74 2d 74 65 73 74 29 0a 09 09 20 20 20 28 ent-test)... (
8180: 64 65 62 75 67 3a 70 72 69 6e 74 20 31 20 22 4e debug:print 1 "N
8190: 4f 54 45 3a 20 4e 6f 74 20 73 74 61 72 74 69 6e OTE: Not startin
81a0: 67 20 74 65 73 74 20 22 20 6e 65 77 2d 74 65 73 g test " new-tes
81b0: 74 2d 6e 61 6d 65 20 22 20 61 73 20 69 74 20 69 t-name " as it i
81c0: 73 20 73 74 61 74 65 20 5c 22 22 20 28 74 65 73 s state \"" (tes
81d0: 74 3a 67 65 74 2d 73 74 61 74 65 20 74 65 73 74 t:get-state test
81e0: 64 61 74 29 20 0a 09 09 09 09 22 5c 22 20 61 6e dat) ....."\" an
81f0: 64 20 73 74 61 74 75 73 20 5c 22 22 20 28 74 65 d status \"" (te
8200: 73 74 3a 67 65 74 2d 73 74 61 74 75 73 20 74 65 st:get-status te
8210: 73 74 64 61 74 29 20 22 5c 22 2c 20 75 73 65 20 stdat) "\", use
8220: 2d 72 65 72 75 6e 20 5c 22 22 20 28 74 65 73 74 -rerun \"" (test
8230: 3a 67 65 74 2d 73 74 61 74 75 73 20 74 65 73 74 :get-status test
8240: 64 61 74 29 0a 20 20 20 20 20 20 20 20 20 20 20 dat).
8250: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8260: 20 20 20 20 20 22 5c 22 20 6f 72 20 2d 66 6f 72 "\" or -for
8270: 63 65 20 74 6f 20 6f 76 65 72 72 69 64 65 22 29 ce to override")
8280: 29 0a 09 20 20 20 20 20 20 20 3b 3b 20 4e 4f 54 ).. ;; NOT
8290: 45 3a 20 4e 6f 20 6c 6f 6e 67 65 72 20 62 65 20 E: No longer be
82a0: 63 68 65 63 6b 69 6e 67 20 70 72 65 72 65 71 75 checking prerequ
82b0: 69 73 69 74 65 73 20 68 65 72 65 21 20 57 69 6c isites here! Wil
82c0: 6c 20 6e 65 76 65 72 20 67 65 74 20 68 65 72 65 l never get here
82d0: 20 75 6e 6c 65 73 73 20 70 72 65 72 65 71 73 20 unless prereqs
82e0: 61 72 65 0a 09 20 20 20 20 20 20 20 3b 3b 20 20 are.. ;;
82f0: 20 20 20 20 20 61 6c 72 65 61 64 79 20 6d 65 74 already met
8300: 2e 0a 09 20 20 20 20 20 20 20 28 69 66 20 28 6e ... (if (n
8310: 6f 74 20 28 6c 61 75 6e 63 68 2d 74 65 73 74 20 ot (launch-test
8320: 23 66 20 72 75 6e 2d 69 64 20 72 75 6e 6e 61 6d #f run-id runnam
8330: 65 20 74 65 73 74 2d 63 6f 6e 66 20 6b 65 79 76 e test-conf keyv
8340: 61 6c 6c 73 74 20 74 65 73 74 2d 6e 61 6d 65 20 allst test-name
8350: 74 65 73 74 2d 70 61 74 68 20 69 74 65 6d 64 61 test-path itemda
8360: 74 20 66 6c 61 67 73 29 29 0a 09 09 20 20 20 28 t flags))... (
8370: 62 65 67 69 6e 0a 09 09 20 20 20 20 20 28 70 72 begin... (pr
8380: 69 6e 74 20 22 45 52 52 4f 52 3a 20 46 61 69 6c int "ERROR: Fail
8390: 65 64 20 74 6f 20 6c 61 75 6e 63 68 20 74 68 65 ed to launch the
83a0: 20 74 65 73 74 2e 20 45 78 69 74 69 6e 67 20 61 test. Exiting a
83b0: 73 20 73 6f 6f 6e 20 61 73 20 70 6f 73 73 69 62 s soon as possib
83c0: 6c 65 22 29 0a 09 09 20 20 20 20 20 28 73 65 74 le")... (set
83d0: 21 20 2a 67 6c 6f 62 61 6c 65 78 69 74 73 74 61 ! *globalexitsta
83e0: 74 75 73 2a 20 31 29 20 3b 3b 20 0a 09 09 20 20 tus* 1) ;; ...
83f0: 20 20 20 28 70 72 6f 63 65 73 73 2d 73 69 67 6e (process-sign
8400: 61 6c 20 28 63 75 72 72 65 6e 74 2d 70 72 6f 63 al (current-proc
8410: 65 73 73 2d 69 64 29 20 73 69 67 6e 61 6c 2f 6b ess-id) signal/k
8420: 69 6c 6c 29 29 29 29 29 29 0a 09 28 28 4b 49 4c ill))))))..((KIL
8430: 4c 45 44 29 20 0a 09 20 28 64 65 62 75 67 3a 70 LED) .. (debug:p
8440: 72 69 6e 74 20 31 20 22 4e 4f 54 45 3a 20 22 20 rint 1 "NOTE: "
8450: 6e 65 77 2d 74 65 73 74 2d 6e 61 6d 65 20 22 20 new-test-name "
8460: 69 73 20 61 6c 72 65 61 64 79 20 72 75 6e 6e 69 is already runni
8470: 6e 67 20 6f 72 20 77 61 73 20 65 78 70 6c 69 63 ng or was explic
8480: 74 6c 79 20 6b 69 6c 6c 65 64 2c 20 75 73 65 20 tly killed, use
8490: 2d 66 6f 72 63 65 20 74 6f 20 6c 61 75 6e 63 68 -force to launch
84a0: 20 69 74 2e 22 29 29 0a 09 28 28 4c 41 55 4e 43 it."))..((LAUNC
84b0: 48 45 44 20 52 45 4d 4f 54 45 48 4f 53 54 53 54 HED REMOTEHOSTST
84c0: 41 52 54 20 52 55 4e 4e 49 4e 47 29 20 20 0a 09 ART RUNNING) ..
84d0: 20 28 69 66 20 28 3e 20 28 2d 20 28 63 75 72 72 (if (> (- (curr
84e0: 65 6e 74 2d 73 65 63 6f 6e 64 73 29 28 2b 20 28 ent-seconds)(+ (
84f0: 64 62 3a 74 65 73 74 2d 67 65 74 2d 65 76 65 6e db:test-get-even
8500: 74 5f 74 69 6d 65 20 74 65 73 74 64 61 74 29 0a t_time testdat).
8510: 09 09 09 09 20 20 20 20 20 20 20 28 64 62 3a 74 .... (db:t
8520: 65 73 74 2d 67 65 74 2d 72 75 6e 5f 64 75 72 61 est-get-run_dura
8530: 74 69 6f 6e 20 74 65 73 74 64 61 74 29 29 29 0a tion testdat))).
8540: 09 09 36 30 30 29 20 3b 3b 20 69 2e 65 2e 20 6e ..600) ;; i.e. n
8550: 6f 20 75 70 64 61 74 65 20 66 6f 72 20 6d 6f 72 o update for mor
8560: 65 20 74 68 61 6e 20 36 30 30 20 73 65 63 6f 6e e than 600 secon
8570: 64 73 0a 09 20 20 20 20 20 28 62 65 67 69 6e 0a ds.. (begin.
8580: 09 20 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 . (debug:p
8590: 72 69 6e 74 20 30 20 22 57 41 52 4e 49 4e 47 3a rint 0 "WARNING:
85a0: 20 54 65 73 74 20 22 20 74 65 73 74 2d 6e 61 6d Test " test-nam
85b0: 65 20 22 20 61 70 70 65 61 72 73 20 74 6f 20 62 e " appears to b
85c0: 65 20 64 65 61 64 2e 20 46 6f 72 63 69 6e 67 20 e dead. Forcing
85d0: 69 74 20 74 6f 20 73 74 61 74 65 20 49 4e 43 4f it to state INCO
85e0: 4d 50 4c 45 54 45 20 61 6e 64 20 73 74 61 74 75 MPLETE and statu
85f0: 73 20 53 54 55 43 4b 2f 44 45 41 44 22 29 0a 09 s STUCK/DEAD")..
8600: 20 20 20 20 20 20 20 28 74 65 73 74 73 3a 74 65 (tests:te
8610: 73 74 2d 73 65 74 2d 73 74 61 74 75 73 21 20 74 st-set-status! t
8620: 65 73 74 2d 69 64 20 22 49 4e 43 4f 4d 50 4c 45 est-id "INCOMPLE
8630: 54 45 22 20 22 53 54 55 43 4b 2f 44 45 41 44 22 TE" "STUCK/DEAD"
8640: 20 22 54 65 73 74 20 69 73 20 73 74 75 63 6b 20 "Test is stuck
8650: 6f 72 20 64 65 61 64 22 20 23 66 29 29 0a 09 20 or dead" #f))..
8660: 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 (debug:print
8670: 20 32 20 22 4e 4f 54 45 3a 20 22 20 74 65 73 74 2 "NOTE: " test
8680: 2d 6e 61 6d 65 20 22 20 69 73 20 61 6c 72 65 61 -name " is alrea
8690: 64 79 20 72 75 6e 6e 69 6e 67 22 29 29 29 0a 09 dy running")))..
86a0: 28 65 6c 73 65 20 20 20 20 20 20 20 28 64 65 62 (else (deb
86b0: 75 67 3a 70 72 69 6e 74 20 30 20 22 45 52 52 4f ug:print 0 "ERRO
86c0: 52 3a 20 46 61 69 6c 65 64 20 74 6f 20 6c 61 75 R: Failed to lau
86d0: 6e 63 68 20 74 65 73 74 20 22 20 6e 65 77 2d 74 nch test " new-t
86e0: 65 73 74 2d 6e 61 6d 65 20 22 2e 20 55 6e 72 65 est-name ". Unre
86f0: 63 6f 67 6e 69 73 65 64 20 73 74 61 74 65 20 22 cognised state "
8700: 20 28 74 65 73 74 3a 67 65 74 2d 73 74 61 74 65 (test:get-state
8710: 20 74 65 73 74 64 61 74 29 29 29 29 29 29 29 0a testdat))))))).
8720: 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d .;;=============
8730: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8740: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8750: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8760: 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 45 4e 44 =========.;; END
8770: 20 4f 46 20 4e 45 57 20 53 54 55 46 46 0a 3b 3b OF NEW STUFF.;;
8780: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8790: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
87a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
87b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
87c0: 3d 3d 3d 3d 3d 3d 0a 0a 28 64 65 66 69 6e 65 20 ======..(define
87d0: 28 67 65 74 2d 64 69 72 2d 75 70 2d 6e 20 64 69 (get-dir-up-n di
87e0: 72 20 2e 20 70 61 72 61 6d 73 29 20 0a 20 20 28 r . params) . (
87f0: 6c 65 74 20 28 28 64 70 61 72 74 73 20 20 28 73 let ((dparts (s
8800: 74 72 69 6e 67 2d 73 70 6c 69 74 20 64 69 72 20 tring-split dir
8810: 22 2f 22 29 29 0a 09 28 63 6f 75 6e 74 20 20 20 "/"))..(count
8820: 28 69 66 20 28 6e 75 6c 6c 3f 20 70 61 72 61 6d (if (null? param
8830: 73 29 20 31 20 28 63 61 72 20 70 61 72 61 6d 73 s) 1 (car params
8840: 29 29 29 29 0a 20 20 20 20 28 63 6f 6e 63 20 22 )))). (conc "
8850: 2f 22 20 28 73 74 72 69 6e 67 2d 69 6e 74 65 72 /" (string-inter
8860: 73 70 65 72 73 65 20 0a 09 20 20 20 20 20 20 20 sperse ..
8870: 28 74 61 6b 65 20 64 70 61 72 74 73 20 28 2d 20 (take dparts (-
8880: 28 6c 65 6e 67 74 68 20 64 70 61 72 74 73 29 20 (length dparts)
8890: 63 6f 75 6e 74 29 29 0a 09 20 20 20 20 20 20 20 count))..
88a0: 22 2f 22 29 29 29 29 0a 3b 3b 20 52 65 6d 6f 76 "/")))).;; Remov
88b0: 65 20 72 75 6e 73 0a 3b 3b 20 66 69 65 6c 64 73 e runs.;; fields
88c0: 20 61 72 65 20 70 61 73 73 69 6e 67 20 69 6e 20 are passing in
88d0: 74 68 72 6f 75 67 68 20 0a 3b 3b 20 61 63 74 69 through .;; acti
88e0: 6f 6e 3a 0a 3b 3b 20 20 20 20 27 72 65 6d 6f 76 on:.;; 'remov
88f0: 65 2d 72 75 6e 73 0a 3b 3b 20 20 20 20 27 73 65 e-runs.;; 'se
8900: 74 2d 73 74 61 74 65 2d 73 74 61 74 75 73 0a 3b t-state-status.;
8910: 3b 0a 3b 3b 20 4e 42 2f 2f 20 73 68 6f 75 6c 64 ;.;; NB// should
8920: 20 70 61 73 73 20 69 6e 20 6b 65 79 73 3f 0a 3b pass in keys?.;
8930: 3b 0a 28 64 65 66 69 6e 65 20 28 72 75 6e 73 3a ;.(define (runs:
8940: 6f 70 65 72 61 74 65 2d 6f 6e 20 61 63 74 69 6f operate-on actio
8950: 6e 20 72 75 6e 6e 61 6d 65 70 61 74 74 20 74 65 n runnamepatt te
8960: 73 74 70 61 74 74 20 23 21 6b 65 79 20 28 73 74 stpatt #!key (st
8970: 61 74 65 20 23 66 29 28 73 74 61 74 75 73 20 23 ate #f)(status #
8980: 66 29 28 6e 65 77 2d 73 74 61 74 65 2d 73 74 61 f)(new-state-sta
8990: 74 75 73 20 23 66 29 29 0a 20 20 28 63 6f 6d 6d tus #f)). (comm
89a0: 6f 6e 3a 63 6c 65 61 72 2d 63 61 63 68 65 73 29 on:clear-caches)
89b0: 20 3b 3b 20 63 6c 65 61 72 20 61 6c 6c 20 63 61 ;; clear all ca
89c0: 63 68 65 73 0a 20 20 28 6c 65 74 2a 20 28 28 64 ches. (let* ((d
89d0: 62 20 20 20 20 20 20 20 20 20 20 20 23 66 29 0a b #f).
89e0: 09 20 28 6b 65 79 73 20 20 20 20 20 20 20 20 20 . (keys
89f0: 28 6f 70 65 6e 2d 72 75 6e 2d 63 6c 6f 73 65 20 (open-run-close
8a00: 64 62 3a 67 65 74 2d 6b 65 79 73 20 64 62 29 29 db:get-keys db))
8a10: 0a 09 20 28 72 75 6e 64 61 74 20 20 20 20 20 20 .. (rundat
8a20: 20 28 6f 70 65 6e 2d 72 75 6e 2d 63 6c 6f 73 65 (open-run-close
8a30: 20 72 75 6e 73 3a 67 65 74 2d 72 75 6e 73 2d 62 runs:get-runs-b
8a40: 79 2d 70 61 74 74 20 64 62 20 6b 65 79 73 20 72 y-patt db keys r
8a50: 75 6e 6e 61 6d 65 70 61 74 74 29 29 0a 09 20 28 unnamepatt)).. (
8a60: 68 65 61 64 65 72 20 20 20 20 20 20 20 28 76 65 header (ve
8a70: 63 74 6f 72 2d 72 65 66 20 72 75 6e 64 61 74 20 ctor-ref rundat
8a80: 30 29 29 0a 09 20 28 72 75 6e 73 20 20 20 20 20 0)).. (runs
8a90: 20 20 20 20 28 76 65 63 74 6f 72 2d 72 65 66 20 (vector-ref
8aa0: 72 75 6e 64 61 74 20 31 29 29 0a 09 20 28 73 74 rundat 1)).. (st
8ab0: 61 74 65 73 20 20 20 20 20 20 20 28 69 66 20 73 ates (if s
8ac0: 74 61 74 65 20 20 28 73 74 72 69 6e 67 2d 73 70 tate (string-sp
8ad0: 6c 69 74 20 73 74 61 74 65 20 20 22 2c 22 29 20 lit state ",")
8ae0: 27 28 29 29 29 0a 09 20 28 73 74 61 74 75 73 65 '())).. (statuse
8af0: 73 20 20 20 20 20 28 69 66 20 73 74 61 74 75 73 s (if status
8b00: 20 28 73 74 72 69 6e 67 2d 73 70 6c 69 74 20 73 (string-split s
8b10: 74 61 74 75 73 20 22 2c 22 29 20 27 28 29 29 29 tatus ",") '()))
8b20: 0a 09 20 28 73 74 61 74 65 2d 73 74 61 74 75 73 .. (state-status
8b30: 20 28 69 66 20 28 73 74 72 69 6e 67 3f 20 6e 65 (if (string? ne
8b40: 77 2d 73 74 61 74 65 2d 73 74 61 74 75 73 29 20 w-state-status)
8b50: 28 73 74 72 69 6e 67 2d 73 70 6c 69 74 20 6e 65 (string-split ne
8b60: 77 2d 73 74 61 74 65 2d 73 74 61 74 75 73 20 22 w-state-status "
8b70: 2c 22 29 20 27 28 23 66 20 23 66 29 29 29 29 0a ,") '(#f #f)))).
8b80: 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 (debug:print
8b90: 2d 69 6e 66 6f 20 34 20 22 72 75 6e 73 3a 6f 70 -info 4 "runs:op
8ba0: 65 72 61 74 65 2d 6f 6e 20 3d 3e 20 48 65 61 64 erate-on => Head
8bb0: 65 72 3a 20 22 20 68 65 61 64 65 72 20 22 20 61 er: " header " a
8bc0: 63 74 69 6f 6e 3a 20 22 20 61 63 74 69 6f 6e 20 ction: " action
8bd0: 22 20 6e 65 77 2d 73 74 61 74 65 2d 73 74 61 74 " new-state-stat
8be0: 75 73 3a 20 22 20 6e 65 77 2d 73 74 61 74 65 2d us: " new-state-
8bf0: 73 74 61 74 75 73 29 0a 20 20 20 20 28 69 66 20 status). (if
8c00: 28 3e 20 32 20 28 6c 65 6e 67 74 68 20 73 74 61 (> 2 (length sta
8c10: 74 65 2d 73 74 61 74 75 73 29 29 0a 09 28 62 65 te-status))..(be
8c20: 67 69 6e 0a 09 20 20 28 64 65 62 75 67 3a 70 72 gin.. (debug:pr
8c30: 69 6e 74 20 30 20 22 45 52 52 4f 52 3a 20 74 68 int 0 "ERROR: th
8c40: 65 20 70 61 72 61 6d 65 74 65 72 20 74 6f 20 2d e parameter to -
8c50: 73 65 74 2d 73 74 61 74 65 2d 73 74 61 74 75 73 set-state-status
8c60: 20 69 73 20 61 20 63 6f 6d 6d 61 20 64 65 6c 69 is a comma deli
8c70: 6d 69 74 65 64 20 73 74 72 69 6e 67 2e 20 45 2e mited string. E.
8c80: 67 2e 20 43 4f 4d 50 4c 45 54 45 44 2c 46 41 49 g. COMPLETED,FAI
8c90: 4c 22 29 0a 09 20 20 28 65 78 69 74 29 29 29 0a L").. (exit))).
8ca0: 20 20 20 20 28 66 6f 72 2d 65 61 63 68 0a 20 20 (for-each.
8cb0: 20 20 20 28 6c 61 6d 62 64 61 20 28 72 75 6e 29 (lambda (run)
8cc0: 0a 20 20 20 20 20 20 20 28 6c 65 74 20 28 28 72 . (let ((r
8cd0: 75 6e 6b 65 79 20 28 73 74 72 69 6e 67 2d 69 6e unkey (string-in
8ce0: 74 65 72 73 70 65 72 73 65 20 28 6d 61 70 20 28 tersperse (map (
8cf0: 6c 61 6d 62 64 61 20 28 6b 29 0a 09 09 09 09 09 lambda (k)......
8d00: 09 28 64 62 3a 67 65 74 2d 76 61 6c 75 65 2d 62 .(db:get-value-b
8d10: 79 2d 68 65 61 64 65 72 20 72 75 6e 20 68 65 61 y-header run hea
8d20: 64 65 72 20 28 76 65 63 74 6f 72 2d 72 65 66 20 der (vector-ref
8d30: 6b 20 30 29 29 29 20 6b 65 79 73 29 20 22 2f 22 k 0))) keys) "/"
8d40: 29 29 0a 09 20 20 20 20 20 28 64 69 72 73 2d 74 )).. (dirs-t
8d50: 6f 2d 72 65 6d 6f 76 65 20 28 6d 61 6b 65 2d 68 o-remove (make-h
8d60: 61 73 68 2d 74 61 62 6c 65 29 29 29 0a 09 20 28 ash-table))).. (
8d70: 6c 65 74 2a 20 28 28 72 75 6e 2d 69 64 20 20 20 let* ((run-id
8d80: 20 28 64 62 3a 67 65 74 2d 76 61 6c 75 65 2d 62 (db:get-value-b
8d90: 79 2d 68 65 61 64 65 72 20 72 75 6e 20 68 65 61 y-header run hea
8da0: 64 65 72 20 22 69 64 22 29 29 0a 09 09 28 72 75 der "id"))...(ru
8db0: 6e 2d 73 74 61 74 65 20 28 64 62 3a 67 65 74 2d n-state (db:get-
8dc0: 76 61 6c 75 65 2d 62 79 2d 68 65 61 64 65 72 20 value-by-header
8dd0: 72 75 6e 20 68 65 61 64 65 72 20 22 73 74 61 74 run header "stat
8de0: 65 22 29 29 0a 09 09 28 74 65 73 74 73 20 20 20 e"))...(tests
8df0: 20 20 28 69 66 20 28 6e 6f 74 20 28 65 71 75 61 (if (not (equa
8e00: 6c 3f 20 72 75 6e 2d 73 74 61 74 65 20 22 6c 6f l? run-state "lo
8e10: 63 6b 65 64 22 29 29 0a 09 09 09 20 20 20 20 20 cked"))....
8e20: 20 20 28 6f 70 65 6e 2d 72 75 6e 2d 63 6c 6f 73 (open-run-clos
8e30: 65 20 64 62 3a 67 65 74 2d 74 65 73 74 73 2d 66 e db:get-tests-f
8e40: 6f 72 2d 72 75 6e 20 64 62 20 72 75 6e 2d 69 64 or-run db run-id
8e50: 0a 09 09 09 09 09 09 20 20 20 20 20 20 74 65 73 ....... tes
8e60: 74 70 61 74 74 20 73 74 61 74 65 73 20 73 74 61 tpatt states sta
8e70: 74 75 73 65 73 0a 09 09 09 09 09 09 20 20 20 20 tuses.......
8e80: 20 20 6e 6f 74 2d 69 6e 3a 20 20 23 66 0a 09 09 not-in: #f...
8e90: 09 09 09 09 20 20 20 20 20 20 73 6f 72 74 2d 62 .... sort-b
8ea0: 79 3a 20 28 63 61 73 65 20 61 63 74 69 6f 6e 0a y: (case action.
8eb0: 09 09 09 09 09 09 09 09 20 28 28 72 65 6d 6f 76 ........ ((remov
8ec0: 65 2d 72 75 6e 73 29 20 27 72 75 6e 64 69 72 29 e-runs) 'rundir)
8ed0: 0a 09 09 09 09 09 09 09 09 20 28 65 6c 73 65 20 ......... (else
8ee0: 20 20 20 20 20 20 20 20 20 27 65 76 65 6e 74 5f 'event_
8ef0: 74 69 6d 65 29 29 29 0a 09 09 09 20 20 20 20 20 time)))....
8f00: 20 20 27 28 29 29 29 0a 09 09 28 6c 61 73 74 74 '()))...(lastt
8f10: 70 61 74 68 20 22 2f 64 6f 65 73 2f 6e 6f 74 2f path "/does/not/
8f20: 65 78 69 73 74 2f 49 2f 68 6f 70 65 22 29 29 0a exist/I/hope")).
8f30: 09 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 . (debug:print
8f40: 2d 69 6e 66 6f 20 34 20 22 72 75 6e 73 3a 6f 70 -info 4 "runs:op
8f50: 65 72 61 74 65 2d 6f 6e 20 72 75 6e 3d 22 20 72 erate-on run=" r
8f60: 75 6e 20 22 2c 20 68 65 61 64 65 72 3d 22 20 68 un ", header=" h
8f70: 65 61 64 65 72 29 0a 09 20 20 20 28 69 66 20 28 eader).. (if (
8f80: 6e 6f 74 20 28 6e 75 6c 6c 3f 20 74 65 73 74 73 not (null? tests
8f90: 29 29 0a 09 20 20 20 20 20 20 20 28 62 65 67 69 )).. (begi
8fa0: 6e 0a 09 09 20 28 63 61 73 65 20 61 63 74 69 6f n... (case actio
8fb0: 6e 0a 09 09 20 20 20 28 28 72 65 6d 6f 76 65 2d n... ((remove-
8fc0: 72 75 6e 73 29 0a 09 09 20 20 20 20 28 64 65 62 runs)... (deb
8fd0: 75 67 3a 70 72 69 6e 74 20 31 20 22 52 65 6d 6f ug:print 1 "Remo
8fe0: 76 69 6e 67 20 74 65 73 74 73 20 66 6f 72 20 72 ving tests for r
8ff0: 75 6e 3a 20 22 20 72 75 6e 6b 65 79 20 22 20 22 un: " runkey " "
9000: 20 28 64 62 3a 67 65 74 2d 76 61 6c 75 65 2d 62 (db:get-value-b
9010: 79 2d 68 65 61 64 65 72 20 72 75 6e 20 68 65 61 y-header run hea
9020: 64 65 72 20 22 72 75 6e 6e 61 6d 65 22 29 29 29 der "runname")))
9030: 0a 09 09 20 20 20 28 28 73 65 74 2d 73 74 61 74 ... ((set-stat
9040: 65 2d 73 74 61 74 75 73 29 0a 09 09 20 20 20 20 e-status)...
9050: 28 64 65 62 75 67 3a 70 72 69 6e 74 20 31 20 22 (debug:print 1 "
9060: 4d 6f 64 69 66 79 69 6e 67 20 73 74 61 74 65 20 Modifying state
9070: 61 6e 64 20 73 74 61 75 73 20 66 6f 72 20 74 65 and staus for te
9080: 73 74 73 20 66 6f 72 20 72 75 6e 3a 20 22 20 72 sts for run: " r
9090: 75 6e 6b 65 79 20 22 20 22 20 28 64 62 3a 67 65 unkey " " (db:ge
90a0: 74 2d 76 61 6c 75 65 2d 62 79 2d 68 65 61 64 65 t-value-by-heade
90b0: 72 20 72 75 6e 20 68 65 61 64 65 72 20 22 72 75 r run header "ru
90c0: 6e 6e 61 6d 65 22 29 29 29 0a 09 09 20 20 20 28 nname")))... (
90d0: 28 70 72 69 6e 74 2d 72 75 6e 29 0a 09 09 20 20 (print-run)...
90e0: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 31 (debug:print 1
90f0: 20 22 50 72 69 6e 74 69 6e 67 20 69 6e 66 6f 20 "Printing info
9100: 66 6f 72 20 72 75 6e 20 22 20 72 75 6e 6b 65 79 for run " runkey
9110: 20 22 2c 20 72 75 6e 3d 22 20 72 75 6e 20 22 2c ", run=" run ",
9120: 20 74 65 73 74 73 3d 22 20 74 65 73 74 73 20 22 tests=" tests "
9130: 2c 20 68 65 61 64 65 72 3d 22 20 68 65 61 64 65 , header=" heade
9140: 72 29 0a 09 09 20 20 20 20 61 63 74 69 6f 6e 29 r)... action)
9150: 0a 09 09 20 20 20 28 65 6c 73 65 0a 09 09 20 20 ... (else...
9160: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 (debug:print-i
9170: 6e 66 6f 20 30 20 22 61 63 74 69 6f 6e 20 6e 6f nfo 0 "action no
9180: 74 20 72 65 63 6f 67 6e 69 73 65 64 20 22 20 61 t recognised " a
9190: 63 74 69 6f 6e 29 29 29 0a 09 09 20 28 66 6f 72 ction)))... (for
91a0: 2d 65 61 63 68 0a 09 09 20 20 28 6c 61 6d 62 64 -each... (lambd
91b0: 61 20 28 74 65 73 74 29 0a 09 09 20 20 20 20 28 a (test)... (
91c0: 6c 65 74 2a 20 28 28 69 74 65 6d 2d 70 61 74 68 let* ((item-path
91d0: 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 69 74 (db:test-get-it
91e0: 65 6d 2d 70 61 74 68 20 74 65 73 74 29 29 0a 09 em-path test))..
91f0: 09 09 20 20 20 28 74 65 73 74 2d 6e 61 6d 65 20 .. (test-name
9200: 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 74 65 73 (db:test-get-tes
9210: 74 6e 61 6d 65 20 74 65 73 74 29 29 0a 09 09 09 tname test))....
9220: 20 20 20 28 72 75 6e 2d 64 69 72 20 20 20 28 64 (run-dir (d
9230: 62 3a 74 65 73 74 2d 67 65 74 2d 72 75 6e 64 69 b:test-get-rundi
9240: 72 20 74 65 73 74 29 29 20 20 20 20 3b 3b 20 72 r test)) ;; r
9250: 75 6e 20 64 69 72 20 69 73 20 66 72 6f 6d 20 74 un dir is from t
9260: 68 65 20 6c 69 6e 6b 20 74 72 65 65 0a 09 09 09 he link tree....
9270: 20 20 20 28 72 65 61 6c 2d 64 69 72 20 20 28 69 (real-dir (i
9280: 66 20 28 66 69 6c 65 2d 65 78 69 73 74 73 3f 20 f (file-exists?
9290: 72 75 6e 2d 64 69 72 29 0a 09 09 09 09 09 20 20 run-dir)......
92a0: 28 72 65 73 6f 6c 76 65 2d 70 61 74 68 6e 61 6d (resolve-pathnam
92b0: 65 20 72 75 6e 2d 64 69 72 29 0a 09 09 09 09 09 e run-dir)......
92c0: 20 20 23 66 29 29 0a 09 09 09 20 20 20 28 74 65 #f)).... (te
92d0: 73 74 2d 69 64 20 20 20 28 64 62 3a 74 65 73 74 st-id (db:test
92e0: 2d 67 65 74 2d 69 64 20 74 65 73 74 29 29 29 0a -get-id test))).
92f0: 09 09 20 20 20 20 20 20 3b 3b 20 20 20 28 74 64 .. ;; (td
9300: 62 20 20 20 20 20 20 20 28 64 62 3a 6f 70 65 6e b (db:open
9310: 2d 74 65 73 74 2d 64 62 20 72 75 6e 2d 64 69 72 -test-db run-dir
9320: 29 29 29 0a 09 09 20 20 20 20 20 20 28 64 65 62 )))... (deb
9330: 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 34 20 ug:print-info 4
9340: 22 74 65 73 74 3d 22 20 74 65 73 74 29 20 3b 3b "test=" test) ;;
9350: 20 20 20 22 20 28 64 62 3a 74 65 73 74 2d 67 65 " (db:test-ge
9360: 74 2d 74 65 73 74 6e 61 6d 65 20 74 65 73 74 29 t-testname test)
9370: 20 22 20 69 64 3a 20 22 20 28 64 62 3a 74 65 73 " id: " (db:tes
9380: 74 2d 67 65 74 2d 69 64 20 74 65 73 74 29 20 22 t-get-id test) "
9390: 20 22 20 69 74 65 6d 2d 70 61 74 68 20 22 20 61 " item-path " a
93a0: 63 74 69 6f 6e 3a 20 22 20 61 63 74 69 6f 6e 29 ction: " action)
93b0: 0a 09 09 20 20 20 20 20 20 28 63 61 73 65 20 61 ... (case a
93c0: 63 74 69 6f 6e 0a 09 09 09 28 28 72 65 6d 6f 76 ction....((remov
93d0: 65 2d 72 75 6e 73 29 20 3b 3b 20 74 68 65 20 74 e-runs) ;; the t
93e0: 64 62 20 69 73 20 66 6f 72 20 66 75 74 75 72 65 db is for future
93f0: 20 70 6f 73 73 69 62 6c 65 2e 20 0a 09 09 09 20 possible. ....
9400: 28 6f 70 65 6e 2d 72 75 6e 2d 63 6c 6f 73 65 20 (open-run-close
9410: 64 62 3a 64 65 6c 65 74 65 2d 74 65 73 74 2d 72 db:delete-test-r
9420: 65 63 6f 72 64 73 20 64 62 20 23 66 20 28 64 62 ecords db #f (db
9430: 3a 74 65 73 74 2d 67 65 74 2d 69 64 20 74 65 73 :test-get-id tes
9440: 74 29 29 0a 09 09 09 20 28 64 65 62 75 67 3a 70 t)).... (debug:p
9450: 72 69 6e 74 2d 69 6e 66 6f 20 31 20 22 41 74 74 rint-info 1 "Att
9460: 65 6d 70 74 69 6e 67 20 74 6f 20 72 65 6d 6f 76 empting to remov
9470: 65 20 22 20 28 69 66 20 72 65 61 6c 2d 64 69 72 e " (if real-dir
9480: 20 28 63 6f 6e 63 20 22 20 64 69 72 20 22 20 72 (conc " dir " r
9490: 65 61 6c 2d 64 69 72 20 22 20 61 6e 64 20 22 29 eal-dir " and ")
94a0: 20 22 22 29 20 22 20 6c 69 6e 6b 20 22 20 72 75 "") " link " ru
94b0: 6e 2d 64 69 72 29 0a 09 09 09 20 28 69 66 20 28 n-dir).... (if (
94c0: 61 6e 64 20 72 65 61 6c 2d 64 69 72 20 0a 09 09 and real-dir ...
94d0: 09 09 20 20 28 3e 20 28 73 74 72 69 6e 67 2d 6c .. (> (string-l
94e0: 65 6e 67 74 68 20 72 65 61 6c 2d 64 69 72 29 20 ength real-dir)
94f0: 35 29 0a 09 09 09 09 20 20 28 66 69 6c 65 2d 65 5)..... (file-e
9500: 78 69 73 74 73 3f 20 72 65 61 6c 2d 64 69 72 29 xists? real-dir)
9510: 29 20 3b 3b 20 62 61 64 20 68 65 75 72 69 73 74 ) ;; bad heurist
9520: 69 63 20 62 75 74 20 73 68 6f 75 6c 64 20 70 72 ic but should pr
9530: 65 76 65 6e 74 20 2f 74 6d 70 20 2f 68 6f 6d 65 event /tmp /home
9540: 20 65 74 63 2e 0a 09 09 09 20 20 20 20 20 28 62 etc..... (b
9550: 65 67 69 6e 20 3b 3b 20 6c 65 74 2a 20 28 28 72 egin ;; let* ((r
9560: 65 61 6c 70 61 74 68 20 28 72 65 73 6f 6c 76 65 ealpath (resolve
9570: 2d 70 61 74 68 6e 61 6d 65 20 72 75 6e 2d 64 69 -pathname run-di
9580: 72 29 29 29 0a 09 09 09 20 20 20 20 20 20 20 28 r))).... (
9590: 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f debug:print-info
95a0: 20 31 20 22 52 65 63 75 72 73 69 76 65 6c 79 20 1 "Recursively
95b0: 72 65 6d 6f 76 69 6e 67 20 22 20 72 65 61 6c 2d removing " real-
95c0: 64 69 72 29 0a 09 09 09 20 20 20 20 20 20 20 28 dir).... (
95d0: 69 66 20 28 66 69 6c 65 2d 65 78 69 73 74 73 3f if (file-exists?
95e0: 20 72 65 61 6c 2d 64 69 72 29 0a 09 09 09 09 20 real-dir).....
95f0: 20 20 28 69 66 20 28 3e 20 28 73 79 73 74 65 6d (if (> (system
9600: 20 28 63 6f 6e 63 20 22 72 6d 20 2d 72 66 20 22 (conc "rm -rf "
9610: 20 72 65 61 6c 2d 64 69 72 29 29 20 30 29 0a 09 real-dir)) 0)..
9620: 09 09 09 20 20 20 20 20 20 20 28 64 65 62 75 67 ... (debug
9630: 3a 70 72 69 6e 74 20 30 20 22 45 52 52 4f 52 3a :print 0 "ERROR:
9640: 20 54 68 65 72 65 20 77 61 73 20 61 20 70 72 6f There was a pro
9650: 62 6c 65 6d 20 72 65 6d 6f 76 69 6e 67 20 22 20 blem removing "
9660: 72 65 61 6c 2d 64 69 72 20 22 20 77 69 74 68 20 real-dir " with
9670: 72 6d 20 2d 66 22 29 29 0a 09 09 09 09 20 20 20 rm -f")).....
9680: 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 22 (debug:print 0 "
9690: 57 41 52 4e 49 4e 47 3a 20 74 65 73 74 20 64 69 WARNING: test di
96a0: 72 20 22 20 72 65 61 6c 2d 64 69 72 20 22 20 61 r " real-dir " a
96b0: 70 70 65 61 72 73 20 74 6f 20 6e 6f 74 20 65 78 ppears to not ex
96c0: 69 73 74 20 6f 72 20 69 73 20 6e 6f 74 20 72 65 ist or is not re
96d0: 61 64 61 62 6c 65 22 29 29 29 0a 09 09 09 20 20 adable")))....
96e0: 20 20 20 28 69 66 20 72 65 61 6c 2d 64 69 72 20 (if real-dir
96f0: 0a 09 09 09 09 20 28 64 65 62 75 67 3a 70 72 69 ..... (debug:pri
9700: 6e 74 20 30 20 22 57 41 52 4e 49 4e 47 3a 20 64 nt 0 "WARNING: d
9710: 69 72 65 63 74 6f 72 79 20 22 20 72 65 61 6c 2d irectory " real-
9720: 64 69 72 20 22 20 64 6f 65 73 20 6e 6f 74 20 65 dir " does not e
9730: 78 69 73 74 22 29 0a 09 09 09 09 20 28 64 65 62 xist")..... (deb
9740: 75 67 3a 70 72 69 6e 74 20 30 20 22 57 41 52 4e ug:print 0 "WARN
9750: 49 4e 47 3a 20 6e 6f 20 72 65 61 6c 20 64 69 72 ING: no real dir
9760: 65 63 74 6f 72 79 20 63 6f 72 72 6f 73 70 6f 6e ectory corrospon
9770: 64 69 6e 67 20 74 6f 20 6c 69 6e 6b 20 22 20 72 ding to link " r
9780: 75 6e 2d 64 69 72 20 22 2c 20 6e 6f 74 68 69 6e un-dir ", nothin
9790: 67 20 64 6f 6e 65 22 29 29 29 0a 09 09 09 20 28 g done"))).... (
97a0: 69 66 20 28 73 79 6d 62 6f 6c 69 63 2d 6c 69 6e if (symbolic-lin
97b0: 6b 3f 20 72 75 6e 2d 64 69 72 29 0a 09 09 09 20 k? run-dir)....
97c0: 20 20 20 20 28 62 65 67 69 6e 0a 09 09 09 20 20 (begin....
97d0: 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e (debug:prin
97e0: 74 2d 69 6e 66 6f 20 31 20 22 52 65 6d 6f 76 69 t-info 1 "Removi
97f0: 6e 67 20 73 79 6d 6c 69 6e 6b 20 22 20 72 75 6e ng symlink " run
9800: 2d 64 69 72 29 0a 09 09 09 20 20 20 20 20 20 20 -dir)....
9810: 28 64 65 6c 65 74 65 2d 66 69 6c 65 20 72 75 6e (delete-file run
9820: 2d 64 69 72 29 29 0a 09 09 09 20 20 20 20 20 28 -dir)).... (
9830: 69 66 20 28 64 69 72 65 63 74 6f 72 79 3f 20 72 if (directory? r
9840: 75 6e 2d 64 69 72 29 0a 09 09 09 09 20 28 69 66 un-dir)..... (if
9850: 20 28 3e 20 28 64 69 72 65 63 74 6f 72 79 2d 66 (> (directory-f
9860: 6f 6c 64 20 28 6c 61 6d 62 64 61 20 28 66 20 78 old (lambda (f x
9870: 29 28 2b 20 31 20 78 29 29 20 30 20 72 75 6e 2d )(+ 1 x)) 0 run-
9880: 64 69 72 29 20 30 29 0a 09 09 09 09 20 20 20 20 dir) 0).....
9890: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 (debug:print 0
98a0: 22 57 41 52 4e 49 4e 47 3a 20 72 65 66 75 73 69 "WARNING: refusi
98b0: 6e 67 20 74 6f 20 72 65 6d 6f 76 65 20 22 20 72 ng to remove " r
98c0: 75 6e 2d 64 69 72 20 22 20 61 73 20 69 74 20 69 un-dir " as it i
98d0: 73 20 6e 6f 74 20 65 6d 70 74 79 22 29 0a 09 09 s not empty")...
98e0: 09 09 20 20 20 20 20 28 64 65 6c 65 74 65 2d 64 .. (delete-d
98f0: 69 72 65 63 74 6f 72 79 20 72 75 6e 2d 64 69 72 irectory run-dir
9900: 29 29 20 3b 3b 20 69 74 20 73 68 6f 75 6c 64 20 )) ;; it should
9910: 62 65 20 65 6d 70 74 79 20 62 79 20 68 65 72 65 be empty by here
9920: 20 42 55 47 20 42 55 47 2c 20 61 64 64 20 65 72 BUG BUG, add er
9930: 72 6f 72 20 63 61 74 63 68 0a 09 09 09 09 20 28 ror catch..... (
9940: 69 66 20 72 75 6e 2d 64 69 72 0a 09 09 09 09 20 if run-dir.....
9950: 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 (debug:print
9960: 20 30 20 22 57 41 52 4e 49 4e 47 3a 20 6e 6f 74 0 "WARNING: not
9970: 20 72 65 6d 6f 76 69 6e 67 20 22 20 72 75 6e 2d removing " run-
9980: 64 69 72 20 22 20 61 73 20 69 74 20 65 69 74 68 dir " as it eith
9990: 65 72 20 64 6f 65 73 6e 27 74 20 65 78 69 73 74 er doesn't exist
99a0: 20 6f 72 20 69 73 20 6e 6f 74 20 61 20 73 79 6d or is not a sym
99b0: 6c 69 6e 6b 22 29 0a 09 09 09 09 20 20 20 20 20 link").....
99c0: 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 22 (debug:print 0 "
99d0: 4e 4f 54 45 3a 20 74 68 65 20 72 75 6e 20 64 69 NOTE: the run di
99e0: 72 20 66 6f 72 20 74 68 69 73 20 74 65 73 74 20 r for this test
99f0: 69 73 20 75 6e 64 65 66 69 6e 65 64 2e 20 54 65 is undefined. Te
9a00: 73 74 20 6d 61 79 20 68 61 76 65 20 61 6c 72 65 st may have alre
9a10: 61 64 79 20 62 65 65 6e 20 64 65 6c 65 74 65 64 ady been deleted
9a20: 2e 22 29 29 0a 09 09 09 09 20 29 29 29 0a 09 09 ."))..... )))...
9a30: 09 28 28 73 65 74 2d 73 74 61 74 65 2d 73 74 61 .((set-state-sta
9a40: 74 75 73 29 0a 09 09 09 20 28 64 65 62 75 67 3a tus).... (debug:
9a50: 70 72 69 6e 74 2d 69 6e 66 6f 20 32 20 22 6e 65 print-info 2 "ne
9a60: 77 20 73 74 61 74 65 20 22 20 28 63 61 72 20 73 w state " (car s
9a70: 74 61 74 65 2d 73 74 61 74 75 73 29 20 22 2c 20 tate-status) ",
9a80: 6e 65 77 20 73 74 61 74 75 73 20 22 20 28 63 61 new status " (ca
9a90: 64 72 20 73 74 61 74 65 2d 73 74 61 74 75 73 29 dr state-status)
9aa0: 29 0a 09 09 09 20 28 6f 70 65 6e 2d 72 75 6e 2d ).... (open-run-
9ab0: 63 6c 6f 73 65 20 64 62 3a 74 65 73 74 2d 73 65 close db:test-se
9ac0: 74 2d 73 74 61 74 65 2d 73 74 61 74 75 73 2d 62 t-state-status-b
9ad0: 79 2d 69 64 20 64 62 20 28 64 62 3a 74 65 73 74 y-id db (db:test
9ae0: 2d 67 65 74 2d 69 64 20 74 65 73 74 29 20 28 63 -get-id test) (c
9af0: 61 72 20 73 74 61 74 65 2d 73 74 61 74 75 73 29 ar state-status)
9b00: 28 63 61 64 72 20 73 74 61 74 65 2d 73 74 61 74 (cadr state-stat
9b10: 75 73 29 20 23 66 29 29 29 29 29 0a 09 09 20 20 us) #f)))))...
9b20: 28 73 6f 72 74 20 74 65 73 74 73 20 28 6c 61 6d (sort tests (lam
9b30: 62 64 61 20 28 61 20 62 29 28 6c 65 74 20 28 28 bda (a b)(let ((
9b40: 64 69 72 61 20 28 64 62 3a 74 65 73 74 2d 67 65 dira (db:test-ge
9b50: 74 2d 72 75 6e 64 69 72 20 61 29 29 0a 09 09 09 t-rundir a))....
9b60: 09 09 09 20 28 64 69 72 62 20 28 64 62 3a 74 65 ... (dirb (db:te
9b70: 73 74 2d 67 65 74 2d 72 75 6e 64 69 72 20 62 29 st-get-rundir b)
9b80: 29 29 0a 09 09 09 09 09 20 20 20 20 20 28 69 66 ))...... (if
9b90: 20 28 61 6e 64 20 28 73 74 72 69 6e 67 3f 20 64 (and (string? d
9ba0: 69 72 61 29 28 73 74 72 69 6e 67 3f 20 64 69 72 ira)(string? dir
9bb0: 62 29 29 0a 09 09 09 09 09 09 20 28 3e 20 28 73 b))....... (> (s
9bc0: 74 72 69 6e 67 2d 6c 65 6e 67 74 68 20 64 69 72 tring-length dir
9bd0: 61 29 28 73 74 72 69 6e 67 2d 6c 65 6e 67 74 68 a)(string-length
9be0: 20 64 69 72 62 29 29 0a 09 09 09 09 09 09 20 23 dirb))....... #
9bf0: 66 29 29 29 29 29 29 29 0a 09 20 20 20 3b 3b 20 f))))))).. ;;
9c00: 72 65 6d 6f 76 65 20 74 68 65 20 72 75 6e 20 69 remove the run i
9c10: 66 20 7a 65 72 6f 20 74 65 73 74 73 20 72 65 6d f zero tests rem
9c20: 61 69 6e 0a 09 20 20 20 28 69 66 20 28 65 71 3f ain.. (if (eq?
9c30: 20 61 63 74 69 6f 6e 20 27 72 65 6d 6f 76 65 2d action 'remove-
9c40: 72 75 6e 73 29 0a 09 20 20 20 20 20 20 20 28 6c runs).. (l
9c50: 65 74 20 28 28 72 65 6d 74 65 73 74 73 20 28 6f et ((remtests (o
9c60: 70 65 6e 2d 72 75 6e 2d 63 6c 6f 73 65 20 64 62 pen-run-close db
9c70: 3a 67 65 74 2d 74 65 73 74 73 2d 66 6f 72 2d 72 :get-tests-for-r
9c80: 75 6e 20 64 62 20 28 64 62 3a 67 65 74 2d 76 61 un db (db:get-va
9c90: 6c 75 65 2d 62 79 2d 68 65 61 64 65 72 20 72 75 lue-by-header ru
9ca0: 6e 20 68 65 61 64 65 72 20 22 69 64 22 29 20 23 n header "id") #
9cb0: 66 20 27 28 22 44 45 4c 45 54 45 44 22 29 20 27 f '("DELETED") '
9cc0: 28 22 6e 2f 61 22 29 20 6e 6f 74 2d 69 6e 3a 20 ("n/a") not-in:
9cd0: 23 74 29 29 29 0a 09 09 20 28 69 66 20 28 6e 75 #t)))... (if (nu
9ce0: 6c 6c 3f 20 72 65 6d 74 65 73 74 73 29 20 3b 3b ll? remtests) ;;
9cf0: 20 6e 6f 20 6d 6f 72 65 20 74 65 73 74 73 20 72 no more tests r
9d00: 65 6d 61 69 6e 69 6e 67 0a 09 09 20 20 20 20 20 emaining...
9d10: 28 6c 65 74 2a 20 28 28 64 70 61 72 74 73 20 20 (let* ((dparts
9d20: 28 73 74 72 69 6e 67 2d 73 70 6c 69 74 20 6c 61 (string-split la
9d30: 73 74 74 70 61 74 68 20 22 2f 22 29 29 0a 09 09 sttpath "/"))...
9d40: 09 20 20 20 20 28 72 75 6e 70 61 74 68 20 28 63 . (runpath (c
9d50: 6f 6e 63 20 22 2f 22 20 28 73 74 72 69 6e 67 2d onc "/" (string-
9d60: 69 6e 74 65 72 73 70 65 72 73 65 20 0a 09 09 09 intersperse ....
9d70: 09 09 09 28 74 61 6b 65 20 64 70 61 72 74 73 20 ...(take dparts
9d80: 28 2d 20 28 6c 65 6e 67 74 68 20 64 70 61 72 74 (- (length dpart
9d90: 73 29 20 31 29 29 0a 09 09 09 09 09 09 22 2f 22 s) 1))......."/"
9da0: 29 29 29 29 0a 09 09 20 20 20 20 20 20 20 28 64 ))))... (d
9db0: 65 62 75 67 3a 70 72 69 6e 74 20 31 20 22 52 65 ebug:print 1 "Re
9dc0: 6d 6f 76 69 6e 67 20 72 75 6e 3a 20 22 20 72 75 moving run: " ru
9dd0: 6e 6b 65 79 20 22 20 22 20 28 64 62 3a 67 65 74 nkey " " (db:get
9de0: 2d 76 61 6c 75 65 2d 62 79 2d 68 65 61 64 65 72 -value-by-header
9df0: 20 72 75 6e 20 68 65 61 64 65 72 20 22 72 75 6e run header "run
9e00: 6e 61 6d 65 22 29 20 22 20 61 6e 64 20 72 65 6c name") " and rel
9e10: 61 74 65 64 20 72 65 63 6f 72 64 22 29 0a 09 09 ated record")...
9e20: 20 20 20 20 20 20 20 28 6f 70 65 6e 2d 72 75 6e (open-run
9e30: 2d 63 6c 6f 73 65 20 64 62 3a 64 65 6c 65 74 65 -close db:delete
9e40: 2d 72 75 6e 20 64 62 20 72 75 6e 2d 69 64 29 0a -run db run-id).
9e50: 09 09 20 20 20 20 20 20 20 3b 3b 20 54 68 69 73 .. ;; This
9e60: 20 69 73 20 61 20 70 72 65 74 74 79 20 67 6f 6f is a pretty goo
9e70: 64 20 70 6c 61 63 65 20 74 6f 20 70 75 72 67 65 d place to purge
9e80: 20 6f 6c 64 20 44 45 4c 45 54 45 44 20 74 65 73 old DELETED tes
9e90: 74 73 0a 09 09 20 20 20 20 20 20 20 28 6f 70 65 ts... (ope
9ea0: 6e 2d 72 75 6e 2d 63 6c 6f 73 65 20 64 62 3a 64 n-run-close db:d
9eb0: 65 6c 65 74 65 2d 74 65 73 74 73 2d 66 6f 72 2d elete-tests-for-
9ec0: 72 75 6e 20 64 62 20 72 75 6e 2d 69 64 29 0a 09 run db run-id)..
9ed0: 09 20 20 20 20 20 20 20 28 6f 70 65 6e 2d 72 75 . (open-ru
9ee0: 6e 2d 63 6c 6f 73 65 20 64 62 3a 64 65 6c 65 74 n-close db:delet
9ef0: 65 2d 6f 6c 64 2d 64 65 6c 65 74 65 64 2d 74 65 e-old-deleted-te
9f00: 73 74 2d 72 65 63 6f 72 64 73 20 64 62 29 0a 09 st-records db)..
9f10: 09 20 20 20 20 20 20 20 28 6f 70 65 6e 2d 72 75 . (open-ru
9f20: 6e 2d 63 6c 6f 73 65 20 64 62 3a 73 65 74 2d 76 n-close db:set-v
9f30: 61 72 20 64 62 20 22 44 45 4c 45 54 45 44 5f 54 ar db "DELETED_T
9f40: 45 53 54 53 22 20 28 63 75 72 72 65 6e 74 2d 73 ESTS" (current-s
9f50: 65 63 6f 6e 64 73 29 29 0a 09 09 20 20 20 20 20 econds))...
9f60: 20 20 3b 3b 20 6e 65 65 64 20 74 6f 20 66 69 67 ;; need to fig
9f70: 75 72 65 20 6f 75 74 20 74 68 65 20 70 61 74 68 ure out the path
9f80: 20 74 6f 20 74 68 65 20 72 75 6e 20 64 69 72 20 to the run dir
9f90: 61 6e 64 20 72 65 6d 6f 76 65 20 69 74 20 69 66 and remove it if
9fa0: 20 65 6d 70 74 79 0a 09 09 20 20 20 20 20 20 20 empty...
9fb0: 3b 3b 20 20 20 20 28 69 66 20 28 6e 75 6c 6c 3f ;; (if (null?
9fc0: 20 28 67 6c 6f 62 20 28 63 6f 6e 63 20 72 75 6e (glob (conc run
9fd0: 70 61 74 68 20 22 2f 2a 22 29 29 29 0a 09 09 20 path "/*")))...
9fe0: 20 20 20 20 20 20 3b 3b 20 20 20 20 20 20 20 20 ;;
9ff0: 28 62 65 67 69 6e 0a 09 09 20 20 20 20 20 20 20 (begin...
a000: 3b 3b 20 09 20 28 64 65 62 75 67 3a 70 72 69 6e ;; . (debug:prin
a010: 74 20 31 20 22 52 65 6d 6f 76 69 6e 67 20 72 75 t 1 "Removing ru
a020: 6e 20 64 69 72 20 22 20 72 75 6e 70 61 74 68 29 n dir " runpath)
a030: 0a 09 09 20 20 20 20 20 20 20 3b 3b 20 09 20 28 ... ;; . (
a040: 73 79 73 74 65 6d 20 28 63 6f 6e 63 20 22 72 6d system (conc "rm
a050: 64 69 72 20 2d 70 20 22 20 72 75 6e 70 61 74 68 dir -p " runpath
a060: 29 29 29 29 0a 09 09 20 20 20 20 20 20 20 29 29 ))))... ))
a070: 29 29 29 0a 09 20 29 29 0a 20 20 20 20 20 72 75 ))).. )). ru
a080: 6e 73 29 29 0a 20 20 23 74 29 0a 0a 3b 3b 3d 3d ns)). #t)..;;==
a090: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
a0a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
a0b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
a0c0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
a0d0: 3d 3d 3d 3d 0a 3b 3b 20 52 6f 75 74 69 6e 65 73 ====.;; Routines
a0e0: 20 66 6f 72 20 6d 61 6e 69 70 75 6c 61 74 69 6e for manipulatin
a0f0: 67 20 72 75 6e 73 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d g runs.;;=======
a100: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
a110: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
a120: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
a130: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a ===============.
a140: 0a 3b 3b 20 53 69 6e 63 65 20 6d 61 6e 79 20 63 .;; Since many c
a150: 61 6c 6c 73 20 74 6f 20 61 20 72 75 6e 20 72 65 alls to a run re
a160: 71 75 69 72 65 20 70 72 65 74 74 79 20 6d 75 63 quire pretty muc
a170: 68 20 74 68 65 20 73 61 6d 65 20 73 65 74 75 70 h the same setup
a180: 20 0a 3b 3b 20 74 68 69 73 20 77 72 61 70 70 65 .;; this wrappe
a190: 72 20 69 73 20 75 73 65 64 20 74 6f 20 72 65 64 r is used to red
a1a0: 75 63 65 20 74 68 65 20 72 65 70 6c 69 63 61 74 uce the replicat
a1b0: 69 6f 6e 20 6f 66 20 63 6f 64 65 0a 28 64 65 66 ion of code.(def
a1c0: 69 6e 65 20 28 67 65 6e 65 72 61 6c 2d 72 75 6e ine (general-run
a1d0: 2d 63 61 6c 6c 20 73 77 69 74 63 68 6e 61 6d 65 -call switchname
a1e0: 20 61 63 74 69 6f 6e 2d 64 65 73 63 20 70 72 6f action-desc pro
a1f0: 63 29 0a 20 20 28 6c 65 74 20 28 28 72 75 6e 6e c). (let ((runn
a200: 61 6d 65 20 28 61 72 67 73 3a 67 65 74 2d 61 72 ame (args:get-ar
a210: 67 20 22 3a 72 75 6e 6e 61 6d 65 22 29 29 0a 09 g ":runname"))..
a220: 28 74 61 72 67 65 74 20 20 28 69 66 20 28 61 72 (target (if (ar
a230: 67 73 3a 67 65 74 2d 61 72 67 20 22 2d 74 61 72 gs:get-arg "-tar
a240: 67 65 74 22 29 0a 09 09 20 20 20 20 20 28 61 72 get")... (ar
a250: 67 73 3a 67 65 74 2d 61 72 67 20 22 2d 74 61 72 gs:get-arg "-tar
a260: 67 65 74 22 29 0a 09 09 20 20 20 20 20 28 61 72 get")... (ar
a270: 67 73 3a 67 65 74 2d 61 72 67 20 22 2d 72 65 71 gs:get-arg "-req
a280: 74 61 72 67 22 29 29 29 0a 09 28 74 68 31 20 20 targ")))..(th1
a290: 20 20 20 23 66 29 29 0a 20 20 20 20 28 63 6f 6e #f)). (con
a2a0: 64 0a 20 20 20 20 20 28 28 6e 6f 74 20 74 61 72 d. ((not tar
a2b0: 67 65 74 29 0a 20 20 20 20 20 20 28 64 65 62 75 get). (debu
a2c0: 67 3a 70 72 69 6e 74 20 30 20 22 45 52 52 4f 52 g:print 0 "ERROR
a2d0: 3a 20 4d 69 73 73 69 6e 67 20 72 65 71 75 69 72 : Missing requir
a2e0: 65 64 20 70 61 72 61 6d 65 74 65 72 20 66 6f 72 ed parameter for
a2f0: 20 22 20 73 77 69 74 63 68 6e 61 6d 65 20 22 2c " switchname ",
a300: 20 79 6f 75 20 6d 75 73 74 20 73 70 65 63 69 66 you must specif
a310: 79 20 74 68 65 20 74 61 72 67 65 74 20 77 69 74 y the target wit
a320: 68 20 2d 74 61 72 67 65 74 22 29 0a 20 20 20 20 h -target").
a330: 20 20 28 65 78 69 74 20 33 29 29 0a 20 20 20 20 (exit 3)).
a340: 20 28 28 6e 6f 74 20 72 75 6e 6e 61 6d 65 29 0a ((not runname).
a350: 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 (debug:pri
a360: 6e 74 20 30 20 22 45 52 52 4f 52 3a 20 4d 69 73 nt 0 "ERROR: Mis
a370: 73 69 6e 67 20 72 65 71 75 69 72 65 64 20 70 61 sing required pa
a380: 72 61 6d 65 74 65 72 20 66 6f 72 20 22 20 73 77 rameter for " sw
a390: 69 74 63 68 6e 61 6d 65 20 22 2c 20 79 6f 75 20 itchname ", you
a3a0: 6d 75 73 74 20 73 70 65 63 69 66 79 20 74 68 65 must specify the
a3b0: 20 72 75 6e 20 6e 61 6d 65 20 77 69 74 68 20 3a run name with :
a3c0: 72 75 6e 6e 61 6d 65 20 72 75 6e 6e 61 6d 65 22 runname runname"
a3d0: 29 0a 20 20 20 20 20 20 28 65 78 69 74 20 33 29 ). (exit 3)
a3e0: 29 0a 20 20 20 20 20 28 65 6c 73 65 0a 20 20 20 ). (else.
a3f0: 20 20 20 28 6c 65 74 20 28 28 64 62 20 20 20 23 (let ((db #
a400: 66 29 0a 09 20 20 20 20 28 6b 65 79 73 20 23 66 f).. (keys #f
a410: 29 29 0a 09 28 69 66 20 28 6e 6f 74 20 28 73 65 ))..(if (not (se
a420: 74 75 70 2d 66 6f 72 2d 72 75 6e 29 29 0a 09 20 tup-for-run))..
a430: 20 20 20 28 62 65 67 69 6e 20 0a 09 20 20 20 20 (begin ..
a440: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 (debug:print 0
a450: 20 22 46 61 69 6c 65 64 20 74 6f 20 73 65 74 75 "Failed to setu
a460: 70 2c 20 65 78 69 74 69 6e 67 22 29 0a 09 20 20 p, exiting")..
a470: 20 20 20 20 28 65 78 69 74 20 31 29 29 29 0a 09 (exit 1)))..
a480: 28 69 66 20 28 61 72 67 73 3a 67 65 74 2d 61 72 (if (args:get-ar
a490: 67 20 22 2d 73 65 72 76 65 72 22 29 0a 09 20 20 g "-server")..
a4a0: 20 20 28 6f 70 65 6e 2d 72 75 6e 2d 63 6c 6f 73 (open-run-clos
a4b0: 65 20 73 65 72 76 65 72 3a 73 74 61 72 74 20 64 e server:start d
a4c0: 62 20 28 61 72 67 73 3a 67 65 74 2d 61 72 67 20 b (args:get-arg
a4d0: 22 2d 73 65 72 76 65 72 22 29 29 0a 20 09 20 20 "-server")). .
a4e0: 20 20 28 69 66 20 28 6e 6f 74 20 28 6f 72 20 28 (if (not (or (
a4f0: 61 72 67 73 3a 67 65 74 2d 61 72 67 20 22 2d 72 args:get-arg "-r
a500: 75 6e 61 6c 6c 22 29 20 20 20 20 20 3b 3b 20 72 unall") ;; r
a510: 75 6e 61 6c 6c 20 61 6e 64 20 72 75 6e 74 65 73 unall and runtes
a520: 74 73 20 61 72 65 20 61 6c 6c 6f 77 65 64 20 74 ts are allowed t
a530: 6f 20 62 65 20 73 65 72 76 65 72 73 0a 20 09 09 o be servers. ..
a540: 09 20 28 61 72 67 73 3a 67 65 74 2d 61 72 67 20 . (args:get-arg
a550: 22 2d 72 75 6e 74 65 73 74 73 22 29 29 29 0a 09 "-runtests")))..
a560: 09 28 73 65 72 76 65 72 3a 63 6c 69 65 6e 74 2d .(server:client-
a570: 73 65 74 75 70 29 20 3b 3b 20 54 68 69 73 20 69 setup) ;; This i
a580: 73 20 61 20 64 75 70 6c 69 63 61 74 65 20 73 74 s a duplicate st
a590: 61 72 74 75 70 21 21 21 3f 3f 3f 20 42 55 47 3f artup!!!??? BUG?
a5a0: 0a 09 09 29 29 0a 09 28 73 65 74 21 20 6b 65 79 ...))..(set! key
a5b0: 73 20 28 6f 70 65 6e 2d 72 75 6e 2d 63 6c 6f 73 s (open-run-clos
a5c0: 65 20 64 62 3a 67 65 74 2d 6b 65 79 73 20 64 62 e db:get-keys db
a5d0: 29 29 0a 09 3b 3b 20 68 61 76 65 20 65 6e 6f 75 ))..;; have enou
a5e0: 67 68 20 74 6f 20 70 72 6f 63 65 73 73 20 2d 74 gh to process -t
a5f0: 61 72 67 65 74 20 6f 72 20 2d 72 65 71 74 61 72 arget or -reqtar
a600: 67 20 68 65 72 65 0a 09 28 69 66 20 28 61 72 67 g here..(if (arg
a610: 73 3a 67 65 74 2d 61 72 67 20 22 2d 72 65 71 74 s:get-arg "-reqt
a620: 61 72 67 22 29 0a 09 20 20 20 20 28 6c 65 74 2a arg").. (let*
a630: 20 28 28 72 75 6e 63 6f 6e 66 69 67 66 20 28 63 ((runconfigf (c
a640: 6f 6e 63 20 20 2a 74 6f 70 70 61 74 68 2a 20 22 onc *toppath* "
a650: 2f 72 75 6e 63 6f 6e 66 69 67 73 2e 63 6f 6e 66 /runconfigs.conf
a660: 69 67 22 29 29 20 3b 3b 20 44 4f 20 4e 4f 54 20 ig")) ;; DO NOT
a670: 45 56 41 4c 55 41 54 45 20 41 4c 4c 20 0a 09 09 EVALUATE ALL ...
a680: 20 20 20 28 72 75 6e 63 6f 6e 66 69 67 20 20 28 (runconfig (
a690: 72 65 61 64 2d 63 6f 6e 66 69 67 20 72 75 6e 63 read-config runc
a6a0: 6f 6e 66 69 67 66 20 23 66 20 23 66 20 65 6e 76 onfigf #f #f env
a6b0: 69 72 6f 6e 2d 70 61 74 74 3a 20 23 66 29 29 29 iron-patt: #f)))
a6c0: 20 0a 09 20 20 20 20 20 20 28 69 66 20 28 68 61 .. (if (ha
a6d0: 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 sh-table-ref/def
a6e0: 61 75 6c 74 20 72 75 6e 63 6f 6e 66 69 67 20 28 ault runconfig (
a6f0: 61 72 67 73 3a 67 65 74 2d 61 72 67 20 22 2d 72 args:get-arg "-r
a700: 65 71 74 61 72 67 22 29 20 23 66 29 0a 09 09 20 eqtarg") #f)...
a710: 20 28 6b 65 79 73 3a 74 61 72 67 65 74 2d 73 65 (keys:target-se
a720: 74 2d 61 72 67 73 20 6b 65 79 73 20 28 61 72 67 t-args keys (arg
a730: 73 3a 67 65 74 2d 61 72 67 20 22 2d 72 65 71 74 s:get-arg "-reqt
a740: 61 72 67 22 29 20 61 72 67 73 3a 61 72 67 2d 68 arg") args:arg-h
a750: 61 73 68 29 0a 09 09 20 20 28 62 65 67 69 6e 0a ash)... (begin.
a760: 09 09 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 .. (debug:pri
a770: 6e 74 20 30 20 22 45 52 52 4f 52 3a 20 5b 22 20 nt 0 "ERROR: ["
a780: 28 61 72 67 73 3a 67 65 74 2d 61 72 67 20 22 2d (args:get-arg "-
a790: 72 65 71 74 61 72 67 22 29 20 22 5d 20 6e 6f 74 reqtarg") "] not
a7a0: 20 66 6f 75 6e 64 20 69 6e 20 22 20 72 75 6e 63 found in " runc
a7b0: 6f 6e 66 69 67 66 29 0a 09 09 20 20 20 20 28 69 onfigf)... (i
a7c0: 66 20 64 62 20 28 73 71 6c 69 74 65 33 3a 66 69 f db (sqlite3:fi
a7d0: 6e 61 6c 69 7a 65 21 20 64 62 29 29 0a 09 09 20 nalize! db))...
a7e0: 20 20 20 28 65 78 69 74 20 31 29 29 29 29 0a 09 (exit 1))))..
a7f0: 20 20 20 20 28 69 66 20 28 61 72 67 73 3a 67 65 (if (args:ge
a800: 74 2d 61 72 67 20 22 2d 74 61 72 67 65 74 22 29 t-arg "-target")
a810: 0a 09 09 28 6b 65 79 73 3a 74 61 72 67 65 74 2d ...(keys:target-
a820: 73 65 74 2d 61 72 67 73 20 6b 65 79 73 20 28 61 set-args keys (a
a830: 72 67 73 3a 67 65 74 2d 61 72 67 20 22 2d 74 61 rgs:get-arg "-ta
a840: 72 67 65 74 22 20 61 72 67 73 3a 61 72 67 2d 68 rget" args:arg-h
a850: 61 73 68 29 20 61 72 67 73 3a 61 72 67 2d 68 61 ash) args:arg-ha
a860: 73 68 29 29 29 0a 09 28 69 66 20 28 6e 6f 74 20 sh)))..(if (not
a870: 28 63 61 72 20 2a 63 6f 6e 66 69 67 69 6e 66 6f (car *configinfo
a880: 2a 29 29 0a 09 20 20 20 20 28 62 65 67 69 6e 0a *)).. (begin.
a890: 09 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 . (debug:pr
a8a0: 69 6e 74 20 30 20 22 45 52 52 4f 52 3a 20 41 74 int 0 "ERROR: At
a8b0: 74 65 6d 70 74 65 64 20 74 6f 20 22 20 61 63 74 tempted to " act
a8c0: 69 6f 6e 2d 64 65 73 63 20 22 20 62 75 74 20 72 ion-desc " but r
a8d0: 75 6e 20 61 72 65 61 20 63 6f 6e 66 69 67 20 66 un area config f
a8e0: 69 6c 65 20 6e 6f 74 20 66 6f 75 6e 64 22 29 0a ile not found").
a8f0: 09 20 20 20 20 20 20 28 65 78 69 74 20 31 29 29 . (exit 1))
a900: 0a 09 20 20 20 20 3b 3b 20 45 78 74 72 61 63 74 .. ;; Extract
a910: 20 6f 75 74 20 73 74 75 66 66 20 6e 65 65 64 65 out stuff neede
a920: 64 20 69 6e 20 6d 6f 73 74 20 6f 72 20 6d 61 6e d in most or man
a930: 79 20 63 61 6c 6c 73 0a 09 20 20 20 20 3b 3b 20 y calls.. ;;
a940: 68 65 72 65 20 74 68 65 6e 20 63 61 6c 6c 20 70 here then call p
a950: 72 6f 63 0a 09 20 20 20 20 28 6c 65 74 2a 20 28 roc.. (let* (
a960: 28 6b 65 79 6e 61 6d 65 73 20 20 20 28 6d 61 70 (keynames (map
a970: 20 6b 65 79 3a 67 65 74 2d 66 69 65 6c 64 6e 61 key:get-fieldna
a980: 6d 65 20 6b 65 79 73 29 29 0a 09 09 20 20 20 28 me keys))... (
a990: 6b 65 79 76 61 6c 6c 73 74 20 20 28 6b 65 79 73 keyvallst (keys
a9a0: 2d 3e 76 61 6c 6c 69 73 74 20 6b 65 79 73 20 23 ->vallist keys #
a9b0: 74 29 29 29 0a 09 20 20 20 20 20 20 28 70 72 6f t))).. (pro
a9c0: 63 20 74 61 72 67 65 74 20 72 75 6e 6e 61 6d 65 c target runname
a9d0: 20 6b 65 79 73 20 6b 65 79 6e 61 6d 65 73 20 6b keys keynames k
a9e0: 65 79 76 61 6c 6c 73 74 29 29 29 0a 09 28 69 66 eyvallst)))..(if
a9f0: 20 74 68 31 20 28 74 68 72 65 61 64 2d 6a 6f 69 th1 (thread-joi
aa00: 6e 21 20 74 68 31 29 29 0a 09 28 69 66 20 64 62 n! th1))..(if db
aa10: 20 28 73 71 6c 69 74 65 33 3a 66 69 6e 61 6c 69 (sqlite3:finali
aa20: 7a 65 21 20 64 62 29 29 0a 09 28 73 65 74 21 20 ze! db))..(set!
aa30: 2a 64 69 64 73 6f 6d 65 74 68 69 6e 67 2a 20 23 *didsomething* #
aa40: 74 29 29 29 29 29 29 0a 0a 3b 3b 3d 3d 3d 3d 3d t))))))..;;=====
aa50: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
aa60: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
aa70: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
aa80: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
aa90: 3d 0a 3b 3b 20 4c 6f 63 6b 2f 75 6e 6c 6f 63 6b =.;; Lock/unlock
aaa0: 20 72 75 6e 73 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d runs.;;========
aab0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
aac0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
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 0a 0a ==============..
aaf0: 28 64 65 66 69 6e 65 20 28 72 75 6e 73 3a 68 61 (define (runs:ha
ab00: 6e 64 6c 65 2d 6c 6f 63 6b 69 6e 67 20 74 61 72 ndle-locking tar
ab10: 67 65 74 20 6b 65 79 73 20 72 75 6e 6e 61 6d 65 get keys runname
ab20: 20 6c 6f 63 6b 20 75 6e 6c 6f 63 6b 20 75 73 65 lock unlock use
ab30: 72 29 0a 20 20 28 6c 65 74 2a 20 28 28 64 62 20 r). (let* ((db
ab40: 20 20 20 20 20 20 23 66 29 0a 09 20 28 72 75 6e #f).. (run
ab50: 64 61 74 20 20 20 28 6f 70 65 6e 2d 72 75 6e 2d dat (open-run-
ab60: 63 6c 6f 73 65 20 72 75 6e 73 3a 67 65 74 2d 72 close runs:get-r
ab70: 75 6e 73 2d 62 79 2d 70 61 74 74 20 64 62 20 6b uns-by-patt db k
ab80: 65 79 73 20 72 75 6e 6e 61 6d 65 29 29 0a 09 20 eys runname))..
ab90: 28 68 65 61 64 65 72 20 20 20 28 76 65 63 74 6f (header (vecto
aba0: 72 2d 72 65 66 20 72 75 6e 64 61 74 20 30 29 29 r-ref rundat 0))
abb0: 0a 09 20 28 72 75 6e 73 20 20 20 20 20 28 76 65 .. (runs (ve
abc0: 63 74 6f 72 2d 72 65 66 20 72 75 6e 64 61 74 20 ctor-ref rundat
abd0: 31 29 29 29 0a 20 20 20 20 28 66 6f 72 2d 65 61 1))). (for-ea
abe0: 63 68 20 28 6c 61 6d 62 64 61 20 28 72 75 6e 29 ch (lambda (run)
abf0: 0a 09 09 28 6c 65 74 20 28 28 72 75 6e 2d 69 64 ...(let ((run-id
ac00: 20 28 64 62 3a 67 65 74 2d 76 61 6c 75 65 2d 62 (db:get-value-b
ac10: 79 2d 68 65 61 64 65 72 20 72 75 6e 20 68 65 61 y-header run hea
ac20: 64 65 72 20 22 69 64 22 29 29 29 0a 09 09 20 20 der "id")))...
ac30: 28 69 66 20 28 6f 72 20 6c 6f 63 6b 0a 09 09 09 (if (or lock....
ac40: 20 20 28 61 6e 64 20 75 6e 6c 6f 63 6b 0a 09 09 (and unlock...
ac50: 09 20 20 20 20 20 20 20 28 62 65 67 69 6e 0a 09 . (begin..
ac60: 09 09 09 20 28 70 72 69 6e 74 20 22 44 6f 20 79 ... (print "Do y
ac70: 6f 75 20 72 65 61 6c 6c 79 20 77 69 73 68 20 74 ou really wish t
ac80: 6f 20 75 6e 6c 6f 63 6b 20 72 75 6e 20 22 20 72 o unlock run " r
ac90: 75 6e 2d 69 64 20 22 3f 5c 6e 20 20 20 79 2f 6e un-id "?\n y/n
aca0: 3a 20 22 29 0a 09 09 09 09 20 28 65 71 75 61 6c : ")..... (equal
acb0: 3f 20 22 79 22 20 28 72 65 61 64 2d 6c 69 6e 65 ? "y" (read-line
acc0: 29 29 29 29 29 0a 09 09 20 20 20 20 20 20 28 6f )))))... (o
acd0: 70 65 6e 2d 72 75 6e 2d 63 6c 6f 73 65 20 64 62 pen-run-close db
ace0: 3a 6c 6f 63 6b 2f 75 6e 6c 6f 63 6b 2d 72 75 6e :lock/unlock-run
acf0: 20 64 62 20 72 75 6e 2d 69 64 20 6c 6f 63 6b 20 db run-id lock
ad00: 75 6e 6c 6f 63 6b 20 75 73 65 72 29 0a 09 09 20 unlock user)...
ad10: 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e (debug:prin
ad20: 74 2d 69 6e 66 6f 20 30 20 22 53 6b 69 70 70 69 t-info 0 "Skippi
ad30: 6e 67 20 6c 6f 63 6b 2f 75 6e 6c 6f 63 6b 20 6f ng lock/unlock o
ad40: 6e 20 22 20 72 75 6e 2d 69 64 29 29 29 29 0a 09 n " run-id))))..
ad50: 20 20 20 20 20 20 72 75 6e 73 29 29 29 0a 3b 3b runs))).;;
ad60: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
ad70: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
ad80: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
ad90: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
ada0: 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 52 6f 6c 6c 75 70 ======.;; Rollup
adb0: 20 72 75 6e 73 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d runs.;;========
adc0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
add0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
ade0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
adf0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a ==============..
ae00: 3b 3b 20 55 70 64 61 74 65 20 74 68 65 20 74 65 ;; Update the te
ae10: 73 74 5f 6d 65 74 61 20 74 61 62 6c 65 20 66 6f st_meta table fo
ae20: 72 20 74 68 69 73 20 74 65 73 74 0a 28 64 65 66 r this test.(def
ae30: 69 6e 65 20 28 72 75 6e 73 3a 75 70 64 61 74 65 ine (runs:update
ae40: 2d 74 65 73 74 5f 6d 65 74 61 20 64 62 20 74 65 -test_meta db te
ae50: 73 74 2d 6e 61 6d 65 20 74 65 73 74 2d 63 6f 6e st-name test-con
ae60: 66 29 0a 20 20 28 6c 65 74 20 28 28 63 75 72 72 f). (let ((curr
ae70: 72 65 63 6f 72 64 20 28 6f 70 65 6e 2d 72 75 6e record (open-run
ae80: 2d 63 6c 6f 73 65 20 64 62 3a 74 65 73 74 6d 65 -close db:testme
ae90: 74 61 2d 67 65 74 2d 72 65 63 6f 72 64 20 64 62 ta-get-record db
aea0: 20 74 65 73 74 2d 6e 61 6d 65 29 29 29 0a 20 20 test-name))).
aeb0: 20 20 28 69 66 20 28 6e 6f 74 20 63 75 72 72 72 (if (not currr
aec0: 65 63 6f 72 64 29 0a 09 28 62 65 67 69 6e 0a 09 ecord)..(begin..
aed0: 20 20 28 73 65 74 21 20 63 75 72 72 72 65 63 6f (set! currreco
aee0: 72 64 20 28 6d 61 6b 65 2d 76 65 63 74 6f 72 20 rd (make-vector
aef0: 31 30 20 23 66 29 29 0a 09 20 20 28 6f 70 65 6e 10 #f)).. (open
af00: 2d 72 75 6e 2d 63 6c 6f 73 65 20 64 62 3a 74 65 -run-close db:te
af10: 73 74 6d 65 74 61 2d 61 64 64 2d 72 65 63 6f 72 stmeta-add-recor
af20: 64 20 64 62 20 74 65 73 74 2d 6e 61 6d 65 29 29 d db test-name))
af30: 29 0a 20 20 20 20 28 66 6f 72 2d 65 61 63 68 20 ). (for-each
af40: 0a 20 20 20 20 20 28 6c 61 6d 62 64 61 20 28 6b . (lambda (k
af50: 65 79 29 0a 20 20 20 20 20 20 20 28 6c 65 74 2a ey). (let*
af60: 20 28 28 69 64 78 20 28 63 61 64 72 20 6b 65 79 ((idx (cadr key
af70: 29 29 0a 09 20 20 20 20 20 20 28 66 6c 64 20 28 )).. (fld (
af80: 63 61 72 20 20 6b 65 79 29 29 0a 09 20 20 20 20 car key))..
af90: 20 20 28 76 61 6c 20 28 63 6f 6e 66 69 67 2d 6c (val (config-l
afa0: 6f 6f 6b 75 70 20 74 65 73 74 2d 63 6f 6e 66 20 ookup test-conf
afb0: 22 74 65 73 74 5f 6d 65 74 61 22 20 66 6c 64 29 "test_meta" fld)
afc0: 29 29 0a 09 20 3b 3b 20 28 64 65 62 75 67 3a 70 )).. ;; (debug:p
afd0: 72 69 6e 74 20 35 20 22 69 64 78 3a 20 22 20 69 rint 5 "idx: " i
afe0: 64 78 20 22 20 66 6c 64 3a 20 22 20 66 6c 64 20 dx " fld: " fld
aff0: 22 20 76 61 6c 3a 20 22 20 76 61 6c 29 0a 09 20 " val: " val)..
b000: 28 69 66 20 28 61 6e 64 20 76 61 6c 20 28 6e 6f (if (and val (no
b010: 74 20 28 65 71 75 61 6c 3f 20 28 76 65 63 74 6f t (equal? (vecto
b020: 72 2d 72 65 66 20 63 75 72 72 72 65 63 6f 72 64 r-ref currrecord
b030: 20 69 64 78 29 20 76 61 6c 29 29 29 0a 09 20 20 idx) val)))..
b040: 20 20 20 28 62 65 67 69 6e 0a 09 20 20 20 20 20 (begin..
b050: 20 20 28 70 72 69 6e 74 20 22 55 70 64 61 74 69 (print "Updati
b060: 6e 67 20 22 20 74 65 73 74 2d 6e 61 6d 65 20 22 ng " test-name "
b070: 20 22 20 66 6c 64 20 22 20 74 6f 20 22 20 76 61 " fld " to " va
b080: 6c 29 0a 09 20 20 20 20 20 20 20 28 6f 70 65 6e l).. (open
b090: 2d 72 75 6e 2d 63 6c 6f 73 65 20 64 62 3a 74 65 -run-close db:te
b0a0: 73 74 6d 65 74 61 2d 75 70 64 61 74 65 2d 66 69 stmeta-update-fi
b0b0: 65 6c 64 20 64 62 20 74 65 73 74 2d 6e 61 6d 65 eld db test-name
b0c0: 20 66 6c 64 20 76 61 6c 29 29 29 29 29 0a 20 20 fld val))))).
b0d0: 20 20 20 27 28 28 22 61 75 74 68 6f 72 22 20 32 '(("author" 2
b0e0: 29 28 22 6f 77 6e 65 72 22 20 33 29 28 22 64 65 )("owner" 3)("de
b0f0: 73 63 72 69 70 74 69 6f 6e 22 20 34 29 28 22 72 scription" 4)("r
b100: 65 76 69 65 77 65 64 22 20 35 29 28 22 74 61 67 eviewed" 5)("tag
b110: 73 22 20 39 29 29 29 29 29 0a 0a 3b 3b 20 55 70 s" 9)))))..;; Up
b120: 64 61 74 65 20 74 65 73 74 5f 6d 65 74 61 20 66 date test_meta f
b130: 6f 72 20 61 6c 6c 20 74 65 73 74 73 0a 28 64 65 or all tests.(de
b140: 66 69 6e 65 20 28 72 75 6e 73 3a 75 70 64 61 74 fine (runs:updat
b150: 65 2d 61 6c 6c 2d 74 65 73 74 5f 6d 65 74 61 20 e-all-test_meta
b160: 64 62 29 0a 20 20 28 6c 65 74 20 28 28 74 65 73 db). (let ((tes
b170: 74 2d 6e 61 6d 65 73 20 28 67 65 74 2d 61 6c 6c t-names (get-all
b180: 2d 6c 65 67 61 6c 2d 74 65 73 74 73 29 29 29 0a -legal-tests))).
b190: 20 20 20 20 28 66 6f 72 2d 65 61 63 68 20 0a 20 (for-each .
b1a0: 20 20 20 20 28 6c 61 6d 62 64 61 20 28 74 65 73 (lambda (tes
b1b0: 74 2d 6e 61 6d 65 29 0a 20 20 20 20 20 20 20 28 t-name). (
b1c0: 6c 65 74 2a 20 28 28 74 65 73 74 2d 70 61 74 68 let* ((test-path
b1d0: 20 20 20 20 28 63 6f 6e 63 20 2a 74 6f 70 70 61 (conc *toppa
b1e0: 74 68 2a 20 22 2f 74 65 73 74 73 2f 22 20 74 65 th* "/tests/" te
b1f0: 73 74 2d 6e 61 6d 65 29 29 0a 09 20 20 20 20 20 st-name))..
b200: 20 28 74 65 73 74 2d 63 6f 6e 66 69 67 66 20 28 (test-configf (
b210: 63 6f 6e 63 20 74 65 73 74 2d 70 61 74 68 20 22 conc test-path "
b220: 2f 74 65 73 74 63 6f 6e 66 69 67 22 29 29 0a 09 /testconfig"))..
b230: 20 20 20 20 20 20 28 74 65 73 74 65 78 69 73 74 (testexist
b240: 73 20 20 20 28 61 6e 64 20 28 66 69 6c 65 2d 65 s (and (file-e
b250: 78 69 73 74 73 3f 20 74 65 73 74 2d 63 6f 6e 66 xists? test-conf
b260: 69 67 66 29 28 66 69 6c 65 2d 72 65 61 64 2d 61 igf)(file-read-a
b270: 63 63 65 73 73 3f 20 74 65 73 74 2d 63 6f 6e 66 ccess? test-conf
b280: 69 67 66 29 29 29 0a 09 20 20 20 20 20 20 3b 3b igf))).. ;;
b290: 20 72 65 61 64 20 63 6f 6e 66 69 67 73 20 77 69 read configs wi
b2a0: 74 68 20 74 72 69 63 6b 73 20 74 75 72 6e 65 64 th tricks turned
b2b0: 20 6f 66 66 20 28 69 2e 65 2e 20 6e 6f 20 73 79 off (i.e. no sy
b2c0: 73 74 65 6d 29 0a 09 20 20 20 20 20 20 28 74 65 stem).. (te
b2d0: 73 74 2d 63 6f 6e 66 20 20 20 20 28 69 66 20 74 st-conf (if t
b2e0: 65 73 74 65 78 69 73 74 73 20 28 72 65 61 64 2d estexists (read-
b2f0: 63 6f 6e 66 69 67 20 74 65 73 74 2d 63 6f 6e 66 config test-conf
b300: 69 67 66 20 23 66 20 23 66 29 28 6d 61 6b 65 2d igf #f #f)(make-
b310: 68 61 73 68 2d 74 61 62 6c 65 29 29 29 29 0a 09 hash-table))))..
b320: 20 3b 3b 20 75 73 65 20 74 68 65 20 6f 70 65 6e ;; use the open
b330: 2d 72 75 6e 2d 63 6c 6f 73 65 20 69 6e 73 74 65 -run-close inste
b340: 61 64 20 6f 66 20 70 61 73 73 69 6e 67 20 69 6e ad of passing in
b350: 20 64 62 0a 09 20 28 72 75 6e 73 3a 75 70 64 61 db.. (runs:upda
b360: 74 65 2d 74 65 73 74 5f 6d 65 74 61 20 23 66 20 te-test_meta #f
b370: 74 65 73 74 2d 6e 61 6d 65 20 74 65 73 74 2d 63 test-name test-c
b380: 6f 6e 66 29 29 29 0a 20 20 20 20 20 74 65 73 74 onf))). test
b390: 2d 6e 61 6d 65 73 29 29 29 0a 0a 3b 3b 20 54 68 -names)))..;; Th
b3a0: 69 73 20 63 6f 75 6c 64 20 70 72 6f 62 61 62 6c is could probabl
b3b0: 79 20 62 65 20 72 65 66 61 63 74 6f 72 65 64 20 y be refactored
b3c0: 69 6e 74 6f 20 6f 6e 65 20 63 6f 6d 70 6c 65 78 into one complex
b3d0: 20 71 75 65 72 79 20 2e 2e 2e 0a 28 64 65 66 69 query ....(defi
b3e0: 6e 65 20 28 72 75 6e 73 3a 72 6f 6c 6c 75 70 2d ne (runs:rollup-
b3f0: 72 75 6e 20 6b 65 79 73 20 6b 65 79 76 61 6c 6c run keys keyvall
b400: 73 74 20 72 75 6e 6e 61 6d 65 20 75 73 65 72 29 st runname user)
b410: 20 3b 3b 20 77 61 73 20 74 61 72 67 65 74 2c 20 ;; was target,
b420: 6e 6f 77 20 6b 65 79 76 61 6c 6c 73 74 0a 20 20 now keyvallst.
b430: 28 64 65 62 75 67 3a 70 72 69 6e 74 20 34 20 22 (debug:print 4 "
b440: 72 75 6e 73 3a 72 6f 6c 6c 75 70 2d 72 75 6e 2c runs:rollup-run,
b450: 20 6b 65 79 73 3a 20 22 20 6b 65 79 73 20 22 20 keys: " keys "
b460: 6b 65 79 76 61 6c 6c 73 74 3a 20 22 20 6b 65 79 keyvallst: " key
b470: 76 61 6c 6c 73 74 20 22 20 3a 72 75 6e 6e 61 6d vallst " :runnam
b480: 65 20 22 20 72 75 6e 6e 61 6d 65 20 22 20 75 73 e " runname " us
b490: 65 72 3a 20 22 20 75 73 65 72 29 0a 20 20 28 6c er: " user). (l
b4a0: 65 74 2a 20 28 28 64 62 20 20 20 20 20 20 20 20 et* ((db
b4b0: 20 20 20 20 20 20 23 66 29 20 3b 3b 20 28 6b 65 #f) ;; (ke
b4c0: 79 76 61 6c 6c 6c 73 74 20 20 20 20 20 20 28 6b yvalllst (k
b4d0: 65 79 73 3a 74 61 72 67 65 74 2d 3e 6b 65 79 76 eys:target->keyv
b4e0: 61 6c 20 6b 65 79 73 20 74 61 72 67 65 74 29 29 al keys target))
b4f0: 0a 09 20 28 6e 65 77 2d 72 75 6e 2d 69 64 20 20 .. (new-run-id
b500: 20 20 20 20 28 6f 70 65 6e 2d 72 75 6e 2d 63 6c (open-run-cl
b510: 6f 73 65 20 72 75 6e 73 3a 72 65 67 69 73 74 65 ose runs:registe
b520: 72 2d 72 75 6e 20 64 62 20 6b 65 79 73 20 6b 65 r-run db keys ke
b530: 79 76 61 6c 6c 73 74 20 72 75 6e 6e 61 6d 65 20 yvallst runname
b540: 22 6e 65 77 22 20 22 6e 2f 61 22 20 75 73 65 72 "new" "n/a" user
b550: 29 29 0a 09 20 28 70 72 65 76 2d 74 65 73 74 73 )).. (prev-tests
b560: 20 20 20 20 20 20 28 6f 70 65 6e 2d 72 75 6e 2d (open-run-
b570: 63 6c 6f 73 65 20 74 65 73 74 3a 67 65 74 2d 6d close test:get-m
b580: 61 74 63 68 69 6e 67 2d 70 72 65 76 69 6f 75 73 atching-previous
b590: 2d 74 65 73 74 2d 72 75 6e 2d 72 65 63 6f 72 64 -test-run-record
b5a0: 73 20 64 62 20 6e 65 77 2d 72 75 6e 2d 69 64 20 s db new-run-id
b5b0: 22 25 22 20 22 25 22 29 29 0a 09 20 28 63 75 72 "%" "%")).. (cur
b5c0: 72 2d 74 65 73 74 73 20 20 20 20 20 20 28 6f 70 r-tests (op
b5d0: 65 6e 2d 72 75 6e 2d 63 6c 6f 73 65 20 64 62 3a en-run-close db:
b5e0: 67 65 74 2d 74 65 73 74 73 2d 66 6f 72 2d 72 75 get-tests-for-ru
b5f0: 6e 20 64 62 20 6e 65 77 2d 72 75 6e 2d 69 64 20 n db new-run-id
b600: 22 25 2f 25 22 20 27 28 29 20 27 28 29 29 29 0a "%/%" '() '())).
b610: 09 20 28 63 75 72 72 2d 74 65 73 74 73 2d 68 61 . (curr-tests-ha
b620: 73 68 20 28 6d 61 6b 65 2d 68 61 73 68 2d 74 61 sh (make-hash-ta
b630: 62 6c 65 29 29 29 0a 20 20 20 20 28 6f 70 65 6e ble))). (open
b640: 2d 72 75 6e 2d 63 6c 6f 73 65 20 64 62 3a 75 70 -run-close db:up
b650: 64 61 74 65 2d 72 75 6e 2d 65 76 65 6e 74 5f 74 date-run-event_t
b660: 69 6d 65 20 64 62 20 6e 65 77 2d 72 75 6e 2d 69 ime db new-run-i
b670: 64 29 0a 20 20 20 20 3b 3b 20 69 6e 64 65 78 20 d). ;; index
b680: 74 68 65 20 61 6c 72 65 61 64 79 20 73 61 76 65 the already save
b690: 64 20 74 65 73 74 73 20 62 79 20 74 65 73 74 6e d tests by testn
b6a0: 61 6d 65 20 61 6e 64 20 69 74 65 6d 64 61 74 20 ame and itemdat
b6b0: 69 6e 20 63 75 72 72 2d 74 65 73 74 73 2d 68 61 in curr-tests-ha
b6c0: 73 68 0a 20 20 20 20 28 66 6f 72 2d 65 61 63 68 sh. (for-each
b6d0: 0a 20 20 20 20 20 28 6c 61 6d 62 64 61 20 28 74 . (lambda (t
b6e0: 65 73 74 64 61 74 29 0a 20 20 20 20 20 20 20 28 estdat). (
b6f0: 6c 65 74 2a 20 28 28 74 65 73 74 6e 61 6d 65 20 let* ((testname
b700: 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 74 65 (db:test-get-te
b710: 73 74 6e 61 6d 65 20 74 65 73 74 64 61 74 29 29 stname testdat))
b720: 0a 09 20 20 20 20 20 20 28 69 74 65 6d 2d 70 61 .. (item-pa
b730: 74 68 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d th (db:test-get-
b740: 69 74 65 6d 2d 70 61 74 68 20 74 65 73 74 64 61 item-path testda
b750: 74 29 29 0a 09 20 20 20 20 20 20 28 66 75 6c 6c t)).. (full
b760: 2d 6e 61 6d 65 20 28 63 6f 6e 63 20 74 65 73 74 -name (conc test
b770: 6e 61 6d 65 20 22 2f 22 20 69 74 65 6d 2d 70 61 name "/" item-pa
b780: 74 68 29 29 29 0a 09 20 28 68 61 73 68 2d 74 61 th))).. (hash-ta
b790: 62 6c 65 2d 73 65 74 21 20 63 75 72 72 2d 74 65 ble-set! curr-te
b7a0: 73 74 73 2d 68 61 73 68 20 66 75 6c 6c 2d 6e 61 sts-hash full-na
b7b0: 6d 65 20 74 65 73 74 64 61 74 29 29 29 0a 20 20 me testdat))).
b7c0: 20 20 20 63 75 72 72 2d 74 65 73 74 73 29 0a 20 curr-tests).
b7d0: 20 20 20 3b 3b 20 4e 4f 50 45 3a 20 4e 6f 6e 2d ;; NOPE: Non-
b7e0: 6f 70 74 69 6d 61 6c 20 61 70 70 72 6f 61 63 68 optimal approach
b7f0: 2e 20 54 72 79 20 74 68 69 73 20 69 6e 73 74 65 . Try this inste
b800: 61 64 2e 0a 20 20 20 20 3b 3b 20 20 20 31 2e 20 ad.. ;; 1.
b810: 74 65 73 74 73 20 61 72 65 20 72 65 63 65 69 76 tests are receiv
b820: 65 64 20 69 6e 20 61 20 6c 69 73 74 2c 20 6d 6f ed in a list, mo
b830: 73 74 20 72 65 63 65 6e 74 20 66 69 72 73 74 0a st recent first.
b840: 20 20 20 20 3b 3b 20 20 20 32 2e 20 72 65 70 6c ;; 2. repl
b850: 61 63 65 20 74 68 65 20 72 6f 6c 6c 75 70 20 74 ace the rollup t
b860: 65 73 74 20 77 69 74 68 20 74 68 65 20 6e 65 77 est with the new
b870: 20 2a 61 6c 77 61 79 73 2a 0a 20 20 20 20 28 66 *always*. (f
b880: 6f 72 2d 65 61 63 68 20 0a 20 20 20 20 20 28 6c or-each . (l
b890: 61 6d 62 64 61 20 28 74 65 73 74 64 61 74 29 0a ambda (testdat).
b8a0: 20 20 20 20 20 20 20 28 6c 65 74 2a 20 28 28 74 (let* ((t
b8b0: 65 73 74 6e 61 6d 65 20 20 28 64 62 3a 74 65 73 estname (db:tes
b8c0: 74 2d 67 65 74 2d 74 65 73 74 6e 61 6d 65 20 74 t-get-testname t
b8d0: 65 73 74 64 61 74 29 29 0a 09 20 20 20 20 20 20 estdat))..
b8e0: 28 69 74 65 6d 2d 70 61 74 68 20 28 64 62 3a 74 (item-path (db:t
b8f0: 65 73 74 2d 67 65 74 2d 69 74 65 6d 2d 70 61 74 est-get-item-pat
b900: 68 20 74 65 73 74 64 61 74 29 29 0a 09 20 20 20 h testdat))..
b910: 20 20 20 28 66 75 6c 6c 2d 6e 61 6d 65 20 28 63 (full-name (c
b920: 6f 6e 63 20 74 65 73 74 6e 61 6d 65 20 22 2f 22 onc testname "/"
b930: 20 69 74 65 6d 2d 70 61 74 68 29 29 0a 09 20 20 item-path))..
b940: 20 20 20 20 28 70 72 65 76 2d 74 65 73 74 2d 64 (prev-test-d
b950: 61 74 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 at (hash-table-r
b960: 65 66 2f 64 65 66 61 75 6c 74 20 63 75 72 72 2d ef/default curr-
b970: 74 65 73 74 73 2d 68 61 73 68 20 66 75 6c 6c 2d tests-hash full-
b980: 6e 61 6d 65 20 23 66 29 29 0a 09 20 20 20 20 20 name #f))..
b990: 20 28 74 65 73 74 2d 73 74 65 70 73 20 20 20 20 (test-steps
b9a0: 20 20 28 6f 70 65 6e 2d 72 75 6e 2d 63 6c 6f 73 (open-run-clos
b9b0: 65 20 64 62 3a 67 65 74 2d 73 74 65 70 73 2d 66 e db:get-steps-f
b9c0: 6f 72 2d 74 65 73 74 20 64 62 20 28 64 62 3a 74 or-test db (db:t
b9d0: 65 73 74 2d 67 65 74 2d 69 64 20 74 65 73 74 64 est-get-id testd
b9e0: 61 74 29 29 29 0a 09 20 20 20 20 20 20 28 6e 65 at))).. (ne
b9f0: 77 2d 74 65 73 74 2d 72 65 63 6f 72 64 20 23 66 w-test-record #f
ba00: 29 29 0a 09 20 3b 3b 20 72 65 70 6c 61 63 65 20 )).. ;; replace
ba10: 74 68 65 73 65 20 77 69 74 68 20 69 6e 73 65 72 these with inser
ba20: 74 20 2e 2e 2e 20 73 65 6c 65 63 74 0a 09 20 28 t ... select.. (
ba30: 61 70 70 6c 79 20 73 71 6c 69 74 65 33 3a 65 78 apply sqlite3:ex
ba40: 65 63 75 74 65 20 0a 09 09 64 62 20 0a 09 09 28 ecute ...db ...(
ba50: 63 6f 6e 63 20 22 49 4e 53 45 52 54 20 4f 52 20 conc "INSERT OR
ba60: 52 45 50 4c 41 43 45 20 49 4e 54 4f 20 74 65 73 REPLACE INTO tes
ba70: 74 73 20 28 72 75 6e 5f 69 64 2c 74 65 73 74 6e ts (run_id,testn
ba80: 61 6d 65 2c 73 74 61 74 65 2c 73 74 61 74 75 73 ame,state,status
ba90: 2c 65 76 65 6e 74 5f 74 69 6d 65 2c 68 6f 73 74 ,event_time,host
baa0: 2c 63 70 75 6c 6f 61 64 2c 64 69 73 6b 66 72 65 ,cpuload,diskfre
bab0: 65 2c 75 6e 61 6d 65 2c 72 75 6e 64 69 72 2c 69 e,uname,rundir,i
bac0: 74 65 6d 5f 70 61 74 68 2c 72 75 6e 5f 64 75 72 tem_path,run_dur
bad0: 61 74 69 6f 6e 2c 66 69 6e 61 6c 5f 6c 6f 67 66 ation,final_logf
bae0: 2c 63 6f 6d 6d 65 6e 74 29 20 22 0a 09 09 20 20 ,comment) "...
baf0: 20 20 20 20 22 56 41 4c 55 45 53 20 28 3f 2c 3f "VALUES (?,?
bb00: 2c 3f 2c 3f 2c 3f 2c 3f 2c 3f 2c 3f 2c 3f 2c 3f ,?,?,?,?,?,?,?,?
bb10: 2c 3f 2c 3f 2c 3f 2c 3f 29 3b 22 29 0a 09 09 6e ,?,?,?,?);")...n
bb20: 65 77 2d 72 75 6e 2d 69 64 20 28 63 64 64 72 20 ew-run-id (cddr
bb30: 28 76 65 63 74 6f 72 2d 3e 6c 69 73 74 20 74 65 (vector->list te
bb40: 73 74 64 61 74 29 29 29 0a 09 20 28 73 65 74 21 stdat))).. (set!
bb50: 20 6e 65 77 2d 74 65 73 74 64 61 74 20 28 63 61 new-testdat (ca
bb60: 72 20 28 6f 70 65 6e 2d 72 75 6e 2d 63 6c 6f 73 r (open-run-clos
bb70: 65 20 64 62 3a 67 65 74 2d 74 65 73 74 73 2d 66 e db:get-tests-f
bb80: 6f 72 2d 72 75 6e 20 64 62 20 6e 65 77 2d 72 75 or-run db new-ru
bb90: 6e 2d 69 64 20 28 63 6f 6e 63 20 74 65 73 74 6e n-id (conc testn
bba0: 61 6d 65 20 22 2f 22 20 69 74 65 6d 2d 70 61 74 ame "/" item-pat
bbb0: 68 29 20 27 28 29 20 27 28 29 29 29 29 0a 09 20 h) '() '())))..
bbc0: 28 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 (hash-table-set!
bbd0: 20 63 75 72 72 2d 74 65 73 74 73 2d 68 61 73 68 curr-tests-hash
bbe0: 20 66 75 6c 6c 2d 6e 61 6d 65 20 6e 65 77 2d 74 full-name new-t
bbf0: 65 73 74 64 61 74 29 20 3b 3b 20 74 68 69 73 20 estdat) ;; this
bc00: 63 6f 75 6c 64 20 62 65 20 63 6f 6e 66 75 73 69 could be confusi
bc10: 6e 67 2c 20 77 68 69 63 68 20 72 65 63 6f 72 64 ng, which record
bc20: 20 73 68 6f 75 6c 64 20 67 6f 20 69 6e 74 6f 20 should go into
bc30: 74 68 65 20 6c 6f 6f 6b 75 70 20 74 61 62 6c 65 the lookup table
bc40: 3f 0a 09 20 3b 3b 20 4e 6f 77 20 64 75 70 6c 69 ?.. ;; Now dupli
bc50: 63 61 74 65 20 74 68 65 20 74 65 73 74 20 73 74 cate the test st
bc60: 65 70 73 0a 09 20 28 64 65 62 75 67 3a 70 72 69 eps.. (debug:pri
bc70: 6e 74 20 34 20 22 43 6f 70 79 69 6e 67 20 72 65 nt 4 "Copying re
bc80: 63 6f 72 64 73 20 69 6e 20 74 65 73 74 5f 73 74 cords in test_st
bc90: 65 70 73 20 66 72 6f 6d 20 74 65 73 74 5f 69 64 eps from test_id
bca0: 3d 22 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d =" (db:test-get-
bcb0: 69 64 20 74 65 73 74 64 61 74 29 20 22 20 74 6f id testdat) " to
bcc0: 20 22 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d " (db:test-get-
bcd0: 69 64 20 6e 65 77 2d 74 65 73 74 64 61 74 29 29 id new-testdat))
bce0: 0a 09 20 28 6f 70 65 6e 2d 72 75 6e 2d 63 6c 6f .. (open-run-clo
bcf0: 73 65 20 0a 09 20 20 28 6c 61 6d 62 64 61 20 28 se .. (lambda (
bd00: 29 0a 09 20 20 20 20 28 73 71 6c 69 74 65 33 3a ).. (sqlite3:
bd10: 65 78 65 63 75 74 65 20 0a 09 20 20 20 20 20 64 execute .. d
bd20: 62 20 0a 09 20 20 20 20 20 28 63 6f 6e 63 20 22 b .. (conc "
bd30: 49 4e 53 45 52 54 20 4f 52 20 52 45 50 4c 41 43 INSERT OR REPLAC
bd40: 45 20 49 4e 54 4f 20 74 65 73 74 5f 73 74 65 70 E INTO test_step
bd50: 73 20 28 74 65 73 74 5f 69 64 2c 73 74 65 70 6e s (test_id,stepn
bd60: 61 6d 65 2c 73 74 61 74 65 2c 73 74 61 74 75 73 ame,state,status
bd70: 2c 65 76 65 6e 74 5f 74 69 6d 65 2c 63 6f 6d 6d ,event_time,comm
bd80: 65 6e 74 29 20 22 0a 09 09 20 20 20 22 53 45 4c ent) "... "SEL
bd90: 45 43 54 20 22 20 28 64 62 3a 74 65 73 74 2d 67 ECT " (db:test-g
bda0: 65 74 2d 69 64 20 6e 65 77 2d 74 65 73 74 64 61 et-id new-testda
bdb0: 74 29 20 22 2c 73 74 65 70 6e 61 6d 65 2c 73 74 t) ",stepname,st
bdc0: 61 74 65 2c 73 74 61 74 75 73 2c 65 76 65 6e 74 ate,status,event
bdd0: 5f 74 69 6d 65 2c 63 6f 6d 6d 65 6e 74 20 46 52 _time,comment FR
bde0: 4f 4d 20 74 65 73 74 5f 73 74 65 70 73 20 57 48 OM test_steps WH
bdf0: 45 52 45 20 74 65 73 74 5f 69 64 3d 3f 3b 22 29 ERE test_id=?;")
be00: 0a 09 20 20 20 20 20 28 64 62 3a 74 65 73 74 2d .. (db:test-
be10: 67 65 74 2d 69 64 20 74 65 73 74 64 61 74 29 29 get-id testdat))
be20: 0a 09 20 20 20 20 3b 3b 20 4e 6f 77 20 64 75 70 .. ;; Now dup
be30: 6c 69 63 61 74 65 20 74 68 65 20 74 65 73 74 20 licate the test
be40: 64 61 74 61 0a 09 20 20 20 20 28 64 65 62 75 67 data.. (debug
be50: 3a 70 72 69 6e 74 20 34 20 22 43 6f 70 79 69 6e :print 4 "Copyin
be60: 67 20 72 65 63 6f 72 64 73 20 69 6e 20 74 65 73 g records in tes
be70: 74 5f 64 61 74 61 20 66 72 6f 6d 20 74 65 73 74 t_data from test
be80: 5f 69 64 3d 22 20 28 64 62 3a 74 65 73 74 2d 67 _id=" (db:test-g
be90: 65 74 2d 69 64 20 74 65 73 74 64 61 74 29 20 22 et-id testdat) "
bea0: 20 74 6f 20 22 20 28 64 62 3a 74 65 73 74 2d 67 to " (db:test-g
beb0: 65 74 2d 69 64 20 6e 65 77 2d 74 65 73 74 64 61 et-id new-testda
bec0: 74 29 29 0a 09 20 20 20 20 28 73 71 6c 69 74 65 t)).. (sqlite
bed0: 33 3a 65 78 65 63 75 74 65 20 0a 09 20 20 20 20 3:execute ..
bee0: 20 64 62 20 0a 09 20 20 20 20 20 28 63 6f 6e 63 db .. (conc
bef0: 20 22 49 4e 53 45 52 54 20 4f 52 20 52 45 50 4c "INSERT OR REPL
bf00: 41 43 45 20 49 4e 54 4f 20 74 65 73 74 5f 64 61 ACE INTO test_da
bf10: 74 61 20 28 74 65 73 74 5f 69 64 2c 63 61 74 65 ta (test_id,cate
bf20: 67 6f 72 79 2c 76 61 72 69 61 62 6c 65 2c 76 61 gory,variable,va
bf30: 6c 75 65 2c 65 78 70 65 63 74 65 64 2c 74 6f 6c lue,expected,tol
bf40: 2c 75 6e 69 74 73 2c 63 6f 6d 6d 65 6e 74 29 20 ,units,comment)
bf50: 22 0a 09 09 20 20 20 22 53 45 4c 45 43 54 20 22 "... "SELECT "
bf60: 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 69 64 (db:test-get-id
bf70: 20 6e 65 77 2d 74 65 73 74 64 61 74 29 20 22 2c new-testdat) ",
bf80: 63 61 74 65 67 6f 72 79 2c 76 61 72 69 61 62 6c category,variabl
bf90: 65 2c 76 61 6c 75 65 2c 65 78 70 65 63 74 65 64 e,value,expected
bfa0: 2c 74 6f 6c 2c 75 6e 69 74 73 2c 63 6f 6d 6d 65 ,tol,units,comme
bfb0: 6e 74 20 46 52 4f 4d 20 74 65 73 74 5f 64 61 74 nt FROM test_dat
bfc0: 61 20 57 48 45 52 45 20 74 65 73 74 5f 69 64 3d a WHERE test_id=
bfd0: 3f 3b 22 29 0a 09 20 20 20 20 20 28 64 62 3a 74 ?;").. (db:t
bfe0: 65 73 74 2d 67 65 74 2d 69 64 20 74 65 73 74 64 est-get-id testd
bff0: 61 74 29 29 29 29 0a 09 20 29 29 0a 20 20 20 20 at)))).. )).
c000: 20 70 72 65 76 2d 74 65 73 74 73 29 29 29 0a 09 prev-tests)))..
c010: 20 0a 20 20 20 20 20 0a . .