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 3b 3b 20 41 h ")")))))..;; A
0970: 77 66 75 6c 2e 20 50 6c 65 61 73 65 20 46 49 58 wful. Please FIX
0980: 4d 45 0a 28 64 65 66 69 6e 65 20 2a 65 6e 76 2d ME.(define *env-
0990: 76 61 72 73 2d 62 79 2d 72 75 6e 2d 69 64 2a 20 vars-by-run-id*
09a0: 28 6d 61 6b 65 2d 68 61 73 68 2d 74 61 62 6c 65 (make-hash-table
09b0: 29 29 0a 28 64 65 66 69 6e 65 20 2a 63 75 72 72 )).(define *curr
09c0: 65 6e 74 2d 72 75 6e 2d 6e 61 6d 65 2a 20 20 20 ent-run-name*
09d0: 23 66 29 0a 0a 28 64 65 66 69 6e 65 20 28 64 62 #f)..(define (db
09e0: 3a 67 65 74 2d 72 75 6e 2d 6b 65 79 2d 76 61 6c :get-run-key-val
09f0: 20 64 62 20 72 75 6e 2d 69 64 20 6b 65 79 29 0a db run-id key).
0a00: 20 20 28 6c 65 74 20 28 28 72 65 73 20 23 66 29 (let ((res #f)
0a10: 29 0a 20 20 20 20 28 73 71 6c 69 74 65 33 3a 66 ). (sqlite3:f
0a20: 6f 72 2d 65 61 63 68 2d 72 6f 77 0a 20 20 20 20 or-each-row.
0a30: 20 28 6c 61 6d 62 64 61 20 28 76 61 6c 29 0a 20 (lambda (val).
0a40: 20 20 20 20 20 20 28 73 65 74 21 20 72 65 73 20 (set! res
0a50: 76 61 6c 29 29 0a 20 20 20 20 20 64 62 20 0a 20 val)). db .
0a60: 20 20 20 20 28 63 6f 6e 63 20 22 53 45 4c 45 43 (conc "SELEC
0a70: 54 20 22 20 28 6b 65 79 3a 67 65 74 2d 66 69 65 T " (key:get-fie
0a80: 6c 64 6e 61 6d 65 20 6b 65 79 29 20 22 20 46 52 ldname key) " FR
0a90: 4f 4d 20 72 75 6e 73 20 57 48 45 52 45 20 69 64 OM runs WHERE id
0aa0: 3d 3f 3b 22 29 0a 20 20 20 20 20 72 75 6e 2d 69 =?;"). run-i
0ab0: 64 29 0a 20 20 20 20 72 65 73 29 29 0a 0a 28 64 d). res))..(d
0ac0: 65 66 69 6e 65 20 28 64 62 3a 67 65 74 2d 72 75 efine (db:get-ru
0ad0: 6e 2d 6e 61 6d 65 2d 66 72 6f 6d 2d 69 64 20 64 n-name-from-id d
0ae0: 62 20 72 75 6e 2d 69 64 29 0a 20 20 28 6c 65 74 b run-id). (let
0af0: 20 28 28 72 65 73 20 23 66 29 29 0a 20 20 20 20 ((res #f)).
0b00: 28 73 71 6c 69 74 65 33 3a 66 6f 72 2d 65 61 63 (sqlite3:for-eac
0b10: 68 2d 72 6f 77 0a 20 20 20 20 20 28 6c 61 6d 62 h-row. (lamb
0b20: 64 61 20 28 72 75 6e 6e 61 6d 65 29 0a 20 20 20 da (runname).
0b30: 20 20 20 20 28 73 65 74 21 20 72 65 73 20 72 75 (set! res ru
0b40: 6e 6e 61 6d 65 29 29 0a 20 20 20 20 20 64 62 0a nname)). db.
0b50: 20 20 20 20 20 22 53 45 4c 45 43 54 20 72 75 6e "SELECT run
0b60: 6e 61 6d 65 20 46 52 4f 4d 20 72 75 6e 73 20 57 name FROM runs W
0b70: 48 45 52 45 20 69 64 3d 3f 3b 22 0a 20 20 20 20 HERE id=?;".
0b80: 20 72 75 6e 2d 69 64 29 0a 20 20 20 20 72 65 73 run-id). res
0b90: 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 73 65 74 ))..(define (set
0ba0: 2d 6d 65 67 61 74 65 73 74 2d 65 6e 76 2d 76 61 -megatest-env-va
0bb0: 72 73 20 72 75 6e 2d 69 64 29 0a 20 20 28 6c 65 rs run-id). (le
0bc0: 74 20 28 28 6b 65 79 73 20 28 63 64 62 3a 72 65 t ((keys (cdb:re
0bd0: 6d 6f 74 65 2d 72 75 6e 20 64 62 3a 67 65 74 2d mote-run db:get-
0be0: 6b 65 79 73 20 23 66 29 29 0a 09 28 76 61 6c 73 keys #f))..(vals
0bf0: 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 (hash-table-ref
0c00: 2f 64 65 66 61 75 6c 74 20 2a 65 6e 76 2d 76 61 /default *env-va
0c10: 72 73 2d 62 79 2d 72 75 6e 2d 69 64 2a 20 72 75 rs-by-run-id* ru
0c20: 6e 2d 69 64 20 23 66 29 29 29 0a 20 20 20 20 3b n-id #f))). ;
0c30: 3b 20 67 65 74 20 74 68 65 20 69 6e 66 6f 20 66 ; get the info f
0c40: 72 6f 6d 20 74 68 65 20 64 62 20 61 6e 64 20 70 rom the db and p
0c50: 75 74 20 69 74 20 69 6e 20 74 68 65 20 63 61 63 ut it in the cac
0c60: 68 65 0a 20 20 20 20 28 69 66 20 28 6e 6f 74 20 he. (if (not
0c70: 76 61 6c 73 29 0a 09 28 6c 65 74 20 28 28 68 74 vals)..(let ((ht
0c80: 20 28 6d 61 6b 65 2d 68 61 73 68 2d 74 61 62 6c (make-hash-tabl
0c90: 65 29 29 29 0a 09 20 20 28 68 61 73 68 2d 74 61 e))).. (hash-ta
0ca0: 62 6c 65 2d 73 65 74 21 20 2a 65 6e 76 2d 76 61 ble-set! *env-va
0cb0: 72 73 2d 62 79 2d 72 75 6e 2d 69 64 2a 20 72 75 rs-by-run-id* ru
0cc0: 6e 2d 69 64 20 68 74 29 0a 09 20 20 28 73 65 74 n-id ht).. (set
0cd0: 21 20 76 61 6c 73 20 68 74 29 0a 09 20 20 28 66 ! vals ht).. (f
0ce0: 6f 72 2d 65 61 63 68 0a 09 20 20 20 28 6c 61 6d or-each.. (lam
0cf0: 62 64 61 20 28 6b 65 79 29 0a 09 20 20 20 20 20 bda (key)..
0d00: 28 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 (hash-table-set!
0d10: 20 76 61 6c 73 20 6b 65 79 20 28 63 64 62 3a 72 vals key (cdb:r
0d20: 65 6d 6f 74 65 2d 72 75 6e 20 64 62 3a 67 65 74 emote-run db:get
0d30: 2d 72 75 6e 2d 6b 65 79 2d 76 61 6c 20 23 66 20 -run-key-val #f
0d40: 72 75 6e 2d 69 64 20 6b 65 79 29 29 29 0a 09 20 run-id key)))..
0d50: 20 20 6b 65 79 73 29 29 29 0a 20 20 20 20 3b 3b keys))). ;;
0d60: 20 66 72 6f 6d 20 74 68 65 20 63 61 63 68 65 64 from the cached
0d70: 20 64 61 74 61 20 73 65 74 20 74 68 65 20 76 61 data set the va
0d80: 72 73 0a 20 20 20 20 28 68 61 73 68 2d 74 61 62 rs. (hash-tab
0d90: 6c 65 2d 66 6f 72 2d 65 61 63 68 0a 20 20 20 20 le-for-each.
0da0: 20 76 61 6c 73 0a 20 20 20 20 20 28 6c 61 6d 62 vals. (lamb
0db0: 64 61 20 28 6b 65 79 20 76 61 6c 29 0a 20 20 20 da (key val).
0dc0: 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 (debug:print
0dd0: 20 32 20 22 73 65 74 65 6e 76 20 22 20 28 6b 65 2 "setenv " (ke
0de0: 79 3a 67 65 74 2d 66 69 65 6c 64 6e 61 6d 65 20 y:get-fieldname
0df0: 6b 65 79 29 20 22 20 22 20 76 61 6c 29 0a 20 20 key) " " val).
0e00: 20 20 20 20 20 28 73 65 74 65 6e 76 20 28 6b 65 (setenv (ke
0e10: 79 3a 67 65 74 2d 66 69 65 6c 64 6e 61 6d 65 20 y:get-fieldname
0e20: 6b 65 79 29 20 76 61 6c 29 29 29 0a 20 20 20 20 key) val))).
0e30: 28 61 6c 69 73 74 2d 3e 65 6e 76 2d 76 61 72 73 (alist->env-vars
0e40: 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 (hash-table-ref
0e50: 2f 64 65 66 61 75 6c 74 20 2a 63 6f 6e 66 69 67 /default *config
0e60: 64 61 74 2a 20 22 65 6e 76 2d 6f 76 65 72 72 69 dat* "env-overri
0e70: 64 65 22 20 27 28 29 29 29 0a 20 20 20 20 3b 3b de" '())). ;;
0e80: 20 4c 65 74 73 20 75 73 65 20 74 68 69 73 20 61 Lets use this a
0e90: 73 20 61 6e 20 6f 70 70 6f 72 74 75 6e 69 74 79 s an opportunity
0ea0: 20 74 6f 20 70 75 74 20 4d 54 5f 52 55 4e 4e 41 to put MT_RUNNA
0eb0: 4d 45 20 69 6e 20 74 68 65 20 65 6e 76 69 72 6f ME in the enviro
0ec0: 6e 6d 65 6e 74 0a 20 20 20 20 28 73 65 74 65 6e nment. (seten
0ed0: 76 20 22 4d 54 5f 52 55 4e 4e 41 4d 45 22 20 28 v "MT_RUNNAME" (
0ee0: 63 64 62 3a 72 65 6d 6f 74 65 2d 72 75 6e 20 64 cdb:remote-run d
0ef0: 62 3a 67 65 74 2d 72 75 6e 2d 6e 61 6d 65 2d 66 b:get-run-name-f
0f00: 72 6f 6d 2d 69 64 20 23 66 20 72 75 6e 2d 69 64 rom-id #f run-id
0f10: 29 29 0a 20 20 20 20 28 73 65 74 65 6e 76 20 22 )). (setenv "
0f20: 4d 54 5f 52 55 4e 5f 41 52 45 41 5f 48 4f 4d 45 MT_RUN_AREA_HOME
0f30: 22 20 2a 74 6f 70 70 61 74 68 2a 29 0a 20 20 20 " *toppath*).
0f40: 20 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 73 65 ))..(define (se
0f50: 74 2d 69 74 65 6d 2d 65 6e 76 2d 76 61 72 73 20 t-item-env-vars
0f60: 69 74 65 6d 64 61 74 29 0a 20 20 28 66 6f 72 2d itemdat). (for-
0f70: 65 61 63 68 20 28 6c 61 6d 62 64 61 20 28 69 74 each (lambda (it
0f80: 65 6d 29 0a 09 20 20 20 20 20 20 28 64 65 62 75 em).. (debu
0f90: 67 3a 70 72 69 6e 74 20 32 20 22 73 65 74 65 6e g:print 2 "seten
0fa0: 76 20 22 20 28 63 61 72 20 69 74 65 6d 29 20 22 v " (car item) "
0fb0: 20 22 20 28 63 61 64 72 20 69 74 65 6d 29 29 0a " (cadr item)).
0fc0: 09 20 20 20 20 20 20 28 73 65 74 65 6e 76 20 28 . (setenv (
0fd0: 63 61 72 20 69 74 65 6d 29 20 28 63 61 64 72 20 car item) (cadr
0fe0: 69 74 65 6d 29 29 29 0a 09 20 20 20 20 69 74 65 item))).. ite
0ff0: 6d 64 61 74 29 29 0a 0a 28 64 65 66 69 6e 65 20 mdat))..(define
1000: 2a 6c 61 73 74 2d 6e 75 6d 2d 72 75 6e 6e 69 6e *last-num-runnin
1010: 67 2d 74 65 73 74 73 2a 20 30 29 0a 28 64 65 66 g-tests* 0).(def
1020: 69 6e 65 20 28 72 75 6e 73 3a 63 61 6e 2d 72 75 ine (runs:can-ru
1030: 6e 2d 6d 6f 72 65 2d 74 65 73 74 73 20 74 65 73 n-more-tests tes
1040: 74 2d 72 65 63 6f 72 64 29 0a 20 20 28 6c 65 74 t-record). (let
1050: 2a 20 28 28 74 63 6f 6e 66 69 67 20 20 20 20 20 * ((tconfig
1060: 20 20 20 20 20 20 20 20 20 20 20 20 28 74 65 73 (tes
1070: 74 73 3a 74 65 73 74 71 75 65 75 65 2d 67 65 74 ts:testqueue-get
1080: 2d 74 65 73 74 63 6f 6e 66 69 67 20 74 65 73 74 -testconfig test
1090: 2d 72 65 63 6f 72 64 29 29 0a 09 20 28 6a 6f 62 -record)).. (job
10a0: 67 72 6f 75 70 20 20 20 20 20 20 20 20 20 20 20 group
10b0: 20 20 20 20 20 28 63 6f 6e 66 69 67 2d 6c 6f 6f (config-loo
10c0: 6b 75 70 20 74 63 6f 6e 66 69 67 20 22 72 65 71 kup tconfig "req
10d0: 75 69 72 65 6d 65 6e 74 73 22 20 22 6a 6f 62 67 uirements" "jobg
10e0: 72 6f 75 70 22 29 29 0a 09 20 28 6e 75 6d 2d 72 roup")).. (num-r
10f0: 75 6e 6e 69 6e 67 20 20 20 20 20 20 20 20 20 20 unning
1100: 20 20 20 28 63 64 62 3a 72 65 6d 6f 74 65 2d 72 (cdb:remote-r
1110: 75 6e 20 64 62 3a 67 65 74 2d 63 6f 75 6e 74 2d un db:get-count-
1120: 74 65 73 74 73 2d 72 75 6e 6e 69 6e 67 20 23 66 tests-running #f
1130: 29 29 0a 09 20 28 6e 75 6d 2d 72 75 6e 6e 69 6e )).. (num-runnin
1140: 67 2d 69 6e 2d 6a 6f 62 67 72 6f 75 70 20 28 63 g-in-jobgroup (c
1150: 64 62 3a 72 65 6d 6f 74 65 2d 72 75 6e 20 64 62 db:remote-run db
1160: 3a 67 65 74 2d 63 6f 75 6e 74 2d 74 65 73 74 73 :get-count-tests
1170: 2d 72 75 6e 6e 69 6e 67 2d 69 6e 2d 6a 6f 62 67 -running-in-jobg
1180: 72 6f 75 70 20 23 66 20 6a 6f 62 67 72 6f 75 70 roup #f jobgroup
1190: 29 29 0a 09 20 28 6d 61 78 2d 63 6f 6e 63 75 72 )).. (max-concur
11a0: 72 65 6e 74 2d 6a 6f 62 73 20 20 20 20 20 28 6c rent-jobs (l
11b0: 65 74 20 28 28 6d 63 6a 20 28 63 6f 6e 66 69 67 et ((mcj (config
11c0: 2d 6c 6f 6f 6b 75 70 20 2a 63 6f 6e 66 69 67 64 -lookup *configd
11d0: 61 74 2a 20 22 73 65 74 75 70 22 20 20 20 20 20 at* "setup"
11e0: 22 6d 61 78 5f 63 6f 6e 63 75 72 72 65 6e 74 5f "max_concurrent_
11f0: 6a 6f 62 73 22 29 29 29 0a 09 09 09 09 20 20 20 jobs"))).....
1200: 20 28 69 66 20 28 61 6e 64 20 6d 63 6a 20 28 73 (if (and mcj (s
1210: 74 72 69 6e 67 2d 3e 6e 75 6d 62 65 72 20 6d 63 tring->number mc
1220: 6a 29 29 0a 09 09 09 09 09 28 73 74 72 69 6e 67 j))......(string
1230: 2d 3e 6e 75 6d 62 65 72 20 6d 63 6a 29 0a 09 09 ->number mcj)...
1240: 09 09 09 23 66 29 29 29 0a 09 20 28 6a 6f 62 2d ...#f))).. (job-
1250: 67 72 6f 75 70 2d 6c 69 6d 69 74 20 20 20 20 20 group-limit
1260: 20 20 20 20 28 63 6f 6e 66 69 67 2d 6c 6f 6f 6b (config-look
1270: 75 70 20 2a 63 6f 6e 66 69 67 64 61 74 2a 20 22 up *configdat* "
1280: 6a 6f 62 67 72 6f 75 70 73 22 20 6a 6f 62 67 72 jobgroups" jobgr
1290: 6f 75 70 29 29 29 0a 20 20 20 20 28 69 66 20 28 oup))). (if (
12a0: 6e 6f 74 20 28 65 71 3f 20 2a 6c 61 73 74 2d 6e not (eq? *last-n
12b0: 75 6d 2d 72 75 6e 6e 69 6e 67 2d 74 65 73 74 73 um-running-tests
12c0: 2a 20 6e 75 6d 2d 72 75 6e 6e 69 6e 67 29 29 0a * num-running)).
12d0: 09 28 62 65 67 69 6e 0a 09 20 20 28 64 65 62 75 .(begin.. (debu
12e0: 67 3a 70 72 69 6e 74 20 32 20 22 6d 61 78 2d 63 g:print 2 "max-c
12f0: 6f 6e 63 75 72 72 65 6e 74 2d 6a 6f 62 73 3a 20 oncurrent-jobs:
1300: 22 20 6d 61 78 2d 63 6f 6e 63 75 72 72 65 6e 74 " max-concurrent
1310: 2d 6a 6f 62 73 20 22 2c 20 6e 75 6d 2d 72 75 6e -jobs ", num-run
1320: 6e 69 6e 67 3a 20 22 20 6e 75 6d 2d 72 75 6e 6e ning: " num-runn
1330: 69 6e 67 29 0a 09 20 20 28 73 65 74 21 20 2a 6c ing).. (set! *l
1340: 61 73 74 2d 6e 75 6d 2d 72 75 6e 6e 69 6e 67 2d ast-num-running-
1350: 74 65 73 74 73 2a 20 6e 75 6d 2d 72 75 6e 6e 69 tests* num-runni
1360: 6e 67 29 29 29 0a 20 20 20 20 28 69 66 20 28 6e ng))). (if (n
1370: 6f 74 20 28 65 71 3f 20 30 20 2a 67 6c 6f 62 61 ot (eq? 0 *globa
1380: 6c 65 78 69 74 73 74 61 74 75 73 2a 29 29 0a 09 lexitstatus*))..
1390: 28 6c 69 73 74 20 23 66 20 6e 75 6d 2d 72 75 6e (list #f num-run
13a0: 6e 69 6e 67 20 6e 75 6d 2d 72 75 6e 6e 69 6e 67 ning num-running
13b0: 2d 69 6e 2d 6a 6f 62 67 72 6f 75 70 20 6d 61 78 -in-jobgroup max
13c0: 2d 63 6f 6e 63 75 72 72 65 6e 74 2d 6a 6f 62 73 -concurrent-jobs
13d0: 20 6a 6f 62 2d 67 72 6f 75 70 2d 6c 69 6d 69 74 job-group-limit
13e0: 29 0a 09 28 6c 65 74 20 28 28 63 61 6e 2d 6e 6f )..(let ((can-no
13f0: 74 2d 72 75 6e 2d 6d 6f 72 65 20 28 63 6f 6e 64 t-run-more (cond
1400: 0a 09 09 09 09 20 3b 3b 20 69 66 20 6d 61 78 2d ..... ;; if max-
1410: 63 6f 6e 63 75 72 72 65 6e 74 2d 6a 6f 62 73 20 concurrent-jobs
1420: 69 73 20 73 65 74 20 61 6e 64 20 74 68 65 20 6e is set and the n
1430: 75 6d 62 65 72 20 72 75 6e 6e 69 6e 67 20 69 73 umber running is
1440: 20 67 72 65 61 74 65 72 20 0a 09 09 09 09 20 3b greater ..... ;
1450: 3b 20 74 68 61 6e 20 69 74 20 74 68 61 6e 20 63 ; than it than c
1460: 61 6e 6e 6f 74 20 72 75 6e 20 6d 6f 72 65 20 6a annot run more j
1470: 6f 62 73 0a 09 09 09 09 20 28 28 61 6e 64 20 6d obs..... ((and m
1480: 61 78 2d 63 6f 6e 63 75 72 72 65 6e 74 2d 6a 6f ax-concurrent-jo
1490: 62 73 20 28 3e 3d 20 6e 75 6d 2d 72 75 6e 6e 69 bs (>= num-runni
14a0: 6e 67 20 6d 61 78 2d 63 6f 6e 63 75 72 72 65 6e ng max-concurren
14b0: 74 2d 6a 6f 62 73 29 29 0a 09 09 09 09 20 20 28 t-jobs))..... (
14c0: 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 22 57 debug:print 0 "W
14d0: 41 52 4e 49 4e 47 3a 20 4d 61 78 20 72 75 6e 6e ARNING: Max runn
14e0: 69 6e 67 20 6a 6f 62 73 20 65 78 63 65 65 64 65 ing jobs exceede
14f0: 64 2c 20 63 75 72 72 65 6e 74 20 6e 75 6d 62 65 d, current numbe
1500: 72 20 72 75 6e 6e 69 6e 67 3a 20 22 20 6e 75 6d r running: " num
1510: 2d 72 75 6e 6e 69 6e 67 20 0a 09 09 09 09 09 20 -running ......
1520: 20 20 20 20 20 20 22 2c 20 6d 61 78 5f 63 6f 6e ", max_con
1530: 63 75 72 72 65 6e 74 5f 6a 6f 62 73 3a 20 22 20 current_jobs: "
1540: 6d 61 78 2d 63 6f 6e 63 75 72 72 65 6e 74 2d 6a max-concurrent-j
1550: 6f 62 73 29 0a 09 09 09 09 20 20 23 74 29 0a 09 obs)..... #t)..
1560: 09 09 09 20 3b 3b 20 69 66 20 6a 6f 62 2d 67 72 ... ;; if job-gr
1570: 6f 75 70 2d 6c 69 6d 69 74 20 69 73 20 73 65 74 oup-limit is set
1580: 20 61 6e 64 20 6e 75 6d 62 65 72 20 6f 66 20 6a and number of j
1590: 6f 62 73 20 69 6e 20 74 68 65 20 67 72 6f 75 70 obs in the group
15a0: 20 69 73 20 67 72 65 61 74 65 72 0a 09 09 09 09 is greater.....
15b0: 20 3b 3b 20 74 68 61 6e 20 74 68 65 20 6c 69 6d ;; than the lim
15c0: 69 74 20 74 68 65 6e 20 63 61 6e 6e 6f 74 20 72 it then cannot r
15d0: 75 6e 20 6d 6f 72 65 20 6a 6f 62 73 20 6f 66 20 un more jobs of
15e0: 74 68 69 73 20 6b 69 6e 64 0a 09 09 09 09 20 28 this kind..... (
15f0: 28 61 6e 64 20 6a 6f 62 2d 67 72 6f 75 70 2d 6c (and job-group-l
1600: 69 6d 69 74 0a 09 09 09 09 20 20 20 20 20 20 20 imit.....
1610: 28 3e 3d 20 6e 75 6d 2d 72 75 6e 6e 69 6e 67 2d (>= num-running-
1620: 69 6e 2d 6a 6f 62 67 72 6f 75 70 20 6a 6f 62 2d in-jobgroup job-
1630: 67 72 6f 75 70 2d 6c 69 6d 69 74 29 29 0a 09 09 group-limit))...
1640: 09 09 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 .. (debug:print
1650: 20 31 20 22 57 41 52 4e 49 4e 47 3a 20 6e 75 6d 1 "WARNING: num
1660: 62 65 72 20 6f 66 20 6a 6f 62 73 20 22 20 6e 75 ber of jobs " nu
1670: 6d 2d 72 75 6e 6e 69 6e 67 2d 69 6e 2d 6a 6f 62 m-running-in-job
1680: 67 72 6f 75 70 20 0a 09 09 09 09 09 20 20 20 20 group ......
1690: 20 20 20 22 20 69 6e 20 22 20 6a 6f 62 67 72 6f " in " jobgro
16a0: 75 70 20 22 20 65 78 63 65 65 64 65 64 2c 20 77 up " exceeded, w
16b0: 69 6c 6c 20 6e 6f 74 20 72 75 6e 20 22 20 28 74 ill not run " (t
16c0: 65 73 74 73 3a 74 65 73 74 71 75 65 75 65 2d 67 ests:testqueue-g
16d0: 65 74 2d 74 65 73 74 6e 61 6d 65 20 74 65 73 74 et-testname test
16e0: 2d 72 65 63 6f 72 64 29 29 0a 09 09 09 09 20 20 -record)).....
16f0: 23 74 29 0a 09 09 09 09 20 28 65 6c 73 65 20 23 #t)..... (else #
1700: 66 29 29 29 29 0a 09 20 20 28 6c 69 73 74 20 28 f)))).. (list (
1710: 6e 6f 74 20 63 61 6e 2d 6e 6f 74 2d 72 75 6e 2d not can-not-run-
1720: 6d 6f 72 65 29 20 6e 75 6d 2d 72 75 6e 6e 69 6e more) num-runnin
1730: 67 20 6e 75 6d 2d 72 75 6e 6e 69 6e 67 2d 69 6e g num-running-in
1740: 2d 6a 6f 62 67 72 6f 75 70 20 6d 61 78 2d 63 6f -jobgroup max-co
1750: 6e 63 75 72 72 65 6e 74 2d 6a 6f 62 73 20 6a 6f ncurrent-jobs jo
1760: 62 2d 67 72 6f 75 70 2d 6c 69 6d 69 74 29 29 29 b-group-limit)))
1770: 29 29 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ))..;;==========
1780: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1790: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
17a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
17b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 ============.;;
17c0: 4e 65 77 20 6d 65 74 68 6f 64 6f 6c 6f 67 79 2e New methodology.
17d0: 20 54 68 65 73 65 20 72 6f 75 74 69 6e 65 73 20 These routines
17e0: 77 69 6c 6c 20 72 65 70 6c 61 63 65 20 74 68 65 will replace the
17f0: 20 61 62 6f 76 65 20 69 6e 20 74 69 6d 65 2e 20 above in time.
1800: 46 6f 72 0a 3b 3b 20 6e 6f 77 20 74 68 65 20 63 For.;; now the c
1810: 6f 64 65 20 69 73 20 64 75 70 6c 69 63 61 74 65 ode is duplicate
1820: 64 2e 20 54 68 69 73 20 73 74 75 66 66 20 69 73 d. This stuff is
1830: 20 69 6e 69 74 69 61 6c 6c 79 20 75 73 65 64 20 initially used
1840: 69 6e 20 74 68 65 20 6d 6f 6e 69 74 6f 72 0a 3b in the monitor.;
1850: 3b 20 62 61 73 65 64 20 63 6f 64 65 2e 0a 3b 3b ; based code..;;
1860: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1870: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1880: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1890: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
18a0: 3d 3d 3d 3d 3d 3d 0a 0a 3b 3b 20 72 65 67 69 73 ======..;; regis
18b0: 74 65 72 20 61 20 74 65 73 74 20 72 75 6e 20 77 ter a test run w
18c0: 69 74 68 20 74 68 65 20 64 62 0a 28 64 65 66 69 ith the db.(defi
18d0: 6e 65 20 28 72 75 6e 73 3a 72 65 67 69 73 74 65 ne (runs:registe
18e0: 72 2d 72 75 6e 20 64 62 20 6b 65 79 73 20 6b 65 r-run db keys ke
18f0: 79 76 61 6c 6c 73 74 20 72 75 6e 6e 61 6d 65 20 yvallst runname
1900: 73 74 61 74 65 20 73 74 61 74 75 73 20 75 73 65 state status use
1910: 72 29 0a 20 20 28 64 65 62 75 67 3a 70 72 69 6e r). (debug:prin
1920: 74 20 33 20 22 72 75 6e 73 3a 72 65 67 69 73 74 t 3 "runs:regist
1930: 65 72 2d 72 75 6e 2c 20 6b 65 79 73 3a 20 22 20 er-run, keys: "
1940: 6b 65 79 73 20 22 20 6b 65 79 76 61 6c 6c 73 74 keys " keyvallst
1950: 3a 20 22 20 6b 65 79 76 61 6c 6c 73 74 20 22 20 : " keyvallst "
1960: 72 75 6e 6e 61 6d 65 3a 20 22 20 72 75 6e 6e 61 runname: " runna
1970: 6d 65 20 22 20 73 74 61 74 65 3a 20 22 20 73 74 me " state: " st
1980: 61 74 65 20 22 20 73 74 61 74 75 73 3a 20 22 20 ate " status: "
1990: 73 74 61 74 75 73 20 22 20 75 73 65 72 3a 20 22 status " user: "
19a0: 20 75 73 65 72 29 0a 20 20 28 6c 65 74 2a 20 28 user). (let* (
19b0: 28 6b 65 79 73 74 72 20 20 20 20 28 6b 65 79 73 (keystr (keys
19c0: 2d 3e 6b 65 79 73 74 72 20 6b 65 79 73 29 29 0a ->keystr keys)).
19d0: 09 20 28 63 6f 6d 6d 61 20 20 20 20 20 28 69 66 . (comma (if
19e0: 20 28 3e 20 28 6c 65 6e 67 74 68 20 6b 65 79 73 (> (length keys
19f0: 29 20 30 29 20 22 2c 22 20 22 22 29 29 0a 09 20 ) 0) "," ""))..
1a00: 28 61 6e 64 73 74 72 20 20 20 20 28 69 66 20 28 (andstr (if (
1a10: 3e 20 28 6c 65 6e 67 74 68 20 6b 65 79 73 29 20 > (length keys)
1a20: 30 29 20 22 20 41 4e 44 20 22 20 22 22 29 29 0a 0) " AND " "")).
1a30: 09 20 28 76 61 6c 73 6c 6f 74 73 20 20 28 6b 65 . (valslots (ke
1a40: 79 73 2d 3e 76 61 6c 73 6c 6f 74 73 20 6b 65 79 ys->valslots key
1a50: 73 29 29 20 3b 3b 20 3f 2c 3f 2c 3f 20 2e 2e 2e s)) ;; ?,?,? ...
1a60: 0a 09 20 28 6b 65 79 76 61 6c 73 20 20 20 28 6d .. (keyvals (m
1a70: 61 70 20 63 61 64 72 20 6b 65 79 76 61 6c 6c 73 ap cadr keyvalls
1a80: 74 29 29 0a 09 20 28 61 6c 6c 76 61 6c 73 20 20 t)).. (allvals
1a90: 20 28 61 70 70 65 6e 64 20 28 6c 69 73 74 20 72 (append (list r
1aa0: 75 6e 6e 61 6d 65 20 73 74 61 74 65 20 73 74 61 unname state sta
1ab0: 74 75 73 20 75 73 65 72 29 20 6b 65 79 76 61 6c tus user) keyval
1ac0: 73 29 29 0a 09 20 28 71 72 79 76 61 6c 73 20 20 s)).. (qryvals
1ad0: 20 28 61 70 70 65 6e 64 20 28 6c 69 73 74 20 72 (append (list r
1ae0: 75 6e 6e 61 6d 65 29 20 6b 65 79 76 61 6c 73 29 unname) keyvals)
1af0: 29 0a 09 20 28 6b 65 79 3d 3f 73 74 72 20 20 28 ).. (key=?str (
1b00: 73 74 72 69 6e 67 2d 69 6e 74 65 72 73 70 65 72 string-intersper
1b10: 73 65 20 28 6d 61 70 20 28 6c 61 6d 62 64 61 20 se (map (lambda
1b20: 28 6b 29 28 63 6f 6e 63 20 28 6b 65 79 3a 67 65 (k)(conc (key:ge
1b30: 74 2d 66 69 65 6c 64 6e 61 6d 65 20 6b 29 20 22 t-fieldname k) "
1b40: 3d 3f 22 29 29 20 6b 65 79 73 29 20 22 20 41 4e =?")) keys) " AN
1b50: 44 20 22 29 29 29 0a 20 20 20 20 28 64 65 62 75 D "))). (debu
1b60: 67 3a 70 72 69 6e 74 20 33 20 22 6b 65 79 73 3a g:print 3 "keys:
1b70: 20 22 20 6b 65 79 73 20 22 20 61 6c 6c 76 61 6c " keys " allval
1b80: 73 3a 20 22 20 61 6c 6c 76 61 6c 73 20 22 20 6b s: " allvals " k
1b90: 65 79 76 61 6c 73 3a 20 22 20 6b 65 79 76 61 6c eyvals: " keyval
1ba0: 73 29 0a 20 20 20 20 28 64 65 62 75 67 3a 70 72 s). (debug:pr
1bb0: 69 6e 74 20 32 20 22 4e 4f 54 45 3a 20 75 73 69 int 2 "NOTE: usi
1bc0: 6e 67 20 74 61 72 67 65 74 20 22 20 28 73 74 72 ng target " (str
1bd0: 69 6e 67 2d 69 6e 74 65 72 73 70 65 72 73 65 20 ing-intersperse
1be0: 6b 65 79 76 61 6c 73 20 22 2f 22 29 20 22 20 66 keyvals "/") " f
1bf0: 6f 72 20 74 68 69 73 20 72 75 6e 22 29 0a 20 20 or this run").
1c00: 20 20 28 69 66 20 28 61 6e 64 20 72 75 6e 6e 61 (if (and runna
1c10: 6d 65 20 28 6e 75 6c 6c 3f 20 28 66 69 6c 74 65 me (null? (filte
1c20: 72 20 28 6c 61 6d 62 64 61 20 28 78 29 28 6e 6f r (lambda (x)(no
1c30: 74 20 78 29 29 20 6b 65 79 76 61 6c 73 29 29 29 t x)) keyvals)))
1c40: 20 3b 3b 20 74 68 65 72 65 20 6d 75 73 74 20 62 ;; there must b
1c50: 65 20 61 20 62 65 74 74 65 72 20 77 61 79 20 74 e a better way t
1c60: 6f 20 22 61 70 70 6c 79 20 61 6e 64 22 0a 09 28 o "apply and"..(
1c70: 6c 65 74 20 28 28 72 65 73 20 23 66 29 29 0a 09 let ((res #f))..
1c80: 20 20 28 61 70 70 6c 79 20 73 71 6c 69 74 65 33 (apply sqlite3
1c90: 3a 65 78 65 63 75 74 65 20 64 62 20 28 63 6f 6e :execute db (con
1ca0: 63 20 22 49 4e 53 45 52 54 20 4f 52 20 49 47 4e c "INSERT OR IGN
1cb0: 4f 52 45 20 49 4e 54 4f 20 72 75 6e 73 20 28 72 ORE INTO runs (r
1cc0: 75 6e 6e 61 6d 65 2c 73 74 61 74 65 2c 73 74 61 unname,state,sta
1cd0: 74 75 73 2c 6f 77 6e 65 72 2c 65 76 65 6e 74 5f tus,owner,event_
1ce0: 74 69 6d 65 22 20 63 6f 6d 6d 61 20 6b 65 79 73 time" comma keys
1cf0: 74 72 20 22 29 20 56 41 4c 55 45 53 20 28 3f 2c tr ") VALUES (?,
1d00: 3f 2c 3f 2c 3f 2c 73 74 72 66 74 69 6d 65 28 27 ?,?,?,strftime('
1d10: 25 73 27 2c 27 6e 6f 77 27 29 22 20 63 6f 6d 6d %s','now')" comm
1d20: 61 20 76 61 6c 73 6c 6f 74 73 20 22 29 3b 22 29 a valslots ");")
1d30: 0a 09 09 20 61 6c 6c 76 61 6c 73 29 0a 09 20 20 ... allvals)..
1d40: 28 61 70 70 6c 79 20 73 71 6c 69 74 65 33 3a 66 (apply sqlite3:f
1d50: 6f 72 2d 65 61 63 68 2d 72 6f 77 20 0a 09 20 20 or-each-row ..
1d60: 20 28 6c 61 6d 62 64 61 20 28 69 64 29 0a 09 20 (lambda (id)..
1d70: 20 20 20 20 28 73 65 74 21 20 72 65 73 20 69 64 (set! res id
1d80: 29 29 0a 09 20 20 20 64 62 0a 09 20 20 20 28 6c )).. db.. (l
1d90: 65 74 20 28 28 71 72 79 20 28 63 6f 6e 63 20 22 et ((qry (conc "
1da0: 53 45 4c 45 43 54 20 69 64 20 46 52 4f 4d 20 72 SELECT id FROM r
1db0: 75 6e 73 20 57 48 45 52 45 20 28 72 75 6e 6e 61 uns WHERE (runna
1dc0: 6d 65 3d 3f 20 22 20 61 6e 64 73 74 72 20 6b 65 me=? " andstr ke
1dd0: 79 3d 3f 73 74 72 20 22 29 3b 22 29 29 29 0a 09 y=?str ");")))..
1de0: 20 20 20 20 20 3b 28 64 65 62 75 67 3a 70 72 69 ;(debug:pri
1df0: 6e 74 20 34 20 22 71 72 79 3a 20 22 20 71 72 79 nt 4 "qry: " qry
1e00: 29 20 0a 09 20 20 20 20 20 71 72 79 29 0a 09 20 ) .. qry)..
1e10: 20 20 71 72 79 76 61 6c 73 29 0a 09 20 20 28 73 qryvals).. (s
1e20: 71 6c 69 74 65 33 3a 65 78 65 63 75 74 65 20 64 qlite3:execute d
1e30: 62 20 22 55 50 44 41 54 45 20 72 75 6e 73 20 53 b "UPDATE runs S
1e40: 45 54 20 73 74 61 74 65 3d 3f 2c 73 74 61 74 75 ET state=?,statu
1e50: 73 3d 3f 20 57 48 45 52 45 20 69 64 3d 3f 3b 22 s=? WHERE id=?;"
1e60: 20 73 74 61 74 65 20 73 74 61 74 75 73 20 72 65 state status re
1e70: 73 29 0a 09 20 20 72 65 73 29 20 0a 09 28 62 65 s).. res) ..(be
1e80: 67 69 6e 0a 09 20 20 28 64 65 62 75 67 3a 70 72 gin.. (debug:pr
1e90: 69 6e 74 20 30 20 22 45 52 52 4f 52 3a 20 43 61 int 0 "ERROR: Ca
1ea0: 6c 6c 65 64 20 77 69 74 68 6f 75 74 20 61 6c 6c lled without all
1eb0: 20 6e 65 63 65 73 73 61 72 79 20 6b 65 79 73 22 necessary keys"
1ec0: 29 0a 09 20 20 23 66 29 29 29 29 0a 0a 3b 3b 20 ).. #f))))..;;
1ed0: 54 68 69 73 20 69 73 20 61 20 64 75 70 6c 69 63 This is a duplic
1ee0: 61 74 65 20 6f 66 20 72 75 6e 2d 74 65 73 74 73 ate of run-tests
1ef0: 20 28 77 68 69 63 68 20 68 61 73 20 62 65 65 6e (which has been
1f00: 20 64 65 70 72 65 63 61 74 65 64 29 2e 20 55 73 deprecated). Us
1f10: 65 20 74 68 69 73 20 6f 6e 65 20 69 6e 73 74 65 e this one inste
1f20: 61 64 20 6f 66 20 72 75 6e 20 74 65 73 74 73 2e ad of run tests.
1f30: 0a 3b 3b 20 6b 65 79 76 61 6c 73 0a 28 64 65 66 .;; keyvals.(def
1f40: 69 6e 65 20 28 72 75 6e 73 3a 72 75 6e 2d 74 65 ine (runs:run-te
1f50: 73 74 73 20 74 61 72 67 65 74 20 72 75 6e 6e 61 sts target runna
1f60: 6d 65 20 74 65 73 74 2d 70 61 74 74 73 20 75 73 me test-patts us
1f70: 65 72 20 66 6c 61 67 73 29 0a 20 20 28 6c 65 74 er flags). (let
1f80: 2a 20 28 28 64 62 20 20 20 20 20 20 20 20 20 20 * ((db
1f90: 23 66 29 0a 09 20 28 6b 65 79 73 20 20 20 20 20 #f).. (keys
1fa0: 20 20 20 28 63 64 62 3a 72 65 6d 6f 74 65 2d 72 (cdb:remote-r
1fb0: 75 6e 20 64 62 3a 67 65 74 2d 6b 65 79 73 20 23 un db:get-keys #
1fc0: 66 29 29 0a 09 20 28 6b 65 79 76 61 6c 6c 73 74 f)).. (keyvallst
1fd0: 20 20 20 28 6b 65 79 73 3a 74 61 72 67 65 74 2d (keys:target-
1fe0: 3e 6b 65 79 76 61 6c 20 6b 65 79 73 20 74 61 72 >keyval keys tar
1ff0: 67 65 74 29 29 0a 09 20 28 72 75 6e 2d 69 64 20 get)).. (run-id
2000: 20 20 20 20 20 28 63 64 62 3a 72 65 6d 6f 74 65 (cdb:remote
2010: 2d 72 75 6e 20 72 75 6e 73 3a 72 65 67 69 73 74 -run runs:regist
2020: 65 72 2d 72 75 6e 20 23 66 20 6b 65 79 73 20 6b er-run #f keys k
2030: 65 79 76 61 6c 6c 73 74 20 72 75 6e 6e 61 6d 65 eyvallst runname
2040: 20 22 6e 65 77 22 20 22 6e 2f 61 22 20 75 73 65 "new" "n/a" use
2050: 72 29 29 20 20 3b 3b 20 20 74 65 73 74 2d 6e 61 r)) ;; test-na
2060: 6d 65 29 29 29 0a 09 20 28 64 65 66 65 72 72 65 me))).. (deferre
2070: 64 20 20 20 20 27 28 29 29 20 3b 3b 20 64 65 6c d '()) ;; del
2080: 61 79 20 72 75 6e 6e 69 6e 67 20 74 68 65 73 65 ay running these
2090: 20 73 69 6e 63 65 20 74 68 65 79 20 68 61 76 65 since they have
20a0: 20 61 20 77 61 69 74 6f 6e 20 63 6c 61 75 73 65 a waiton clause
20b0: 0a 09 20 3b 3b 20 6b 65 65 70 67 6f 69 6e 67 20 .. ;; keepgoing
20c0: 69 73 20 74 68 65 20 64 65 66 61 63 74 6f 20 6d is the defacto m
20d0: 6f 64 61 6c 69 74 79 20 6e 6f 77 2c 20 77 69 6c odality now, wil
20e0: 6c 20 61 64 64 20 68 69 74 2d 6e 2d 72 75 6e 20 l add hit-n-run
20f0: 61 20 62 69 74 20 6c 61 74 65 72 0a 09 20 3b 3b a bit later.. ;;
2100: 20 28 6b 65 65 70 67 6f 69 6e 67 20 20 20 28 68 (keepgoing (h
2110: 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 ash-table-ref/de
2120: 66 61 75 6c 74 20 66 6c 61 67 73 20 22 2d 6b 65 fault flags "-ke
2130: 65 70 67 6f 69 6e 67 22 20 23 66 29 29 0a 09 20 epgoing" #f))..
2140: 28 74 65 73 74 2d 6e 61 6d 65 73 20 20 27 28 29 (test-names '()
2150: 29 0a 09 20 28 72 75 6e 63 6f 6e 66 69 67 66 20 ).. (runconfigf
2160: 20 20 28 63 6f 6e 63 20 20 2a 74 6f 70 70 61 74 (conc *toppat
2170: 68 2a 20 22 2f 72 75 6e 63 6f 6e 66 69 67 73 2e h* "/runconfigs.
2180: 63 6f 6e 66 69 67 22 29 29 0a 09 20 28 72 65 71 config")).. (req
2190: 75 69 72 65 64 2d 74 65 73 74 73 20 27 28 29 29 uired-tests '())
21a0: 0a 09 20 28 74 65 73 74 2d 72 65 63 6f 72 64 73 .. (test-records
21b0: 20 28 6d 61 6b 65 2d 68 61 73 68 2d 74 61 62 6c (make-hash-tabl
21c0: 65 29 29 29 0a 0a 20 20 20 20 28 73 65 74 2d 6d e))).. (set-m
21d0: 65 67 61 74 65 73 74 2d 65 6e 76 2d 76 61 72 73 egatest-env-vars
21e0: 20 72 75 6e 2d 69 64 29 20 3b 3b 20 74 68 65 73 run-id) ;; thes
21f0: 65 20 6d 61 79 20 62 65 20 6e 65 65 64 65 64 20 e may be needed
2200: 62 79 20 74 68 65 20 6c 61 75 6e 63 68 69 6e 67 by the launching
2210: 20 70 72 6f 63 65 73 73 0a 0a 20 20 20 20 28 69 process.. (i
2220: 66 20 28 66 69 6c 65 2d 65 78 69 73 74 73 3f 20 f (file-exists?
2230: 72 75 6e 63 6f 6e 66 69 67 66 29 0a 09 28 6f 70 runconfigf)..(op
2240: 65 6e 2d 72 75 6e 2d 63 6c 6f 73 65 20 73 65 74 en-run-close set
2250: 75 70 2d 65 6e 76 2d 64 65 66 61 75 6c 74 73 20 up-env-defaults
2260: 64 62 20 72 75 6e 63 6f 6e 66 69 67 66 20 72 75 db runconfigf ru
2270: 6e 2d 69 64 20 2a 61 6c 72 65 61 64 79 2d 73 65 n-id *already-se
2280: 65 6e 2d 72 75 6e 63 6f 6e 66 69 67 2d 69 6e 66 en-runconfig-inf
2290: 6f 2a 20 22 70 72 65 2d 6c 61 75 6e 63 68 2d 65 o* "pre-launch-e
22a0: 6e 76 2d 76 61 72 73 22 29 0a 09 28 64 65 62 75 nv-vars")..(debu
22b0: 67 3a 70 72 69 6e 74 20 30 20 22 57 41 52 4e 49 g:print 0 "WARNI
22c0: 4e 47 3a 20 59 6f 75 20 64 6f 20 6e 6f 74 20 68 NG: You do not h
22d0: 61 76 65 20 61 20 72 75 6e 20 63 6f 6e 66 69 67 ave a run config
22e0: 20 66 69 6c 65 3a 20 22 20 72 75 6e 63 6f 6e 66 file: " runconf
22f0: 69 67 66 29 29 0a 20 20 20 20 0a 20 20 20 20 3b igf)). . ;
2300: 3b 20 6c 6f 6f 6b 20 75 70 20 61 6c 6c 20 74 65 ; look up all te
2310: 73 74 73 20 6d 61 74 63 68 69 6e 67 20 74 68 65 sts matching the
2320: 20 63 6f 6d 6d 61 20 73 65 70 61 72 61 74 65 64 comma separated
2330: 20 6c 69 73 74 20 6f 66 20 67 6c 6f 62 73 20 69 list of globs i
2340: 6e 0a 20 20 20 20 3b 3b 20 74 65 73 74 2d 70 61 n. ;; test-pa
2350: 74 74 73 20 28 75 73 69 6e 67 20 25 20 61 73 20 tts (using % as
2360: 77 69 6c 64 63 61 72 64 29 0a 0a 20 20 20 20 28 wildcard).. (
2370: 73 65 74 21 20 74 65 73 74 2d 6e 61 6d 65 73 20 set! test-names
2380: 28 74 65 73 74 73 3a 67 65 74 2d 76 61 6c 69 64 (tests:get-valid
2390: 2d 74 65 73 74 73 20 2a 74 6f 70 70 61 74 68 2a -tests *toppath*
23a0: 20 74 65 73 74 2d 70 61 74 74 73 20 74 65 73 74 test-patts test
23b0: 2d 6e 61 6d 65 73 3a 20 74 65 73 74 2d 6e 61 6d -names: test-nam
23c0: 65 73 29 29 0a 20 20 20 20 28 73 65 74 21 20 74 es)). (set! t
23d0: 65 73 74 2d 6e 61 6d 65 73 20 28 64 65 6c 65 74 est-names (delet
23e0: 65 2d 64 75 70 6c 69 63 61 74 65 73 20 74 65 73 e-duplicates tes
23f0: 74 2d 6e 61 6d 65 73 29 29 0a 0a 20 20 20 20 28 t-names)).. (
2400: 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f debug:print-info
2410: 20 30 20 22 74 65 73 74 20 6e 61 6d 65 73 20 22 0 "test names "
2420: 20 74 65 73 74 2d 6e 61 6d 65 73 29 0a 0a 20 20 test-names)..
2430: 20 20 3b 3b 20 6f 6e 20 74 68 65 20 66 69 72 73 ;; on the firs
2440: 74 20 70 61 73 73 20 6f 72 20 63 61 6c 6c 20 74 t pass or call t
2450: 6f 20 72 75 6e 2d 74 65 73 74 73 20 73 65 74 20 o run-tests set
2460: 46 41 49 4c 53 20 74 6f 20 4e 4f 54 5f 53 54 41 FAILS to NOT_STA
2470: 52 54 45 44 20 69 66 0a 20 20 20 20 3b 3b 20 2d RTED if. ;; -
2480: 6b 65 65 70 67 6f 69 6e 67 20 69 73 20 73 70 65 keepgoing is spe
2490: 63 69 66 69 65 64 0a 20 20 20 20 28 69 66 20 28 cified. (if (
24a0: 65 71 3f 20 2a 70 61 73 73 6e 75 6d 2a 20 30 29 eq? *passnum* 0)
24b0: 0a 09 28 62 65 67 69 6e 0a 09 20 20 3b 3b 20 68 ..(begin.. ;; h
24c0: 61 76 65 20 74 6f 20 64 65 6c 65 74 65 20 74 65 ave to delete te
24d0: 73 74 20 72 65 63 6f 72 64 73 20 77 68 65 72 65 st records where
24e0: 20 4e 4f 54 5f 53 54 41 52 54 45 44 20 73 69 6e NOT_STARTED sin
24f0: 63 65 20 74 68 65 79 20 63 61 6e 20 63 61 75 73 ce they can caus
2500: 65 20 2d 6b 65 65 70 67 6f 69 6e 67 20 74 6f 20 e -keepgoing to
2510: 0a 09 20 20 3b 3b 20 67 65 74 20 73 74 75 63 6b .. ;; get stuck
2520: 20 64 75 65 20 74 6f 20 62 65 63 6f 6d 69 6e 67 due to becoming
2530: 20 69 6e 61 63 63 65 73 73 69 62 6c 65 20 66 72 inaccessible fr
2540: 6f 6d 20 61 20 66 61 69 6c 65 64 20 74 65 73 74 om a failed test
2550: 2e 20 49 2e 65 2e 20 69 66 20 74 65 73 74 20 42 . I.e. if test B
2560: 20 64 65 70 65 6e 64 73 20 0a 09 20 20 3b 3b 20 depends .. ;;
2570: 6f 6e 20 74 65 73 74 20 41 20 62 75 74 20 74 65 on test A but te
2580: 73 74 20 42 20 72 65 61 63 68 65 64 20 74 68 65 st B reached the
2590: 20 70 6f 69 6e 74 20 6f 6e 20 62 65 69 6e 67 20 point on being
25a0: 72 65 67 69 73 74 65 72 65 64 20 61 73 20 4e 4f registered as NO
25b0: 54 5f 53 54 41 52 54 45 44 20 61 6e 64 20 74 65 T_STARTED and te
25c0: 73 74 0a 09 20 20 3b 3b 20 41 20 66 61 69 6c 65 st.. ;; A faile
25d0: 64 20 66 6f 72 20 73 6f 6d 65 20 72 65 61 73 6f d for some reaso
25e0: 6e 20 74 68 65 6e 20 6f 6e 20 72 65 2d 72 75 6e n then on re-run
25f0: 20 75 73 69 6e 67 20 2d 6b 65 65 70 67 6f 69 6e using -keepgoin
2600: 67 20 74 68 65 20 72 75 6e 20 63 61 6e 20 6e 65 g the run can ne
2610: 76 65 72 20 63 6f 6d 70 6c 65 74 65 2e 0a 09 20 ver complete...
2620: 20 28 63 64 62 3a 64 65 6c 65 74 65 2d 74 65 73 (cdb:delete-tes
2630: 74 73 2d 69 6e 2d 73 74 61 74 65 20 2a 72 75 6e ts-in-state *run
2640: 72 65 6d 6f 74 65 2a 20 72 75 6e 2d 69 64 20 22 remote* run-id "
2650: 4e 4f 54 5f 53 54 41 52 54 45 44 22 29 0a 09 20 NOT_STARTED")..
2660: 20 28 63 64 62 3a 72 65 6d 6f 74 65 2d 72 75 6e (cdb:remote-run
2670: 20 64 62 3a 73 65 74 2d 74 65 73 74 73 2d 73 74 db:set-tests-st
2680: 61 74 65 2d 73 74 61 74 75 73 20 23 66 20 72 75 ate-status #f ru
2690: 6e 2d 69 64 20 74 65 73 74 2d 6e 61 6d 65 73 20 n-id test-names
26a0: 23 66 20 22 46 41 49 4c 22 20 22 4e 4f 54 5f 53 #f "FAIL" "NOT_S
26b0: 54 41 52 54 45 44 22 20 22 46 41 49 4c 22 29 29 TARTED" "FAIL"))
26c0: 29 0a 0a 20 20 20 20 3b 3b 20 66 72 6f 6d 20 68 ).. ;; from h
26d0: 65 72 65 20 6f 6e 20 6f 75 74 20 74 68 65 20 64 ere on out the d
26e0: 62 20 77 69 6c 6c 20 62 65 20 6f 70 65 6e 65 64 b will be opened
26f0: 20 61 6e 64 20 63 6c 6f 73 65 64 20 6f 6e 20 65 and closed on e
2700: 76 65 72 79 20 63 61 6c 6c 20 72 75 6e 73 3a 72 very call runs:r
2710: 75 6e 2d 74 65 73 74 73 2d 71 75 65 75 65 0a 20 un-tests-queue.
2720: 20 20 20 3b 3b 20 28 73 71 6c 69 74 65 33 3a 66 ;; (sqlite3:f
2730: 69 6e 61 6c 69 7a 65 21 20 64 62 29 20 0a 20 20 inalize! db) .
2740: 20 20 3b 3b 20 6e 6f 77 20 61 64 64 20 6e 6f 6e ;; now add non
2750: 2d 64 69 72 65 63 74 6c 79 20 72 65 66 65 72 65 -directly refere
2760: 6e 63 65 64 20 64 65 70 65 6e 64 65 6e 63 69 65 nced dependencie
2770: 73 20 28 69 2e 65 2e 20 77 61 69 74 6f 6e 29 0a s (i.e. waiton).
2780: 20 20 20 20 28 69 66 20 28 6e 6f 74 20 28 6e 75 (if (not (nu
2790: 6c 6c 3f 20 74 65 73 74 2d 6e 61 6d 65 73 29 29 ll? test-names))
27a0: 0a 09 28 6c 65 74 20 6c 6f 6f 70 20 28 28 68 65 ..(let loop ((he
27b0: 64 20 28 63 61 72 20 74 65 73 74 2d 6e 61 6d 65 d (car test-name
27c0: 73 29 29 0a 09 09 20 20 20 28 74 61 6c 20 28 63 s))... (tal (c
27d0: 64 72 20 74 65 73 74 2d 6e 61 6d 65 73 29 29 29 dr test-names)))
27e0: 20 20 20 20 20 20 20 20 20 3b 3b 20 27 72 65 74 ;; 'ret
27f0: 75 72 6e 2d 70 72 6f 63 73 20 74 65 6c 6c 73 20 urn-procs tells
2800: 74 68 65 20 63 6f 6e 66 69 67 20 72 65 61 64 65 the config reade
2810: 72 20 74 6f 20 70 72 65 70 20 72 75 6e 6e 69 6e r to prep runnin
2820: 67 20 73 79 73 74 65 6d 20 62 75 74 20 72 65 74 g system but ret
2830: 75 72 6e 20 61 20 70 72 6f 63 0a 09 20 20 28 64 urn a proc.. (d
2840: 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 ebug:print-info
2850: 34 20 22 68 65 64 3d 22 20 68 65 64 20 22 20 61 4 "hed=" hed " a
2860: 74 20 74 6f 70 20 6f 66 20 6c 6f 6f 70 22 29 0a t top of loop").
2870: 09 20 20 28 6c 65 74 2a 20 28 28 63 6f 6e 66 69 . (let* ((confi
2880: 67 20 20 28 74 65 73 74 73 3a 67 65 74 2d 74 65 g (tests:get-te
2890: 73 74 63 6f 6e 66 69 67 20 68 65 64 20 27 72 65 stconfig hed 're
28a0: 74 75 72 6e 2d 70 72 6f 63 73 29 29 0a 09 09 20 turn-procs))...
28b0: 28 77 61 69 74 6f 6e 73 20 28 69 66 20 63 6f 6e (waitons (if con
28c0: 66 69 67 20 28 73 74 72 69 6e 67 2d 73 70 6c 69 fig (string-spli
28d0: 74 20 28 6c 65 74 20 28 28 77 20 28 63 6f 6e 66 t (let ((w (conf
28e0: 69 67 2d 6c 6f 6f 6b 75 70 20 63 6f 6e 66 69 67 ig-lookup config
28f0: 20 22 72 65 71 75 69 72 65 6d 65 6e 74 73 22 20 "requirements"
2900: 22 77 61 69 74 6f 6e 22 29 29 29 0a 09 09 09 09 "waiton"))).....
2910: 09 09 20 20 20 20 20 28 69 66 20 77 20 77 20 22 .. (if w w "
2920: 22 29 29 29 0a 09 09 09 20 20 20 20 20 20 28 62 "))).... (b
2930: 65 67 69 6e 0a 09 09 09 09 28 64 65 62 75 67 3a egin.....(debug:
2940: 70 72 69 6e 74 20 30 20 22 45 52 52 4f 52 3a 20 print 0 "ERROR:
2950: 6e 6f 6e 2d 65 78 69 73 74 65 6e 74 20 72 65 71 non-existent req
2960: 75 69 72 65 64 20 74 65 73 74 20 5c 22 22 20 68 uired test \"" h
2970: 65 64 20 22 5c 22 22 29 0a 20 20 20 20 20 20 20 ed "\"").
2980: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2990: 20 20 20 20 20 20 20 20 20 28 69 66 20 64 62 20 (if db
29a0: 28 73 71 6c 69 74 65 33 3a 66 69 6e 61 6c 69 7a (sqlite3:finaliz
29b0: 65 21 20 64 62 29 29 0a 09 09 09 09 28 65 78 69 e! db)).....(exi
29c0: 74 20 31 29 29 29 29 29 0a 09 20 20 20 20 3b 3b t 1))))).. ;;
29d0: 20 63 68 65 63 6b 20 66 6f 72 20 68 65 64 20 69 check for hed i
29e0: 6e 20 77 61 69 74 6f 6e 73 20 3d 3e 20 74 68 69 n waitons => thi
29f0: 73 20 77 6f 75 6c 64 20 62 65 20 63 69 72 63 75 s would be circu
2a00: 6c 61 72 2c 20 72 65 6d 6f 76 65 20 69 74 20 61 lar, remove it a
2a10: 6e 64 20 69 73 73 75 65 20 61 6e 0a 09 20 20 20 nd issue an..
2a20: 20 3b 3b 20 65 72 72 6f 72 0a 09 20 20 20 20 28 ;; error.. (
2a30: 69 66 20 28 6d 65 6d 62 65 72 20 68 65 64 20 77 if (member hed w
2a40: 61 69 74 6f 6e 73 29 0a 09 09 28 62 65 67 69 6e aitons)...(begin
2a50: 0a 09 09 20 20 28 64 65 62 75 67 3a 70 72 69 6e ... (debug:prin
2a60: 74 20 30 20 22 45 52 52 4f 52 3a 20 74 65 73 74 t 0 "ERROR: test
2a70: 20 22 20 68 65 64 20 22 20 68 61 73 20 6c 69 73 " hed " has lis
2a80: 74 65 64 20 69 74 73 65 6c 66 20 61 73 20 61 20 ted itself as a
2a90: 77 61 69 74 6f 6e 2c 20 70 6c 65 61 73 65 20 63 waiton, please c
2aa0: 6f 72 72 65 63 74 20 74 68 69 73 21 22 29 0a 09 orrect this!")..
2ab0: 09 20 20 28 73 65 74 21 20 77 61 69 74 6f 6e 73 . (set! waitons
2ac0: 20 28 66 69 6c 74 65 72 20 28 6c 61 6d 62 64 61 (filter (lambda
2ad0: 20 28 78 29 28 6e 6f 74 20 28 65 71 75 61 6c 3f (x)(not (equal?
2ae0: 20 78 20 68 65 64 29 29 29 20 77 61 69 74 6f 6e x hed))) waiton
2af0: 73 29 29 29 29 0a 09 20 20 20 20 0a 09 20 20 20 s)))).. ..
2b00: 20 3b 3b 20 28 69 74 65 6d 73 20 20 20 28 69 74 ;; (items (it
2b10: 65 6d 73 3a 67 65 74 2d 69 74 65 6d 73 2d 66 72 ems:get-items-fr
2b20: 6f 6d 2d 63 6f 6e 66 69 67 20 63 6f 6e 66 69 67 om-config config
2b30: 29 29 29 0a 09 20 20 20 20 28 69 66 20 28 6e 6f ))).. (if (no
2b40: 74 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 t (hash-table-re
2b50: 66 2f 64 65 66 61 75 6c 74 20 74 65 73 74 2d 72 f/default test-r
2b60: 65 63 6f 72 64 73 20 68 65 64 20 23 66 29 29 0a ecords hed #f)).
2b70: 09 09 28 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 ..(hash-table-se
2b80: 74 21 20 74 65 73 74 2d 72 65 63 6f 72 64 73 0a t! test-records.
2b90: 09 09 09 09 20 68 65 64 20 28 76 65 63 74 6f 72 .... hed (vector
2ba0: 20 68 65 64 20 20 20 20 20 3b 3b 20 30 0a 09 09 hed ;; 0...
2bb0: 09 09 09 20 20 20 20 20 63 6f 6e 66 69 67 20 20 ... config
2bc0: 3b 3b 20 31 0a 09 09 09 09 09 20 20 20 20 20 77 ;; 1...... w
2bd0: 61 69 74 6f 6e 73 20 3b 3b 20 32 0a 09 09 09 09 aitons ;; 2.....
2be0: 09 20 20 20 20 20 28 63 6f 6e 66 69 67 2d 6c 6f . (config-lo
2bf0: 6f 6b 75 70 20 63 6f 6e 66 69 67 20 22 72 65 71 okup config "req
2c00: 75 69 72 65 6d 65 6e 74 73 22 20 22 70 72 69 6f uirements" "prio
2c10: 72 69 74 79 22 29 20 20 20 20 20 3b 3b 20 70 72 rity") ;; pr
2c20: 69 6f 72 69 74 79 20 33 0a 09 09 09 09 09 20 20 iority 3......
2c30: 20 20 20 28 6c 65 74 20 28 28 69 74 65 6d 73 20 (let ((items
2c40: 20 20 20 20 20 28 68 61 73 68 2d 74 61 62 6c 65 (hash-table
2c50: 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 63 6f 6e -ref/default con
2c60: 66 69 67 20 22 69 74 65 6d 73 22 20 23 66 29 29 fig "items" #f))
2c70: 20 3b 3b 20 69 74 65 6d 73 20 34 0a 09 09 09 09 ;; items 4.....
2c80: 09 09 20 20 20 28 69 74 65 6d 73 74 61 62 6c 65 .. (itemstable
2c90: 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 (hash-table-ref
2ca0: 2f 64 65 66 61 75 6c 74 20 63 6f 6e 66 69 67 20 /default config
2cb0: 22 69 74 65 6d 73 74 61 62 6c 65 22 20 23 66 29 "itemstable" #f)
2cc0: 29 29 20 0a 09 09 09 09 09 20 20 20 20 20 20 20 )) ......
2cd0: 3b 3b 20 69 66 20 65 69 74 68 65 72 20 69 74 65 ;; if either ite
2ce0: 6d 73 20 6f 72 20 69 74 65 6d 73 20 74 61 62 6c ms or items tabl
2cf0: 65 20 69 73 20 61 20 70 72 6f 63 20 72 65 74 75 e is a proc retu
2d00: 72 6e 20 69 74 20 73 6f 20 74 65 73 74 20 72 75 rn it so test ru
2d10: 6e 6e 69 6e 67 0a 09 09 09 09 09 20 20 20 20 20 nning......
2d20: 20 20 3b 3b 20 70 72 6f 63 65 73 73 20 63 61 6e ;; process can
2d30: 20 6b 6e 6f 77 20 74 6f 20 63 61 6c 6c 20 69 74 know to call it
2d40: 65 6d 73 3a 67 65 74 2d 69 74 65 6d 73 2d 66 72 ems:get-items-fr
2d50: 6f 6d 2d 63 6f 6e 66 69 67 0a 09 09 09 09 09 20 om-config......
2d60: 20 20 20 20 20 20 3b 3b 20 69 66 20 65 69 74 68 ;; if eith
2d70: 65 72 20 69 73 20 61 20 6c 69 73 74 20 61 6e 64 er is a list and
2d80: 20 6e 6f 6e 65 20 69 73 20 61 20 70 72 6f 63 20 none is a proc
2d90: 67 6f 20 61 68 65 61 64 20 61 6e 64 20 63 61 6c go ahead and cal
2da0: 6c 20 67 65 74 2d 69 74 65 6d 73 0a 09 09 09 09 l get-items.....
2db0: 09 20 20 20 20 20 20 20 3b 3b 20 6f 74 68 65 72 . ;; other
2dc0: 77 69 73 65 20 72 65 74 75 72 6e 20 23 66 20 2d wise return #f -
2dd0: 20 74 68 69 73 20 69 73 20 6e 6f 74 20 61 6e 20 this is not an
2de0: 69 74 65 72 61 74 65 64 20 74 65 73 74 0a 09 09 iterated test...
2df0: 09 09 09 20 20 20 20 20 20 20 28 63 6f 6e 64 0a ... (cond.
2e00: 09 09 09 09 09 09 28 28 70 72 6f 63 65 64 75 72 ......((procedur
2e10: 65 3f 20 69 74 65 6d 73 29 20 20 20 20 20 20 0a e? items) .
2e20: 09 09 09 09 09 09 20 28 64 65 62 75 67 3a 70 72 ...... (debug:pr
2e30: 69 6e 74 2d 69 6e 66 6f 20 34 20 22 69 74 65 6d int-info 4 "item
2e40: 73 20 69 73 20 61 20 70 72 6f 63 65 64 75 72 65 s is a procedure
2e50: 2c 20 77 69 6c 6c 20 63 61 6c 63 20 6c 61 74 65 , will calc late
2e60: 72 22 29 0a 09 09 09 09 09 09 20 69 74 65 6d 73 r")....... items
2e70: 29 20 20 20 20 20 20 20 20 20 20 20 20 3b 3b 20 ) ;;
2e80: 63 61 6c 63 20 6c 61 74 65 72 0a 09 09 09 09 09 calc later......
2e90: 09 28 28 70 72 6f 63 65 64 75 72 65 3f 20 69 74 .((procedure? it
2ea0: 65 6d 73 74 61 62 6c 65 29 0a 09 09 09 09 09 09 emstable).......
2eb0: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e (debug:print-in
2ec0: 66 6f 20 34 20 22 69 74 65 6d 73 74 61 62 6c 65 fo 4 "itemstable
2ed0: 20 69 73 20 61 20 70 72 6f 63 65 64 75 72 65 2c is a procedure,
2ee0: 20 77 69 6c 6c 20 63 61 6c 63 20 6c 61 74 65 72 will calc later
2ef0: 22 29 0a 09 09 09 09 09 09 20 69 74 65 6d 73 74 ")....... itemst
2f00: 61 62 6c 65 29 20 20 20 20 20 20 20 3b 3b 20 63 able) ;; c
2f10: 61 6c 63 20 6c 61 74 65 72 0a 09 09 09 09 09 09 alc later.......
2f20: 28 28 66 69 6c 74 65 72 20 28 6c 61 6d 62 64 61 ((filter (lambda
2f30: 20 28 78 29 0a 09 09 09 09 09 09 09 20 20 20 28 (x)........ (
2f40: 6c 65 74 20 28 28 76 61 6c 20 28 63 61 72 20 78 let ((val (car x
2f50: 29 29 29 0a 09 09 09 09 09 09 09 20 20 20 20 20 )))........
2f60: 28 69 66 20 28 70 72 6f 63 65 64 75 72 65 3f 20 (if (procedure?
2f70: 76 61 6c 29 20 76 61 6c 20 23 66 29 29 29 0a 09 val) val #f)))..
2f80: 09 09 09 09 09 09 20 28 61 70 70 65 6e 64 20 28 ...... (append (
2f90: 69 66 20 28 6c 69 73 74 3f 20 69 74 65 6d 73 29 if (list? items)
2fa0: 20 69 74 65 6d 73 20 27 28 29 29 0a 09 09 09 09 items '()).....
2fb0: 09 09 09 09 20 28 69 66 20 28 6c 69 73 74 3f 20 .... (if (list?
2fc0: 69 74 65 6d 73 74 61 62 6c 65 29 20 69 74 65 6d itemstable) item
2fd0: 73 74 61 62 6c 65 20 27 28 29 29 29 29 0a 09 09 stable '())))...
2fe0: 09 09 09 09 20 27 68 61 76 65 2d 70 72 6f 63 65 .... 'have-proce
2ff0: 64 75 72 65 29 0a 09 09 09 09 09 09 28 28 6f 72 dure).......((or
3000: 20 28 6c 69 73 74 3f 20 69 74 65 6d 73 29 28 6c (list? items)(l
3010: 69 73 74 3f 20 69 74 65 6d 73 74 61 62 6c 65 29 ist? itemstable)
3020: 29 20 3b 3b 20 63 61 6c 63 20 6e 6f 77 0a 09 09 ) ;; calc now...
3030: 09 09 09 09 20 28 64 65 62 75 67 3a 70 72 69 6e .... (debug:prin
3040: 74 2d 69 6e 66 6f 20 34 20 22 69 74 65 6d 73 20 t-info 4 "items
3050: 61 6e 64 20 69 74 65 6d 73 74 61 62 6c 65 20 61 and itemstable a
3060: 72 65 20 6c 69 73 74 73 2c 20 63 61 6c 63 20 6e re lists, calc n
3070: 6f 77 5c 6e 22 0a 09 09 09 09 09 09 09 20 20 20 ow\n"........
3080: 20 20 20 22 20 20 20 20 69 74 65 6d 73 3a 20 22 " items: "
3090: 20 69 74 65 6d 73 20 22 20 69 74 65 6d 73 74 61 items " itemsta
30a0: 62 6c 65 3a 20 22 20 69 74 65 6d 73 74 61 62 6c ble: " itemstabl
30b0: 65 29 0a 09 09 09 09 09 09 20 28 69 74 65 6d 73 e)....... (items
30c0: 3a 67 65 74 2d 69 74 65 6d 73 2d 66 72 6f 6d 2d :get-items-from-
30d0: 63 6f 6e 66 69 67 20 63 6f 6e 66 69 67 29 29 0a config config)).
30e0: 09 09 09 09 09 09 28 65 6c 73 65 20 23 66 29 29 ......(else #f))
30f0: 29 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 )
3100: 20 20 20 20 20 20 20 20 20 20 20 20 3b 3b 20 6e ;; n
3110: 6f 74 20 69 74 65 72 61 74 65 64 0a 09 09 09 09 ot iterated.....
3120: 09 20 20 20 20 20 23 66 20 20 20 20 20 20 3b 3b . #f ;;
3130: 20 69 74 65 6d 73 64 61 74 20 35 0a 09 09 09 09 itemsdat 5.....
3140: 09 20 20 20 20 20 23 66 20 20 20 20 20 20 3b 3b . #f ;;
3150: 20 73 70 61 72 65 20 2d 20 75 73 65 64 20 66 6f spare - used fo
3160: 72 20 69 74 65 6d 2d 70 61 74 68 0a 09 09 09 09 r item-path.....
3170: 09 20 20 20 20 20 29 29 29 0a 09 20 20 20 20 28 . ))).. (
3180: 66 6f 72 2d 65 61 63 68 20 0a 09 20 20 20 20 20 for-each ..
3190: 28 6c 61 6d 62 64 61 20 28 77 61 69 74 6f 6e 29 (lambda (waiton)
31a0: 0a 09 20 20 20 20 20 20 20 28 69 66 20 28 61 6e .. (if (an
31b0: 64 20 77 61 69 74 6f 6e 20 28 6e 6f 74 20 28 6d d waiton (not (m
31c0: 65 6d 62 65 72 20 77 61 69 74 6f 6e 20 74 65 73 ember waiton tes
31d0: 74 2d 6e 61 6d 65 73 29 29 29 0a 09 09 20 20 20 t-names)))...
31e0: 28 62 65 67 69 6e 0a 09 09 20 20 20 20 20 28 73 (begin... (s
31f0: 65 74 21 20 72 65 71 75 69 72 65 64 2d 74 65 73 et! required-tes
3200: 74 73 20 28 63 6f 6e 73 20 77 61 69 74 6f 6e 20 ts (cons waiton
3210: 72 65 71 75 69 72 65 64 2d 74 65 73 74 73 29 29 required-tests))
3220: 0a 09 09 20 20 20 20 20 28 73 65 74 21 20 74 65 ... (set! te
3230: 73 74 2d 6e 61 6d 65 73 20 28 63 6f 6e 73 20 77 st-names (cons w
3240: 61 69 74 6f 6e 20 74 65 73 74 2d 6e 61 6d 65 73 aiton test-names
3250: 29 29 29 29 29 20 3b 3b 20 77 61 73 20 61 6e 20 ))))) ;; was an
3260: 61 70 70 65 6e 64 2c 20 6e 6f 77 20 61 20 63 6f append, now a co
3270: 6e 73 0a 09 20 20 20 20 20 77 61 69 74 6f 6e 73 ns.. waitons
3280: 29 0a 09 20 20 20 20 28 6c 65 74 20 28 28 72 65 ).. (let ((re
3290: 6d 74 65 73 74 73 20 28 64 65 6c 65 74 65 2d 64 mtests (delete-d
32a0: 75 70 6c 69 63 61 74 65 73 20 28 61 70 70 65 6e uplicates (appen
32b0: 64 20 77 61 69 74 6f 6e 73 20 74 61 6c 29 29 29 d waitons tal)))
32c0: 29 0a 09 20 20 20 20 20 20 28 69 66 20 28 6e 6f ).. (if (no
32d0: 74 20 28 6e 75 6c 6c 3f 20 72 65 6d 74 65 73 74 t (null? remtest
32e0: 73 29 29 0a 09 09 20 20 28 6c 6f 6f 70 20 28 63 s))... (loop (c
32f0: 61 72 20 72 65 6d 74 65 73 74 73 29 28 63 64 72 ar remtests)(cdr
3300: 20 72 65 6d 74 65 73 74 73 29 29 29 29 29 29 29 remtests)))))))
3310: 0a 0a 20 20 20 20 28 69 66 20 28 6e 6f 74 20 28 .. (if (not (
3320: 6e 75 6c 6c 3f 20 72 65 71 75 69 72 65 64 2d 74 null? required-t
3330: 65 73 74 73 29 29 0a 09 28 64 65 62 75 67 3a 70 ests))..(debug:p
3340: 72 69 6e 74 2d 69 6e 66 6f 20 31 20 22 41 64 64 rint-info 1 "Add
3350: 69 6e 67 20 22 20 72 65 71 75 69 72 65 64 2d 74 ing " required-t
3360: 65 73 74 73 20 22 20 74 6f 20 74 68 65 20 72 75 ests " to the ru
3370: 6e 20 71 75 65 75 65 22 29 29 0a 20 20 20 20 3b n queue")). ;
3380: 3b 20 4e 4f 54 45 3a 20 74 68 65 73 65 20 61 72 ; NOTE: these ar
3390: 65 20 61 6c 6c 20 70 61 72 65 6e 74 20 74 65 73 e all parent tes
33a0: 74 73 2c 20 69 74 65 6d 73 20 61 72 65 20 6e 6f ts, items are no
33b0: 74 20 65 78 70 61 6e 64 65 64 20 79 65 74 2e 0a t expanded yet..
33c0: 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 (debug:print
33d0: 2d 69 6e 66 6f 20 34 20 22 74 65 73 74 2d 72 65 -info 4 "test-re
33e0: 63 6f 72 64 73 3d 22 20 28 68 61 73 68 2d 74 61 cords=" (hash-ta
33f0: 62 6c 65 2d 3e 61 6c 69 73 74 20 74 65 73 74 2d ble->alist test-
3400: 72 65 63 6f 72 64 73 29 29 0a 20 20 20 20 28 72 records)). (r
3410: 75 6e 73 3a 72 75 6e 2d 74 65 73 74 73 2d 71 75 uns:run-tests-qu
3420: 65 75 65 20 72 75 6e 2d 69 64 20 72 75 6e 6e 61 eue run-id runna
3430: 6d 65 20 74 65 73 74 2d 72 65 63 6f 72 64 73 20 me test-records
3440: 6b 65 79 76 61 6c 6c 73 74 20 66 6c 61 67 73 20 keyvallst flags
3450: 74 65 73 74 2d 70 61 74 74 73 29 0a 20 20 20 20 test-patts).
3460: 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 (debug:print-inf
3470: 6f 20 34 20 22 41 6c 6c 20 64 6f 6e 65 20 62 79 o 4 "All done by
3480: 20 68 65 72 65 22 29 29 29 0a 0a 28 64 65 66 69 here")))..(defi
3490: 6e 65 20 28 72 75 6e 73 3a 63 61 6c 63 2d 66 61 ne (runs:calc-fa
34a0: 69 6c 73 20 70 72 65 72 65 71 73 2d 6e 6f 74 2d ils prereqs-not-
34b0: 6d 65 74 29 0a 20 20 28 66 69 6c 74 65 72 20 28 met). (filter (
34c0: 6c 61 6d 62 64 61 20 28 74 65 73 74 29 0a 09 20 lambda (test)..
34d0: 20 20 20 28 61 6e 64 20 28 76 65 63 74 6f 72 3f (and (vector?
34e0: 20 74 65 73 74 29 20 3b 3b 20 6e 6f 74 20 28 73 test) ;; not (s
34f0: 74 72 69 6e 67 3f 20 74 65 73 74 29 29 0a 09 09 tring? test))...
3500: 20 28 65 71 75 61 6c 3f 20 28 64 62 3a 74 65 73 (equal? (db:tes
3510: 74 2d 67 65 74 2d 73 74 61 74 65 20 74 65 73 74 t-get-state test
3520: 29 20 22 43 4f 4d 50 4c 45 54 45 44 22 29 0a 09 ) "COMPLETED")..
3530: 09 20 28 6e 6f 74 20 28 6d 65 6d 62 65 72 20 28 . (not (member (
3540: 64 62 3a 74 65 73 74 2d 67 65 74 2d 73 74 61 74 db:test-get-stat
3550: 75 73 20 74 65 73 74 29 0a 09 09 09 20 20 20 20 us test)....
3560: 20 20 27 28 22 50 41 53 53 22 20 22 57 41 52 4e '("PASS" "WARN
3570: 22 20 22 43 48 45 43 4b 22 20 22 57 41 49 56 45 " "CHECK" "WAIVE
3580: 44 22 29 29 29 29 29 0a 09 20 20 70 72 65 72 65 D"))))).. prere
3590: 71 73 2d 6e 6f 74 2d 6d 65 74 29 29 0a 0a 28 64 qs-not-met))..(d
35a0: 65 66 69 6e 65 20 28 72 75 6e 73 3a 63 61 6c 63 efine (runs:calc
35b0: 2d 6e 6f 74 2d 63 6f 6d 70 6c 65 74 65 64 20 70 -not-completed p
35c0: 72 65 72 65 71 73 2d 6e 6f 74 2d 6d 65 74 29 0a rereqs-not-met).
35d0: 20 20 28 66 69 6c 74 65 72 0a 20 20 20 28 6c 61 (filter. (la
35e0: 6d 62 64 61 20 28 74 29 0a 20 20 20 20 20 28 6f mbda (t). (o
35f0: 72 20 28 6e 6f 74 20 28 76 65 63 74 6f 72 3f 20 r (not (vector?
3600: 74 29 29 0a 09 20 28 6e 6f 74 20 28 65 71 75 61 t)).. (not (equa
3610: 6c 3f 20 22 43 4f 4d 50 4c 45 54 45 44 22 20 28 l? "COMPLETED" (
3620: 64 62 3a 74 65 73 74 2d 67 65 74 2d 73 74 61 74 db:test-get-stat
3630: 65 20 74 29 29 29 29 29 0a 20 20 20 70 72 65 72 e t))))). prer
3640: 65 71 73 2d 6e 6f 74 2d 6d 65 74 29 29 0a 0a 28 eqs-not-met))..(
3650: 64 65 66 69 6e 65 20 28 72 75 6e 73 3a 70 72 65 define (runs:pre
3660: 74 74 79 2d 73 74 72 69 6e 67 20 6c 73 74 29 0a tty-string lst).
3670: 20 20 28 6d 61 70 20 28 6c 61 6d 62 64 61 20 28 (map (lambda (
3680: 74 29 0a 09 20 28 69 66 20 28 6e 6f 74 20 28 76 t).. (if (not (v
3690: 65 63 74 6f 72 3f 20 74 29 29 0a 09 20 20 20 20 ector? t))..
36a0: 20 28 63 6f 6e 63 20 74 29 0a 09 20 20 20 20 20 (conc t)..
36b0: 28 63 6f 6e 63 20 28 64 62 3a 74 65 73 74 2d 67 (conc (db:test-g
36c0: 65 74 2d 74 65 73 74 6e 61 6d 65 20 74 29 20 22 et-testname t) "
36d0: 3a 22 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d :" (db:test-get-
36e0: 73 74 61 74 65 20 74 29 20 22 2f 22 20 28 64 62 state t) "/" (db
36f0: 3a 74 65 73 74 2d 67 65 74 2d 73 74 61 74 75 73 :test-get-status
3700: 20 74 29 29 29 29 0a 20 20 20 20 20 20 20 6c 73 t)))). ls
3710: 74 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 72 75 t))..(define (ru
3720: 6e 73 3a 6d 61 6b 65 2d 66 75 6c 6c 2d 74 65 73 ns:make-full-tes
3730: 74 2d 6e 61 6d 65 20 74 65 73 74 6e 61 6d 65 20 t-name testname
3740: 69 74 65 6d 70 61 74 68 29 0a 20 20 28 69 66 20 itempath). (if
3750: 28 65 71 75 61 6c 3f 20 69 74 65 6d 70 61 74 68 (equal? itempath
3760: 20 22 22 29 20 74 65 73 74 6e 61 6d 65 20 28 63 "") testname (c
3770: 6f 6e 63 20 74 65 73 74 6e 61 6d 65 20 22 2f 22 onc testname "/"
3780: 20 69 74 65 6d 70 61 74 68 29 29 29 0a 0a 3b 3b itempath)))..;;
3790: 20 74 65 73 74 2d 72 65 63 6f 72 64 73 20 69 73 test-records is
37a0: 20 61 20 68 61 73 68 20 74 61 62 6c 65 20 74 65 a hash table te
37b0: 73 74 6e 61 6d 65 3a 69 74 65 6d 5f 70 61 74 68 stname:item_path
37c0: 20 3d 3e 20 76 65 63 74 6f 72 20 3c 20 74 65 73 => vector < tes
37d0: 74 6e 61 6d 65 20 74 65 73 74 63 6f 6e 66 69 67 tname testconfig
37e0: 20 77 61 69 74 6f 6e 73 20 70 72 69 6f 72 69 74 waitons priorit
37f0: 79 20 69 74 65 6d 73 2d 69 6e 66 6f 20 2e 2e 2e y items-info ...
3800: 20 3e 0a 28 64 65 66 69 6e 65 20 28 72 75 6e 73 >.(define (runs
3810: 3a 72 75 6e 2d 74 65 73 74 73 2d 71 75 65 75 65 :run-tests-queue
3820: 20 72 75 6e 2d 69 64 20 72 75 6e 6e 61 6d 65 20 run-id runname
3830: 74 65 73 74 2d 72 65 63 6f 72 64 73 20 6b 65 79 test-records key
3840: 76 61 6c 6c 73 74 20 66 6c 61 67 73 20 74 65 73 vallst flags tes
3850: 74 2d 70 61 74 74 73 29 0a 20 20 20 20 3b 3b 20 t-patts). ;;
3860: 41 74 20 74 68 69 73 20 70 6f 69 6e 74 20 74 68 At this point th
3870: 65 20 6c 69 73 74 20 6f 66 20 70 61 72 65 6e 74 e list of parent
3880: 20 74 65 73 74 73 20 69 73 20 65 78 70 61 6e 64 tests is expand
3890: 65 64 20 0a 20 20 20 20 3b 3b 20 4e 42 2f 2f 20 ed . ;; NB//
38a0: 53 68 6f 75 6c 64 20 65 78 70 61 6e 64 20 69 74 Should expand it
38b0: 65 6d 73 20 68 65 72 65 20 61 6e 64 20 74 68 65 ems here and the
38c0: 6e 20 69 6e 73 65 72 74 20 69 6e 74 6f 20 74 68 n insert into th
38d0: 65 20 72 75 6e 20 71 75 65 75 65 2e 0a 20 20 28 e run queue.. (
38e0: 64 65 62 75 67 3a 70 72 69 6e 74 20 35 20 22 74 debug:print 5 "t
38f0: 65 73 74 2d 72 65 63 6f 72 64 73 3a 20 22 20 74 est-records: " t
3900: 65 73 74 2d 72 65 63 6f 72 64 73 20 22 2c 20 6b est-records ", k
3910: 65 79 76 61 6c 6c 73 74 3a 20 22 20 6b 65 79 76 eyvallst: " keyv
3920: 61 6c 6c 73 74 20 22 20 66 6c 61 67 73 3a 20 22 allst " flags: "
3930: 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 3e 61 6c (hash-table->al
3940: 69 73 74 20 66 6c 61 67 73 29 29 0a 20 20 28 6c ist flags)). (l
3950: 65 74 20 28 28 73 6f 72 74 65 64 2d 74 65 73 74 et ((sorted-test
3960: 2d 6e 61 6d 65 73 20 28 74 65 73 74 73 3a 73 6f -names (tests:so
3970: 72 74 2d 62 79 2d 70 72 69 6f 72 69 74 79 2d 61 rt-by-priority-a
3980: 6e 64 2d 77 61 69 74 6f 6e 20 74 65 73 74 2d 72 nd-waiton test-r
3990: 65 63 6f 72 64 73 29 29 0a 09 28 74 65 73 74 2d ecords))..(test-
39a0: 72 65 67 69 73 74 65 72 79 20 20 20 20 28 6d 61 registery (ma
39b0: 6b 65 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 0a ke-hash-table)).
39c0: 09 28 6e 75 6d 2d 72 65 74 72 69 65 73 20 20 20 .(num-retries
39d0: 20 20 20 20 20 30 29 0a 09 28 6d 61 78 2d 72 65 0)..(max-re
39e0: 74 72 69 65 73 20 20 20 20 20 20 20 28 63 6f 6e tries (con
39f0: 66 69 67 2d 6c 6f 6f 6b 75 70 20 2a 63 6f 6e 66 fig-lookup *conf
3a00: 69 67 64 61 74 2a 20 22 73 65 74 75 70 22 20 22 igdat* "setup" "
3a10: 6d 61 78 72 65 74 72 69 65 73 22 29 29 29 0a 20 maxretries"))).
3a20: 20 20 20 28 73 65 74 21 20 6d 61 78 2d 72 65 74 (set! max-ret
3a30: 72 69 65 73 20 28 69 66 20 28 61 6e 64 20 6d 61 ries (if (and ma
3a40: 78 2d 72 65 74 72 69 65 73 20 28 73 74 72 69 6e x-retries (strin
3a50: 67 2d 3e 6e 75 6d 62 65 72 20 6d 61 78 2d 72 65 g->number max-re
3a60: 74 72 69 65 73 29 29 28 73 74 72 69 6e 67 2d 3e tries))(string->
3a70: 6e 75 6d 62 65 72 20 6d 61 78 2d 72 65 74 72 69 number max-retri
3a80: 65 73 29 20 31 30 30 29 29 0a 20 20 20 20 28 69 es) 100)). (i
3a90: 66 20 28 6e 6f 74 20 28 6e 75 6c 6c 3f 20 73 6f f (not (null? so
3aa0: 72 74 65 64 2d 74 65 73 74 2d 6e 61 6d 65 73 29 rted-test-names)
3ab0: 29 0a 09 28 6c 65 74 20 6c 6f 6f 70 20 28 28 68 )..(let loop ((h
3ac0: 65 64 20 20 20 20 20 20 20 20 20 28 63 61 72 20 ed (car
3ad0: 73 6f 72 74 65 64 2d 74 65 73 74 2d 6e 61 6d 65 sorted-test-name
3ae0: 73 29 29 0a 09 09 20 20 20 28 74 61 6c 20 20 20 s))... (tal
3af0: 20 20 20 20 20 20 28 63 64 72 20 73 6f 72 74 65 (cdr sorte
3b00: 64 2d 74 65 73 74 2d 6e 61 6d 65 73 29 29 0a 09 d-test-names))..
3b10: 09 20 20 20 28 72 65 72 75 6e 73 20 20 20 20 20 . (reruns
3b20: 20 27 28 29 29 29 0a 09 20 20 28 69 66 20 28 6e '())).. (if (n
3b30: 6f 74 20 28 6e 75 6c 6c 3f 20 72 65 72 75 6e 73 ot (null? reruns
3b40: 29 29 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 ))(debug:print-i
3b50: 6e 66 6f 20 34 20 22 72 65 72 75 6e 73 3d 22 20 nfo 4 "reruns="
3b60: 72 65 72 75 6e 73 29 29 0a 09 20 20 3b 3b 20 28 reruns)).. ;; (
3b70: 70 72 69 6e 74 20 22 54 6f 70 20 6f 66 20 6c 6f print "Top of lo
3b80: 6f 70 2c 20 68 65 64 3d 22 20 68 65 64 20 22 2c op, hed=" hed ",
3b90: 20 74 61 6c 3d 22 20 74 61 6c 20 22 20 2c 72 65 tal=" tal " ,re
3ba0: 72 75 6e 73 3d 22 20 72 65 72 75 6e 73 29 0a 09 runs=" reruns)..
3bb0: 20 20 28 6c 65 74 2a 20 28 28 74 65 73 74 2d 72 (let* ((test-r
3bc0: 65 63 6f 72 64 20 28 68 61 73 68 2d 74 61 62 6c ecord (hash-tabl
3bd0: 65 2d 72 65 66 20 74 65 73 74 2d 72 65 63 6f 72 e-ref test-recor
3be0: 64 73 20 68 65 64 29 29 0a 09 09 20 28 74 65 73 ds hed))... (tes
3bf0: 74 2d 6e 61 6d 65 20 20 20 28 74 65 73 74 73 3a t-name (tests:
3c00: 74 65 73 74 71 75 65 75 65 2d 67 65 74 2d 74 65 testqueue-get-te
3c10: 73 74 6e 61 6d 65 20 74 65 73 74 2d 72 65 63 6f stname test-reco
3c20: 72 64 29 29 0a 09 09 20 28 74 63 6f 6e 66 69 67 rd))... (tconfig
3c30: 20 20 20 20 20 28 74 65 73 74 73 3a 74 65 73 74 (tests:test
3c40: 71 75 65 75 65 2d 67 65 74 2d 74 65 73 74 63 6f queue-get-testco
3c50: 6e 66 69 67 20 74 65 73 74 2d 72 65 63 6f 72 64 nfig test-record
3c60: 29 29 0a 09 09 20 28 74 65 73 74 6d 6f 64 65 20 ))... (testmode
3c70: 20 20 20 28 6c 65 74 20 28 28 6d 20 28 63 6f 6e (let ((m (con
3c80: 66 69 67 2d 6c 6f 6f 6b 75 70 20 74 63 6f 6e 66 fig-lookup tconf
3c90: 69 67 20 22 72 65 71 75 69 72 65 6d 65 6e 74 73 ig "requirements
3ca0: 22 20 22 6d 6f 64 65 22 29 29 29 0a 09 09 09 09 " "mode"))).....
3cb0: 28 69 66 20 6d 20 28 73 74 72 69 6e 67 2d 3e 73 (if m (string->s
3cc0: 79 6d 62 6f 6c 20 6d 29 20 27 6e 6f 72 6d 61 6c ymbol m) 'normal
3cd0: 29 29 29 0a 09 09 20 28 77 61 69 74 6f 6e 73 20 )))... (waitons
3ce0: 20 20 20 20 28 74 65 73 74 73 3a 74 65 73 74 71 (tests:testq
3cf0: 75 65 75 65 2d 67 65 74 2d 77 61 69 74 6f 6e 73 ueue-get-waitons
3d00: 20 20 20 20 74 65 73 74 2d 72 65 63 6f 72 64 29 test-record)
3d10: 29 0a 09 09 20 28 70 72 69 6f 72 69 74 79 20 20 )... (priority
3d20: 20 20 28 74 65 73 74 73 3a 74 65 73 74 71 75 65 (tests:testque
3d30: 75 65 2d 67 65 74 2d 70 72 69 6f 72 69 74 79 20 ue-get-priority
3d40: 20 20 74 65 73 74 2d 72 65 63 6f 72 64 29 29 0a test-record)).
3d50: 09 09 20 28 69 74 65 6d 64 61 74 20 20 20 20 20 .. (itemdat
3d60: 28 74 65 73 74 73 3a 74 65 73 74 71 75 65 75 65 (tests:testqueue
3d70: 2d 67 65 74 2d 69 74 65 6d 64 61 74 20 20 20 20 -get-itemdat
3d80: 74 65 73 74 2d 72 65 63 6f 72 64 29 29 20 3b 3b test-record)) ;;
3d90: 20 69 74 65 6d 64 61 74 20 63 61 6e 20 62 65 20 itemdat can be
3da0: 61 20 73 74 72 69 6e 67 2c 20 6c 69 73 74 20 6f a string, list o
3db0: 72 20 23 66 0a 09 09 20 28 69 74 65 6d 73 20 20 r #f... (items
3dc0: 20 20 20 20 20 28 74 65 73 74 73 3a 74 65 73 74 (tests:test
3dd0: 71 75 65 75 65 2d 67 65 74 2d 69 74 65 6d 73 20 queue-get-items
3de0: 20 20 20 20 20 74 65 73 74 2d 72 65 63 6f 72 64 test-record
3df0: 29 29 0a 09 09 20 28 69 74 65 6d 2d 70 61 74 68 ))... (item-path
3e00: 20 20 20 28 69 74 65 6d 2d 6c 69 73 74 2d 3e 70 (item-list->p
3e10: 61 74 68 20 69 74 65 6d 64 61 74 29 29 0a 09 09 ath itemdat))...
3e20: 20 28 6e 65 77 74 61 6c 20 20 20 20 20 20 28 61 (newtal (a
3e30: 70 70 65 6e 64 20 74 61 6c 20 28 6c 69 73 74 20 ppend tal (list
3e40: 68 65 64 29 29 29 29 0a 09 20 20 20 20 0a 09 20 hed)))).. ..
3e50: 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 (debug:print
3e60: 36 0a 09 09 09 20 22 74 65 73 74 2d 6e 61 6d 65 6.... "test-name
3e70: 3a 20 22 20 74 65 73 74 2d 6e 61 6d 65 0a 09 09 : " test-name...
3e80: 09 20 22 5c 6e 20 20 68 65 64 3a 20 20 20 20 20 . "\n hed:
3e90: 20 20 20 20 22 20 68 65 64 0a 09 09 09 20 22 5c " hed.... "\
3ea0: 6e 20 20 69 74 65 6d 64 61 74 3a 20 20 20 20 20 n itemdat:
3eb0: 22 20 69 74 65 6d 64 61 74 0a 09 09 09 20 22 5c " itemdat.... "\
3ec0: 6e 20 20 69 74 65 6d 73 3a 20 20 20 20 20 20 20 n items:
3ed0: 22 20 69 74 65 6d 73 0a 09 09 09 20 22 5c 6e 20 " items.... "\n
3ee0: 20 69 74 65 6d 2d 70 61 74 68 3a 20 20 20 22 20 item-path: "
3ef0: 69 74 65 6d 2d 70 61 74 68 0a 09 09 09 20 22 5c item-path.... "\
3f00: 6e 20 20 77 61 69 74 6f 6e 73 3a 20 20 20 20 20 n waitons:
3f10: 22 20 77 61 69 74 6f 6e 73 0a 09 09 09 20 22 5c " waitons.... "\
3f20: 6e 20 20 6e 75 6d 2d 72 65 74 72 69 65 73 3a 20 n num-retries:
3f30: 22 20 6e 75 6d 2d 72 65 74 72 69 65 73 0a 09 09 " num-retries...
3f40: 09 20 22 5c 6e 20 20 74 61 6c 3a 20 20 20 20 20 . "\n tal:
3f50: 20 20 20 20 22 20 74 61 6c 0a 09 09 09 20 22 5c " tal.... "\
3f60: 6e 20 20 72 65 72 75 6e 73 3a 20 20 20 20 20 20 n reruns:
3f70: 22 20 72 65 72 75 6e 73 29 0a 0a 09 20 20 20 20 " reruns)...
3f80: 3b 3b 20 63 68 65 63 6b 20 66 6f 72 20 68 65 64 ;; check for hed
3f90: 20 69 6e 20 77 61 69 74 6f 6e 73 20 3d 3e 20 74 in waitons => t
3fa0: 68 69 73 20 77 6f 75 6c 64 20 62 65 20 63 69 72 his would be cir
3fb0: 63 75 6c 61 72 2c 20 72 65 6d 6f 76 65 20 69 74 cular, remove it
3fc0: 20 61 6e 64 20 69 73 73 75 65 20 61 6e 0a 09 20 and issue an..
3fd0: 20 20 20 3b 3b 20 65 72 72 6f 72 0a 09 20 20 20 ;; error..
3fe0: 20 28 69 66 20 28 6d 65 6d 62 65 72 20 74 65 73 (if (member tes
3ff0: 74 2d 6e 61 6d 65 20 77 61 69 74 6f 6e 73 29 0a t-name waitons).
4000: 09 09 28 62 65 67 69 6e 0a 09 09 20 20 28 64 65 ..(begin... (de
4010: 62 75 67 3a 70 72 69 6e 74 20 30 20 22 45 52 52 bug:print 0 "ERR
4020: 4f 52 3a 20 74 65 73 74 20 22 20 74 65 73 74 2d OR: test " test-
4030: 6e 61 6d 65 20 22 20 68 61 73 20 6c 69 73 74 65 name " has liste
4040: 64 20 69 74 73 65 6c 66 20 61 73 20 61 20 77 61 d itself as a wa
4050: 69 74 6f 6e 2c 20 70 6c 65 61 73 65 20 63 6f 72 iton, please cor
4060: 72 65 63 74 20 74 68 69 73 21 22 29 0a 09 09 20 rect this!")...
4070: 20 28 73 65 74 21 20 77 61 69 74 6f 6e 20 28 66 (set! waiton (f
4080: 69 6c 74 65 72 20 28 6c 61 6d 62 64 61 20 28 78 ilter (lambda (x
4090: 29 28 6e 6f 74 20 28 65 71 75 61 6c 3f 20 78 20 )(not (equal? x
40a0: 68 65 64 29 29 29 20 77 61 69 74 6f 6e 73 29 29 hed))) waitons))
40b0: 29 29 0a 0a 09 20 20 20 20 28 63 6f 6e 64 20 3b ))... (cond ;
40c0: 3b 20 4f 55 54 45 52 20 43 4f 4e 44 0a 09 20 20 ; OUTER COND..
40d0: 20 20 20 28 28 6e 6f 74 20 69 74 65 6d 73 29 20 ((not items)
40e0: 3b 3b 20 77 68 65 6e 20 66 61 6c 73 65 20 74 68 ;; when false th
40f0: 65 20 74 65 73 74 20 69 73 20 6f 6b 20 74 6f 20 e test is ok to
4100: 62 65 20 68 61 6e 64 65 64 20 6f 66 66 20 74 6f be handed off to
4110: 20 6c 61 75 6e 63 68 20 28 62 75 74 20 6e 6f 74 launch (but not
4120: 20 62 65 66 6f 72 65 29 0a 09 20 20 20 20 20 20 before)..
4130: 28 6c 65 74 2a 20 28 28 72 75 6e 2d 6c 69 6d 69 (let* ((run-limi
4140: 74 73 2d 69 6e 66 6f 20 20 20 20 20 20 20 20 20 ts-info
4150: 28 6f 70 65 6e 2d 72 75 6e 2d 63 6c 6f 73 65 20 (open-run-close
4160: 72 75 6e 73 3a 63 61 6e 2d 72 75 6e 2d 6d 6f 72 runs:can-run-mor
4170: 65 2d 74 65 73 74 73 20 74 65 73 74 2d 72 65 63 e-tests test-rec
4180: 6f 72 64 29 29 20 3b 3b 20 6c 6f 6f 6b 20 61 74 ord)) ;; look at
4190: 20 74 68 65 20 74 65 73 74 20 6a 6f 62 67 72 6f the test jobgro
41a0: 75 70 20 61 6e 64 20 74 6f 74 20 6a 6f 62 73 20 up and tot jobs
41b0: 72 75 6e 6e 69 6e 67 0a 09 09 20 20 20 20 20 28 running... (
41c0: 68 61 76 65 2d 72 65 73 6f 75 72 63 65 73 20 20 have-resources
41d0: 20 20 20 20 20 20 20 20 28 63 61 72 20 72 75 6e (car run
41e0: 2d 6c 69 6d 69 74 73 2d 69 6e 66 6f 29 29 0a 09 -limits-info))..
41f0: 09 20 20 20 20 20 28 6e 75 6d 2d 72 75 6e 6e 69 . (num-runni
4200: 6e 67 20 20 20 20 20 20 20 20 20 20 20 20 20 28 ng (
4210: 6c 69 73 74 2d 72 65 66 20 72 75 6e 2d 6c 69 6d list-ref run-lim
4220: 69 74 73 2d 69 6e 66 6f 20 31 29 29 0a 09 09 20 its-info 1))...
4230: 20 20 20 20 28 6e 75 6d 2d 72 75 6e 6e 69 6e 67 (num-running
4240: 2d 69 6e 2d 6a 6f 62 67 72 6f 75 70 20 28 6c 69 -in-jobgroup (li
4250: 73 74 2d 72 65 66 20 72 75 6e 2d 6c 69 6d 69 74 st-ref run-limit
4260: 73 2d 69 6e 66 6f 20 32 29 29 0a 09 09 20 20 20 s-info 2))...
4270: 20 20 28 6d 61 78 2d 63 6f 6e 63 75 72 72 65 6e (max-concurren
4280: 74 2d 6a 6f 62 73 20 20 20 20 20 28 6c 69 73 74 t-jobs (list
4290: 2d 72 65 66 20 72 75 6e 2d 6c 69 6d 69 74 73 2d -ref run-limits-
42a0: 69 6e 66 6f 20 33 29 29 0a 09 09 20 20 20 20 20 info 3))...
42b0: 28 6a 6f 62 2d 67 72 6f 75 70 2d 6c 69 6d 69 74 (job-group-limit
42c0: 20 20 20 20 20 20 20 20 20 28 6c 69 73 74 2d 72 (list-r
42d0: 65 66 20 72 75 6e 2d 6c 69 6d 69 74 73 2d 69 6e ef run-limits-in
42e0: 66 6f 20 34 29 29 0a 09 09 20 20 20 20 20 28 70 fo 4))... (p
42f0: 72 65 72 65 71 73 2d 6e 6f 74 2d 6d 65 74 20 20 rereqs-not-met
4300: 20 20 20 20 20 20 20 28 6f 70 65 6e 2d 72 75 6e (open-run
4310: 2d 63 6c 6f 73 65 20 64 62 3a 67 65 74 2d 70 72 -close db:get-pr
4320: 65 72 65 71 73 2d 6e 6f 74 2d 6d 65 74 20 23 66 ereqs-not-met #f
4330: 20 72 75 6e 2d 69 64 20 77 61 69 74 6f 6e 73 20 run-id waitons
4340: 69 74 65 6d 2d 70 61 74 68 20 6d 6f 64 65 3a 20 item-path mode:
4350: 74 65 73 74 6d 6f 64 65 29 29 0a 09 09 20 20 20 testmode))...
4360: 20 20 28 66 61 69 6c 73 20 20 20 20 20 20 20 20 (fails
4370: 20 20 20 20 20 20 20 20 20 20 20 28 72 75 6e 73 (runs
4380: 3a 63 61 6c 63 2d 66 61 69 6c 73 20 70 72 65 72 :calc-fails prer
4390: 65 71 73 2d 6e 6f 74 2d 6d 65 74 29 29 0a 09 09 eqs-not-met))...
43a0: 20 20 20 20 20 28 6e 6f 6e 2d 63 6f 6d 70 6c 65 (non-comple
43b0: 74 65 64 20 20 20 20 20 20 20 20 20 20 20 28 72 ted (r
43c0: 75 6e 73 3a 63 61 6c 63 2d 6e 6f 74 2d 63 6f 6d uns:calc-not-com
43d0: 70 6c 65 74 65 64 20 70 72 65 72 65 71 73 2d 6e pleted prereqs-n
43e0: 6f 74 2d 6d 65 74 29 29 29 0a 09 09 28 64 65 62 ot-met)))...(deb
43f0: 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 38 20 ug:print-info 8
4400: 22 68 61 76 65 2d 72 65 73 6f 75 72 63 65 73 3a "have-resources:
4410: 20 22 20 68 61 76 65 2d 72 65 73 6f 75 72 63 65 " have-resource
4420: 73 20 22 20 70 72 65 72 65 71 73 2d 6e 6f 74 2d s " prereqs-not-
4430: 6d 65 74 3a 20 22 20 0a 09 09 09 20 20 20 20 20 met: " ....
4440: 28 73 74 72 69 6e 67 2d 69 6e 74 65 72 73 70 65 (string-interspe
4450: 72 73 65 20 0a 09 09 09 20 20 20 20 20 20 28 6d rse .... (m
4460: 61 70 20 28 6c 61 6d 62 64 61 20 28 74 29 0a 09 ap (lambda (t)..
4470: 09 09 09 20 20 20 20 20 28 69 66 20 28 76 65 63 ... (if (vec
4480: 74 6f 72 3f 20 74 29 0a 09 09 09 09 09 20 28 63 tor? t)...... (c
4490: 6f 6e 63 20 28 64 62 3a 74 65 73 74 2d 67 65 74 onc (db:test-get
44a0: 2d 73 74 61 74 65 20 74 29 20 22 2f 22 20 28 64 -state t) "/" (d
44b0: 62 3a 74 65 73 74 2d 67 65 74 2d 73 74 61 74 75 b:test-get-statu
44c0: 73 20 74 29 29 0a 09 09 09 09 09 20 28 63 6f 6e s t))...... (con
44d0: 63 20 22 20 57 41 52 4e 49 4e 47 3a 20 74 20 69 c " WARNING: t i
44e0: 73 20 6e 6f 74 20 61 20 76 65 63 74 6f 72 3d 22 s not a vector="
44f0: 20 74 20 29 29 29 0a 09 09 09 09 20 20 20 70 72 t )))..... pr
4500: 65 72 65 71 73 2d 6e 6f 74 2d 6d 65 74 29 20 22 ereqs-not-met) "
4510: 2c 20 22 29 20 22 20 66 61 69 6c 73 3a 20 22 20 , ") " fails: "
4520: 66 61 69 6c 73 29 0a 09 09 28 64 65 62 75 67 3a fails)...(debug:
4530: 70 72 69 6e 74 2d 69 6e 66 6f 20 34 20 22 68 65 print-info 4 "he
4540: 64 3d 22 20 68 65 64 20 22 5c 6e 20 20 74 65 73 d=" hed "\n tes
4550: 74 2d 72 65 63 6f 72 64 3d 22 20 74 65 73 74 2d t-record=" test-
4560: 72 65 63 6f 72 64 20 22 5c 6e 20 20 74 65 73 74 record "\n test
4570: 2d 6e 61 6d 65 3a 20 22 20 74 65 73 74 2d 6e 61 -name: " test-na
4580: 6d 65 20 22 5c 6e 20 20 69 74 65 6d 2d 70 61 74 me "\n item-pat
4590: 68 3a 20 22 20 69 74 65 6d 2d 70 61 74 68 20 22 h: " item-path "
45a0: 5c 6e 20 20 74 65 73 74 2d 70 61 74 74 73 3a 20 \n test-patts:
45b0: 22 20 74 65 73 74 2d 70 61 74 74 73 29 0a 0a 09 " test-patts)...
45c0: 09 3b 3b 20 44 6f 6e 27 74 20 6b 6e 6f 77 20 61 .;; Don't know a
45d0: 74 20 74 68 69 73 20 74 69 6d 65 20 69 66 20 74 t this time if t
45e0: 68 65 20 74 65 73 74 20 68 61 76 65 20 62 65 65 he test have bee
45f0: 6e 20 6c 61 75 6e 63 68 65 64 20 61 74 20 73 6f n launched at so
4600: 6d 65 20 74 69 6d 65 20 69 6e 20 74 68 65 20 70 me time in the p
4610: 61 73 74 0a 09 09 3b 3b 20 69 2e 65 2e 20 69 73 ast...;; i.e. is
4620: 20 74 68 69 73 20 61 20 72 65 2d 6c 61 75 6e 63 this a re-launc
4630: 68 3f 0a 09 09 28 64 65 62 75 67 3a 70 72 69 6e h?...(debug:prin
4640: 74 2d 69 6e 66 6f 20 34 20 22 72 75 6e 2d 6c 69 t-info 4 "run-li
4650: 6d 69 74 73 2d 69 6e 66 6f 20 3d 20 22 20 72 75 mits-info = " ru
4660: 6e 2d 6c 69 6d 69 74 73 2d 69 6e 66 6f 29 0a 09 n-limits-info)..
4670: 09 28 63 6f 6e 64 20 3b 3b 20 49 4e 4e 45 52 20 .(cond ;; INNER
4680: 43 4f 4e 44 20 23 31 20 66 6f 72 20 61 20 6c 61 COND #1 for a la
4690: 75 6e 63 68 61 62 6c 65 20 74 65 73 74 0a 09 09 unchable test...
46a0: 20 3b 3b 20 43 68 65 63 6b 20 69 74 65 6d 20 70 ;; Check item p
46b0: 61 74 68 20 61 67 61 69 6e 73 74 20 69 74 65 6d ath against item
46c0: 2d 70 61 74 74 73 0a 09 09 20 28 28 6e 6f 74 20 -patts... ((not
46d0: 28 74 65 73 74 73 3a 6d 61 74 63 68 20 74 65 73 (tests:match tes
46e0: 74 2d 70 61 74 74 73 20 28 74 65 73 74 73 3a 74 t-patts (tests:t
46f0: 65 73 74 71 75 65 75 65 2d 67 65 74 2d 74 65 73 estqueue-get-tes
4700: 74 6e 61 6d 65 20 74 65 73 74 2d 72 65 63 6f 72 tname test-recor
4710: 64 29 20 69 74 65 6d 2d 70 61 74 68 29 29 20 3b d) item-path)) ;
4720: 3b 20 54 68 69 73 20 74 65 73 74 2f 69 74 65 6d ; This test/item
4730: 70 61 74 68 20 69 73 20 6e 6f 74 20 74 6f 20 62 path is not to b
4740: 65 20 72 75 6e 0a 09 09 20 20 3b 3b 20 65 6c 73 e run... ;; els
4750: 65 20 74 68 65 20 72 75 6e 20 69 73 20 73 74 75 e the run is stu
4760: 63 6b 2c 20 74 65 6d 70 6f 72 61 72 69 6c 79 20 ck, temporarily
4770: 6f 72 20 70 65 72 6d 61 6e 65 6e 74 6c 79 0a 09 or permanently..
4780: 09 20 20 3b 3b 20 62 75 74 20 73 68 6f 75 6c 64 . ;; but should
4790: 20 63 68 65 63 6b 20 69 66 20 69 74 20 69 73 20 check if it is
47a0: 64 75 65 20 74 6f 20 6c 61 63 6b 20 6f 66 20 72 due to lack of r
47b0: 65 73 6f 75 72 63 65 73 20 76 73 2e 20 70 72 65 esources vs. pre
47c0: 72 65 71 75 69 73 69 74 65 73 0a 09 09 20 20 28 requisites... (
47d0: 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f debug:print-info
47e0: 20 31 20 22 53 6b 69 70 70 69 6e 67 20 22 20 28 1 "Skipping " (
47f0: 74 65 73 74 73 3a 74 65 73 74 71 75 65 75 65 2d tests:testqueue-
4800: 67 65 74 2d 74 65 73 74 6e 61 6d 65 20 74 65 73 get-testname tes
4810: 74 2d 72 65 63 6f 72 64 29 20 22 20 22 20 69 74 t-record) " " it
4820: 65 6d 2d 70 61 74 68 20 22 20 61 73 20 69 74 20 em-path " as it
4830: 64 6f 65 73 6e 27 74 20 6d 61 74 63 68 20 22 20 doesn't match "
4840: 74 65 73 74 2d 70 61 74 74 73 29 0a 09 09 20 20 test-patts)...
4850: 28 74 68 72 65 61 64 2d 73 6c 65 65 70 21 20 2a (thread-sleep! *
4860: 67 6c 6f 62 61 6c 2d 64 65 6c 74 61 2a 29 0a 09 global-delta*)..
4870: 09 20 20 28 69 66 20 28 6e 6f 74 20 28 6e 75 6c . (if (not (nul
4880: 6c 3f 20 74 61 6c 29 29 0a 09 09 20 20 20 20 20 l? tal))...
4890: 20 28 6c 6f 6f 70 20 28 63 61 72 20 74 61 6c 29 (loop (car tal)
48a0: 28 63 64 72 20 74 61 6c 29 20 72 65 72 75 6e 73 (cdr tal) reruns
48b0: 29 29 29 0a 09 09 20 28 28 61 6e 64 20 28 6e 6f )))... ((and (no
48c0: 74 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 t (hash-table-re
48d0: 66 2f 64 65 66 61 75 6c 74 20 74 65 73 74 2d 72 f/default test-r
48e0: 65 67 69 73 74 65 72 79 20 28 72 75 6e 73 3a 6d egistery (runs:m
48f0: 61 6b 65 2d 66 75 6c 6c 2d 74 65 73 74 2d 6e 61 ake-full-test-na
4900: 6d 65 20 74 65 73 74 2d 6e 61 6d 65 20 69 74 65 me test-name ite
4910: 6d 2d 70 61 74 68 29 20 23 66 29 29 0a 09 09 20 m-path) #f))...
4920: 20 20 20 20 20 20 28 61 6e 64 20 6d 61 78 2d 63 (and max-c
4930: 6f 6e 63 75 72 72 65 6e 74 2d 6a 6f 62 73 20 28 oncurrent-jobs (
4940: 3e 20 28 2d 20 6d 61 78 2d 63 6f 6e 63 75 72 72 > (- max-concurr
4950: 65 6e 74 2d 6a 6f 62 73 20 6e 75 6d 2d 72 75 6e ent-jobs num-run
4960: 6e 69 6e 67 29 20 35 29 29 29 0a 09 09 20 20 28 ning) 5)))... (
4970: 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f debug:print-info
4980: 20 34 20 22 50 72 65 2d 72 65 67 69 73 74 65 72 4 "Pre-register
4990: 69 6e 67 20 74 65 73 74 20 22 20 74 65 73 74 2d ing test " test-
49a0: 6e 61 6d 65 20 22 2f 22 20 69 74 65 6d 2d 70 61 name "/" item-pa
49b0: 74 68 20 22 20 74 6f 20 63 72 65 61 74 65 20 70 th " to create p
49c0: 6c 61 63 65 68 6f 6c 64 65 72 22 20 29 0a 09 09 laceholder" )...
49d0: 20 20 28 6f 70 65 6e 2d 72 75 6e 2d 63 6c 6f 73 (open-run-clos
49e0: 65 20 64 62 3a 74 65 73 74 73 2d 72 65 67 69 73 e db:tests-regis
49f0: 74 65 72 2d 74 65 73 74 20 23 66 20 72 75 6e 2d ter-test #f run-
4a00: 69 64 20 74 65 73 74 2d 6e 61 6d 65 20 69 74 65 id test-name ite
4a10: 6d 2d 70 61 74 68 29 0a 09 09 20 20 28 68 61 73 m-path)... (has
4a20: 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 74 65 73 h-table-set! tes
4a30: 74 2d 72 65 67 69 73 74 65 72 79 20 28 72 75 6e t-registery (run
4a40: 73 3a 6d 61 6b 65 2d 66 75 6c 6c 2d 74 65 73 74 s:make-full-test
4a50: 2d 6e 61 6d 65 20 74 65 73 74 2d 6e 61 6d 65 20 -name test-name
4a60: 69 74 65 6d 2d 70 61 74 68 29 20 23 74 29 0a 09 item-path) #t)..
4a70: 09 20 20 28 74 68 72 65 61 64 2d 73 6c 65 65 70 . (thread-sleep
4a80: 21 20 2a 67 6c 6f 62 61 6c 2d 64 65 6c 74 61 2a ! *global-delta*
4a90: 29 0a 09 09 20 20 28 6c 6f 6f 70 20 28 63 61 72 )... (loop (car
4aa0: 20 6e 65 77 74 61 6c 29 28 63 64 72 20 6e 65 77 newtal)(cdr new
4ab0: 74 61 6c 29 20 72 65 72 75 6e 73 29 29 0a 09 09 tal) reruns))...
4ac0: 20 28 28 6e 6f 74 20 68 61 76 65 2d 72 65 73 6f ((not have-reso
4ad0: 75 72 63 65 73 29 20 3b 3b 20 73 69 6d 70 6c 79 urces) ;; simply
4ae0: 20 74 72 79 20 61 67 61 69 6e 20 61 66 74 65 72 try again after
4af0: 20 77 61 69 74 69 6e 67 20 61 20 73 65 63 6f 6e waiting a secon
4b00: 64 0a 09 09 20 20 28 64 65 62 75 67 3a 70 72 69 d... (debug:pri
4b10: 6e 74 2d 69 6e 66 6f 20 31 20 22 6e 6f 20 72 65 nt-info 1 "no re
4b20: 73 6f 75 72 63 65 73 20 74 6f 20 72 75 6e 20 6e sources to run n
4b30: 65 77 20 74 65 73 74 73 2c 20 77 61 69 74 69 6e ew tests, waitin
4b40: 67 20 2e 2e 2e 22 29 0a 09 09 20 20 28 74 68 72 g ...")... (thr
4b50: 65 61 64 2d 73 6c 65 65 70 21 20 28 2b 20 30 2e ead-sleep! (+ 0.
4b60: 30 31 20 2a 67 6c 6f 62 61 6c 2d 64 65 6c 74 61 01 *global-delta
4b70: 2a 29 29 0a 09 09 20 20 3b 3b 20 63 6f 75 6c 64 *))... ;; could
4b80: 20 68 61 76 65 20 64 6f 6e 65 20 68 65 64 20 74 have done hed t
4b90: 61 6c 20 68 65 72 65 20 62 75 74 20 64 6f 69 6e al here but doin
4ba0: 67 20 63 61 72 2f 63 64 72 20 6f 66 20 6e 65 77 g car/cdr of new
4bb0: 74 61 6c 20 74 6f 20 72 6f 74 61 74 65 20 74 65 tal to rotate te
4bc0: 73 74 73 0a 09 09 20 20 28 6c 6f 6f 70 20 28 63 sts... (loop (c
4bd0: 61 72 20 6e 65 77 74 61 6c 29 28 63 64 72 20 6e ar newtal)(cdr n
4be0: 65 77 74 61 6c 29 20 72 65 72 75 6e 73 29 29 0a ewtal) reruns)).
4bf0: 09 09 20 28 28 61 6e 64 20 68 61 76 65 2d 72 65 .. ((and have-re
4c00: 73 6f 75 72 63 65 73 0a 09 09 20 20 20 20 20 20 sources...
4c10: 20 28 6f 72 20 28 6e 75 6c 6c 3f 20 70 72 65 72 (or (null? prer
4c20: 65 71 73 2d 6e 6f 74 2d 6d 65 74 29 0a 09 09 09 eqs-not-met)....
4c30: 20 20 20 28 61 6e 64 20 28 65 71 3f 20 74 65 73 (and (eq? tes
4c40: 74 6d 6f 64 65 20 27 74 6f 70 6c 65 76 65 6c 29 tmode 'toplevel)
4c50: 0a 09 09 09 09 28 6e 75 6c 6c 3f 20 6e 6f 6e 2d .....(null? non-
4c60: 63 6f 6d 70 6c 65 74 65 64 29 29 29 29 0a 09 09 completed))))...
4c70: 20 20 28 72 75 6e 3a 74 65 73 74 20 72 75 6e 2d (run:test run-
4c80: 69 64 20 72 75 6e 6e 61 6d 65 20 6b 65 79 76 61 id runname keyva
4c90: 6c 6c 73 74 20 74 65 73 74 2d 72 65 63 6f 72 64 llst test-record
4ca0: 20 66 6c 61 67 73 20 23 66 29 0a 09 09 20 20 28 flags #f)... (
4cb0: 74 68 72 65 61 64 2d 73 6c 65 65 70 21 20 2a 67 thread-sleep! *g
4cc0: 6c 6f 62 61 6c 2d 64 65 6c 74 61 2a 29 0a 09 09 lobal-delta*)...
4cd0: 20 20 28 69 66 20 28 6e 6f 74 20 28 6e 75 6c 6c (if (not (null
4ce0: 3f 20 74 61 6c 29 29 0a 09 09 20 20 20 20 20 20 ? tal))...
4cf0: 28 6c 6f 6f 70 20 28 63 61 72 20 74 61 6c 29 28 (loop (car tal)(
4d00: 63 64 72 20 74 61 6c 29 20 72 65 72 75 6e 73 29 cdr tal) reruns)
4d10: 29 29 0a 09 09 20 28 65 6c 73 65 20 3b 3b 20 6d ))... (else ;; m
4d20: 75 73 74 20 62 65 20 77 65 20 68 61 76 65 20 75 ust be we have u
4d30: 6e 6d 65 74 20 70 72 65 72 65 71 75 69 73 69 74 nmet prerequisit
4d40: 65 73 0a 09 09 20 20 20 20 28 64 65 62 75 67 3a es... (debug:
4d50: 70 72 69 6e 74 20 34 20 22 46 41 49 4c 53 3a 20 print 4 "FAILS:
4d60: 22 20 66 61 69 6c 73 29 0a 09 09 20 20 20 20 3b " fails)... ;
4d70: 3b 20 49 66 20 6f 6e 65 20 6f 72 20 6d 6f 72 65 ; If one or more
4d80: 20 6f 66 20 74 68 65 20 70 72 65 72 65 71 73 2d of the prereqs-
4d90: 6e 6f 74 2d 6d 65 74 20 61 72 65 20 46 41 49 4c not-met are FAIL
4da0: 20 74 68 65 6e 20 77 65 20 63 61 6e 20 69 73 73 then we can iss
4db0: 75 65 0a 09 09 20 20 20 20 3b 3b 20 61 20 6d 65 ue... ;; a me
4dc0: 73 73 61 67 65 20 61 6e 64 20 64 72 6f 70 20 68 ssage and drop h
4dd0: 65 64 20 66 72 6f 6d 20 74 68 65 20 69 74 65 6d ed from the item
4de0: 73 20 74 6f 20 62 65 20 70 72 6f 63 65 73 73 65 s to be processe
4df0: 64 2e 0a 09 09 20 20 20 20 28 69 66 20 28 6e 75 d.... (if (nu
4e00: 6c 6c 3f 20 66 61 69 6c 73 29 0a 09 09 09 28 62 ll? fails)....(b
4e10: 65 67 69 6e 0a 09 09 09 20 20 3b 3b 20 63 6f 75 egin.... ;; cou
4e20: 6c 64 6e 27 74 20 72 75 6e 2c 20 74 61 6b 65 20 ldn't run, take
4e30: 61 20 62 72 65 61 74 68 65 72 0a 09 09 09 20 20 a breather....
4e40: 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 (debug:print-inf
4e50: 6f 20 34 20 22 53 68 6f 75 6c 64 6e 27 74 20 72 o 4 "Shouldn't r
4e60: 65 61 6c 6c 79 20 67 65 74 20 68 65 72 65 2c 20 eally get here,
4e70: 72 61 63 65 20 63 6f 6e 64 69 74 69 6f 6e 3f 20 race condition?
4e80: 55 6e 61 62 6c 65 20 74 6f 20 6c 61 75 6e 63 68 Unable to launch
4e90: 20 6d 6f 72 65 20 74 65 73 74 73 20 61 74 20 74 more tests at t
4ea0: 68 69 73 20 6d 6f 6d 65 6e 74 2c 20 6b 69 6c 6c his moment, kill
4eb0: 69 6e 67 20 74 69 6d 65 20 2e 2e 2e 22 29 0a 09 ing time ...")..
4ec0: 09 09 20 20 28 74 68 72 65 61 64 2d 73 6c 65 65 .. (thread-slee
4ed0: 70 21 20 28 2b 20 30 2e 30 31 20 2a 67 6c 6f 62 p! (+ 0.01 *glob
4ee0: 61 6c 2d 64 65 6c 74 61 2a 29 29 20 3b 3b 20 6c al-delta*)) ;; l
4ef0: 6f 6e 67 20 73 6c 65 65 70 20 68 65 72 65 20 2d ong sleep here -
4f00: 20 6e 6f 20 72 65 73 6f 75 72 63 65 73 2c 20 6d no resources, m
4f10: 61 79 20 61 73 20 77 65 6c 6c 20 62 65 20 70 61 ay as well be pa
4f20: 74 69 65 6e 74 0a 09 09 09 20 20 3b 3b 20 77 65 tient.... ;; we
4f30: 20 6d 61 64 65 20 6e 65 77 20 74 61 6c 20 62 79 made new tal by
4f40: 20 73 74 69 63 6b 69 6e 67 20 68 65 64 20 61 74 sticking hed at
4f50: 20 74 68 65 20 62 61 63 6b 20 6f 66 20 74 68 65 the back of the
4f60: 20 6c 69 73 74 0a 09 09 09 20 20 28 6c 6f 6f 70 list.... (loop
4f70: 20 28 63 61 72 20 6e 65 77 74 61 6c 29 28 63 64 (car newtal)(cd
4f80: 72 20 6e 65 77 74 61 6c 29 20 72 65 72 75 6e 73 r newtal) reruns
4f90: 29 29 0a 09 09 09 3b 3b 20 74 68 65 20 77 61 69 ))....;; the wai
4fa0: 74 6f 6e 20 69 73 20 46 41 49 4c 20 73 6f 20 6e ton is FAIL so n
4fb0: 6f 20 70 6f 69 6e 74 20 69 6e 20 74 72 79 69 6e o point in tryin
4fc0: 67 20 74 6f 20 72 75 6e 20 68 65 64 20 65 76 65 g to run hed eve
4fd0: 72 20 61 67 61 69 6e 0a 09 09 09 28 69 66 20 28 r again....(if (
4fe0: 6e 6f 74 20 28 6e 75 6c 6c 3f 20 74 61 6c 29 29 not (null? tal))
4ff0: 0a 09 09 09 20 20 20 20 28 69 66 20 28 76 65 63 .... (if (vec
5000: 74 6f 72 3f 20 68 65 64 29 0a 09 09 09 09 28 62 tor? hed).....(b
5010: 65 67 69 6e 20 28 64 65 62 75 67 3a 70 72 69 6e egin (debug:prin
5020: 74 20 31 20 22 57 41 52 4e 3a 20 44 72 6f 70 70 t 1 "WARN: Dropp
5030: 69 6e 67 20 74 65 73 74 20 22 20 28 64 62 3a 74 ing test " (db:t
5040: 65 73 74 2d 67 65 74 2d 74 65 73 74 6e 61 6d 65 est-get-testname
5050: 20 68 65 64 29 20 22 2f 22 20 28 64 62 3a 74 65 hed) "/" (db:te
5060: 73 74 2d 67 65 74 2d 69 74 65 6d 2d 70 61 74 68 st-get-item-path
5070: 20 68 65 64 29 0a 09 09 09 09 09 09 20 20 20 20 hed).......
5080: 22 20 66 72 6f 6d 20 74 68 65 20 6c 61 75 6e 63 " from the launc
5090: 68 20 6c 69 73 74 20 61 73 20 69 74 20 68 61 73 h list as it has
50a0: 20 70 72 65 72 65 71 75 69 73 74 65 73 20 74 68 prerequistes th
50b0: 61 74 20 61 72 65 20 46 41 49 4c 22 29 0a 09 09 at are FAIL")...
50c0: 09 09 20 20 20 20 20 20 20 28 74 68 72 65 61 64 .. (thread
50d0: 2d 73 6c 65 65 70 21 20 2a 67 6c 6f 62 61 6c 2d -sleep! *global-
50e0: 64 65 6c 74 61 2a 29 0a 09 09 09 09 20 20 20 20 delta*).....
50f0: 20 20 20 28 6c 6f 6f 70 20 28 63 61 72 20 74 61 (loop (car ta
5100: 6c 29 28 63 64 72 20 74 61 6c 29 20 28 63 6f 6e l)(cdr tal) (con
5110: 73 20 68 65 64 20 72 65 72 75 6e 73 29 29 29 0a s hed reruns))).
5120: 09 09 09 09 28 62 65 67 69 6e 0a 09 09 09 09 20 ....(begin.....
5130: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 31 20 (debug:print 1
5140: 22 57 41 52 4e 3a 20 54 65 73 74 20 6e 6f 74 20 "WARN: Test not
5150: 70 72 6f 63 65 73 73 65 64 20 63 6f 72 72 65 63 processed correc
5160: 74 6c 79 2e 20 43 6f 75 6c 64 20 62 65 20 61 20 tly. Could be a
5170: 72 61 63 65 20 63 6f 6e 64 69 74 69 6f 6e 20 69 race condition i
5180: 6e 20 79 6f 75 72 20 74 65 73 74 20 69 6d 70 6c n your test impl
5190: 65 6d 65 6e 74 61 74 69 6f 6e 3f 20 22 20 68 65 ementation? " he
51a0: 64 29 20 3b 3b 20 20 22 20 61 73 20 69 74 20 68 d) ;; " as it h
51b0: 61 73 20 70 72 65 72 65 71 75 69 73 74 65 73 20 as prerequistes
51c0: 74 68 61 74 20 61 72 65 20 46 41 49 4c 2e 20 28 that are FAIL. (
51d0: 4e 4f 54 45 3a 20 68 65 64 20 69 73 20 6e 6f 74 NOTE: hed is not
51e0: 20 61 20 76 65 63 74 6f 72 29 22 29 0a 09 09 09 a vector)")....
51f0: 09 20 20 28 74 68 72 65 61 64 2d 73 6c 65 65 70 . (thread-sleep
5200: 21 20 28 2b 20 30 2e 30 31 20 2a 67 6c 6f 62 61 ! (+ 0.01 *globa
5210: 6c 2d 64 65 6c 74 61 2a 29 29 0a 09 09 09 09 20 l-delta*)).....
5220: 20 28 6c 6f 6f 70 20 68 65 64 20 74 61 6c 20 72 (loop hed tal r
5230: 65 72 75 6e 73 29 29 29 29 29 29 29 29 29 20 3b eruns))))))))) ;
5240: 3b 20 45 4e 44 20 4f 46 20 49 4e 4e 45 52 20 43 ; END OF INNER C
5250: 4f 4e 44 0a 09 20 20 20 20 20 0a 09 20 20 20 20 OND.. ..
5260: 20 3b 3b 20 63 61 73 65 20 77 68 65 72 65 20 61 ;; case where a
5270: 6e 20 69 74 65 6d 73 20 63 61 6d 65 20 69 6e 20 n items came in
5280: 61 73 20 61 20 6c 69 73 74 20 62 65 65 6e 20 70 as a list been p
5290: 72 6f 63 65 73 73 65 64 0a 09 20 20 20 20 20 28 rocessed.. (
52a0: 28 61 6e 64 20 28 6c 69 73 74 3f 20 69 74 65 6d (and (list? item
52b0: 73 29 20 20 20 20 20 3b 3b 20 74 68 75 73 20 77 s) ;; thus w
52c0: 65 20 6b 6e 6f 77 20 6f 75 72 20 69 74 65 6d 73 e know our items
52d0: 20 61 72 65 20 61 6c 72 65 61 64 79 20 63 61 6c are already cal
52e0: 63 75 6c 61 74 65 64 0a 09 09 20 20 20 28 6e 6f culated... (no
52f0: 74 20 20 20 69 74 65 6d 64 61 74 29 29 20 3b 3b t itemdat)) ;;
5300: 20 61 6e 64 20 6e 6f 74 20 79 65 74 20 65 78 70 and not yet exp
5310: 61 6e 64 65 64 20 69 6e 74 6f 20 74 68 65 20 6c anded into the l
5320: 69 73 74 20 6f 66 20 74 68 69 6e 67 73 20 74 6f ist of things to
5330: 20 62 65 20 64 6f 6e 65 0a 09 20 20 20 20 20 20 be done..
5340: 28 69 66 20 28 61 6e 64 20 28 64 65 62 75 67 3a (if (and (debug:
5350: 64 65 62 75 67 2d 6d 6f 64 65 20 31 29 20 3b 3b debug-mode 1) ;;
5360: 20 28 3e 3d 20 2a 76 65 72 62 6f 73 69 74 79 2a (>= *verbosity*
5370: 20 31 29 0a 09 09 20 20 20 20 20 20 20 28 3e 20 1)... (>
5380: 28 6c 65 6e 67 74 68 20 69 74 65 6d 73 29 20 30 (length items) 0
5390: 29 0a 09 09 20 20 20 20 20 20 20 28 3e 20 28 6c )... (> (l
53a0: 65 6e 67 74 68 20 28 63 61 72 20 69 74 65 6d 73 ength (car items
53b0: 29 29 20 30 29 29 0a 09 09 20 20 28 70 70 20 69 )) 0))... (pp i
53c0: 74 65 6d 73 29 29 0a 09 20 20 20 20 20 20 28 66 tems)).. (f
53d0: 6f 72 2d 65 61 63 68 0a 09 20 20 20 20 20 20 20 or-each..
53e0: 28 6c 61 6d 62 64 61 20 28 6d 79 2d 69 74 65 6d (lambda (my-item
53f0: 64 61 74 29 0a 09 09 20 28 6c 65 74 2a 20 28 28 dat)... (let* ((
5400: 6e 65 77 2d 74 65 73 74 2d 72 65 63 6f 72 64 20 new-test-record
5410: 28 6c 65 74 20 28 28 6e 65 77 72 65 63 20 28 6d (let ((newrec (m
5420: 61 6b 65 2d 74 65 73 74 73 3a 74 65 73 74 71 75 ake-tests:testqu
5430: 65 75 65 29 29 29 0a 09 09 09 09 09 20 20 20 28 eue)))...... (
5440: 76 65 63 74 6f 72 2d 63 6f 70 79 21 20 74 65 73 vector-copy! tes
5450: 74 2d 72 65 63 6f 72 64 20 6e 65 77 72 65 63 29 t-record newrec)
5460: 0a 09 09 09 09 09 20 20 20 6e 65 77 72 65 63 29 ...... newrec)
5470: 29 0a 09 09 09 28 6d 79 2d 69 74 65 6d 2d 70 61 )....(my-item-pa
5480: 74 68 20 28 69 74 65 6d 2d 6c 69 73 74 2d 3e 70 th (item-list->p
5490: 61 74 68 20 6d 79 2d 69 74 65 6d 64 61 74 29 29 ath my-itemdat))
54a0: 29 0a 09 09 20 20 20 28 69 66 20 28 74 65 73 74 )... (if (test
54b0: 73 3a 6d 61 74 63 68 20 74 65 73 74 2d 70 61 74 s:match test-pat
54c0: 74 73 20 68 65 64 20 6d 79 2d 69 74 65 6d 2d 70 ts hed my-item-p
54d0: 61 74 68 29 20 3b 3b 20 28 70 61 74 74 2d 6c 69 ath) ;; (patt-li
54e0: 73 74 2d 6d 61 74 63 68 20 6d 79 2d 69 74 65 6d st-match my-item
54f0: 2d 70 61 74 68 20 69 74 65 6d 2d 70 61 74 74 73 -path item-patts
5500: 29 20 20 20 20 20 20 20 20 20 20 20 3b 3b 20 79 ) ;; y
5510: 65 73 2c 20 77 65 20 77 61 6e 74 20 74 6f 20 70 es, we want to p
5520: 72 6f 63 65 73 73 20 74 68 69 73 20 69 74 65 6d rocess this item
5530: 2c 20 4e 4f 54 45 3a 20 53 68 6f 75 6c 64 20 6e , NOTE: Should n
5540: 6f 74 20 6e 65 65 64 20 74 68 69 73 20 63 68 65 ot need this che
5550: 63 6b 20 68 65 72 65 21 0a 09 09 20 20 20 20 20 ck here!...
5560: 20 20 28 6c 65 74 20 28 28 6e 65 77 74 65 73 74 (let ((newtest
5570: 6e 61 6d 65 20 28 72 75 6e 73 3a 6d 61 6b 65 2d name (runs:make-
5580: 66 75 6c 6c 2d 74 65 73 74 2d 6e 61 6d 65 20 68 full-test-name h
5590: 65 64 20 6d 79 2d 69 74 65 6d 2d 70 61 74 68 29 ed my-item-path)
55a0: 29 29 20 20 20 20 3b 3b 20 74 65 73 74 20 6e 61 )) ;; test na
55b0: 6d 65 73 20 61 72 65 20 75 6e 69 71 75 65 20 6f mes are unique o
55c0: 6e 20 74 65 73 74 6e 61 6d 65 2f 69 74 65 6d 2d n testname/item-
55d0: 70 61 74 68 0a 09 09 09 20 28 74 65 73 74 73 3a path.... (tests:
55e0: 74 65 73 74 71 75 65 75 65 2d 73 65 74 2d 69 74 testqueue-set-it
55f0: 65 6d 73 21 20 20 20 20 20 6e 65 77 2d 74 65 73 ems! new-tes
5600: 74 2d 72 65 63 6f 72 64 20 23 66 29 0a 09 09 09 t-record #f)....
5610: 20 28 74 65 73 74 73 3a 74 65 73 74 71 75 65 75 (tests:testqueu
5620: 65 2d 73 65 74 2d 69 74 65 6d 64 61 74 21 20 20 e-set-itemdat!
5630: 20 6e 65 77 2d 74 65 73 74 2d 72 65 63 6f 72 64 new-test-record
5640: 20 6d 79 2d 69 74 65 6d 64 61 74 29 0a 09 09 09 my-itemdat)....
5650: 20 28 74 65 73 74 73 3a 74 65 73 74 71 75 65 75 (tests:testqueu
5660: 65 2d 73 65 74 2d 69 74 65 6d 5f 70 61 74 68 21 e-set-item_path!
5670: 20 6e 65 77 2d 74 65 73 74 2d 72 65 63 6f 72 64 new-test-record
5680: 20 6d 79 2d 69 74 65 6d 2d 70 61 74 68 29 0a 09 my-item-path)..
5690: 09 09 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 73 .. (hash-table-s
56a0: 65 74 21 20 74 65 73 74 2d 72 65 63 6f 72 64 73 et! test-records
56b0: 20 6e 65 77 74 65 73 74 6e 61 6d 65 20 6e 65 77 newtestname new
56c0: 2d 74 65 73 74 2d 72 65 63 6f 72 64 29 0a 09 09 -test-record)...
56d0: 09 20 28 73 65 74 21 20 74 61 6c 20 28 63 6f 6e . (set! tal (con
56e0: 73 20 6e 65 77 74 65 73 74 6e 61 6d 65 20 74 61 s newtestname ta
56f0: 6c 29 29 29 29 29 29 20 3b 3b 20 73 69 6e 63 65 l)))))) ;; since
5700: 20 74 68 65 73 65 20 61 72 65 20 69 74 65 6d 69 these are itemi
5710: 7a 65 64 20 63 72 65 61 74 65 20 6e 65 77 20 74 zed create new t
5720: 65 73 74 20 6e 61 6d 65 73 20 74 65 73 74 6e 61 est names testna
5730: 6d 65 2f 69 74 65 6d 70 61 74 68 0a 09 20 20 20 me/itempath..
5740: 20 20 20 20 69 74 65 6d 73 29 0a 09 20 20 20 20 items)..
5750: 20 20 28 69 66 20 28 6e 6f 74 20 28 6e 75 6c 6c (if (not (null
5760: 3f 20 74 61 6c 29 29 0a 09 09 20 20 28 62 65 67 ? tal))... (beg
5770: 69 6e 0a 09 09 20 20 20 20 28 64 65 62 75 67 3a in... (debug:
5780: 70 72 69 6e 74 2d 69 6e 66 6f 20 34 20 22 45 6e print-info 4 "En
5790: 64 20 6f 66 20 69 74 65 6d 73 20 6c 69 73 74 2c d of items list,
57a0: 20 6c 6f 6f 70 69 6e 67 20 77 69 74 68 20 6e 65 looping with ne
57b0: 78 74 20 61 66 74 65 72 20 73 68 6f 72 74 20 64 xt after short d
57c0: 65 6c 61 79 22 29 0a 09 09 20 20 20 20 28 74 68 elay")... (th
57d0: 72 65 61 64 2d 73 6c 65 65 70 21 20 28 2b 20 30 read-sleep! (+ 0
57e0: 2e 30 31 20 2a 67 6c 6f 62 61 6c 2d 64 65 6c 74 .01 *global-delt
57f0: 61 2a 29 29 0a 09 09 20 20 20 20 28 6c 6f 6f 70 a*))... (loop
5800: 20 28 63 61 72 20 74 61 6c 29 28 63 64 72 20 74 (car tal)(cdr t
5810: 61 6c 29 20 72 65 72 75 6e 73 29 29 29 29 0a 0a al) reruns))))..
5820: 09 20 20 20 20 20 3b 3b 20 69 66 20 69 74 65 6d . ;; if item
5830: 73 20 69 73 20 61 20 70 72 6f 63 20 74 68 65 6e s is a proc then
5840: 20 6e 65 65 64 20 74 6f 20 72 75 6e 20 69 74 65 need to run ite
5850: 6d 73 3a 67 65 74 2d 69 74 65 6d 73 2d 66 72 6f ms:get-items-fro
5860: 6d 2d 63 6f 6e 66 69 67 2c 20 67 65 74 20 74 68 m-config, get th
5870: 65 20 6c 69 73 74 20 61 6e 64 20 6c 6f 6f 70 20 e list and loop
5880: 0a 09 20 20 20 20 20 3b 3b 20 20 20 20 2d 20 62 .. ;; - b
5890: 75 74 20 6f 6e 6c 79 20 64 6f 20 74 68 61 74 20 ut only do that
58a0: 69 66 20 72 65 73 6f 75 72 63 65 73 20 65 78 69 if resources exi
58b0: 73 74 20 74 6f 20 6b 69 63 6b 20 6f 66 66 20 74 st to kick off t
58c0: 68 65 20 6a 6f 62 0a 09 20 20 20 20 20 28 28 6f he job.. ((o
58d0: 72 20 28 70 72 6f 63 65 64 75 72 65 3f 20 69 74 r (procedure? it
58e0: 65 6d 73 29 28 65 71 3f 20 69 74 65 6d 73 20 27 ems)(eq? items '
58f0: 68 61 76 65 2d 70 72 6f 63 65 64 75 72 65 29 29 have-procedure))
5900: 0a 09 20 20 20 20 20 20 28 6c 65 74 20 28 28 63 .. (let ((c
5910: 61 6e 2d 72 75 6e 2d 6d 6f 72 65 20 20 20 20 28 an-run-more (
5920: 72 75 6e 73 3a 63 61 6e 2d 72 75 6e 2d 6d 6f 72 runs:can-run-mor
5930: 65 2d 74 65 73 74 73 20 74 65 73 74 2d 72 65 63 e-tests test-rec
5940: 6f 72 64 29 29 29 0a 09 09 28 69 66 20 63 61 6e ord)))...(if can
5950: 2d 72 75 6e 2d 6d 6f 72 65 0a 09 09 20 20 20 20 -run-more...
5960: 28 6c 65 74 2a 20 28 28 70 72 65 72 65 71 73 2d (let* ((prereqs-
5970: 6e 6f 74 2d 6d 65 74 20 28 6f 70 65 6e 2d 72 75 not-met (open-ru
5980: 6e 2d 63 6c 6f 73 65 20 64 62 3a 67 65 74 2d 70 n-close db:get-p
5990: 72 65 72 65 71 73 2d 6e 6f 74 2d 6d 65 74 20 23 rereqs-not-met #
59a0: 66 20 72 75 6e 2d 69 64 20 77 61 69 74 6f 6e 73 f run-id waitons
59b0: 20 69 74 65 6d 2d 70 61 74 68 20 6d 6f 64 65 3a item-path mode:
59c0: 20 74 65 73 74 6d 6f 64 65 29 29 0a 09 09 09 20 testmode))....
59d0: 20 20 28 66 61 69 6c 73 20 20 20 20 20 20 20 20 (fails
59e0: 20 20 20 28 72 75 6e 73 3a 63 61 6c 63 2d 66 61 (runs:calc-fa
59f0: 69 6c 73 20 70 72 65 72 65 71 73 2d 6e 6f 74 2d ils prereqs-not-
5a00: 6d 65 74 29 29 0a 09 09 09 20 20 20 28 6e 6f 6e met)).... (non
5a10: 2d 63 6f 6d 70 6c 65 74 65 64 20 20 20 28 72 75 -completed (ru
5a20: 6e 73 3a 63 61 6c 63 2d 6e 6f 74 2d 63 6f 6d 70 ns:calc-not-comp
5a30: 6c 65 74 65 64 20 70 72 65 72 65 71 73 2d 6e 6f leted prereqs-no
5a40: 74 2d 6d 65 74 29 29 29 0a 09 09 20 20 20 20 20 t-met)))...
5a50: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e (debug:print-in
5a60: 66 6f 20 38 20 22 63 61 6e 2d 72 75 6e 2d 6d 6f fo 8 "can-run-mo
5a70: 72 65 3a 20 22 20 63 61 6e 2d 72 75 6e 2d 6d 6f re: " can-run-mo
5a80: 72 65 0a 09 09 09 09 20 20 20 22 5c 6e 20 74 65 re..... "\n te
5a90: 73 74 6e 61 6d 65 3a 20 20 20 20 20 20 20 20 22 stname: "
5aa0: 20 68 65 64 0a 09 09 09 09 20 20 20 22 5c 6e 20 hed..... "\n
5ab0: 70 72 65 72 65 71 73 2d 6e 6f 74 2d 6d 65 74 3a prereqs-not-met:
5ac0: 20 22 20 28 72 75 6e 73 3a 70 72 65 74 74 79 2d " (runs:pretty-
5ad0: 73 74 72 69 6e 67 20 70 72 65 72 65 71 73 2d 6e string prereqs-n
5ae0: 6f 74 2d 6d 65 74 29 0a 09 09 09 09 20 20 20 22 ot-met)..... "
5af0: 5c 6e 20 6e 6f 6e 2d 63 6f 6d 70 6c 65 74 65 64 \n non-completed
5b00: 3a 20 20 20 22 20 28 72 75 6e 73 3a 70 72 65 74 : " (runs:pret
5b10: 74 79 2d 73 74 72 69 6e 67 20 6e 6f 6e 2d 63 6f ty-string non-co
5b20: 6d 70 6c 65 74 65 64 29 20 0a 09 09 09 09 20 20 mpleted) .....
5b30: 20 22 5c 6e 20 66 61 69 6c 73 3a 20 20 20 20 20 "\n fails:
5b40: 20 20 20 20 20 20 22 20 28 72 75 6e 73 3a 70 72 " (runs:pr
5b50: 65 74 74 79 2d 73 74 72 69 6e 67 20 66 61 69 6c etty-string fail
5b60: 73 29 0a 09 09 09 09 20 20 20 22 5c 6e 20 74 65 s)..... "\n te
5b70: 73 74 6d 6f 64 65 3a 20 20 20 20 20 20 20 20 22 stmode: "
5b80: 20 74 65 73 74 6d 6f 64 65 0a 09 09 09 09 20 20 testmode.....
5b90: 20 22 5c 6e 20 6e 75 6d 2d 72 65 74 72 69 65 73 "\n num-retries
5ba0: 3a 20 20 20 20 20 22 20 6e 75 6d 2d 72 65 74 72 : " num-retr
5bb0: 69 65 73 0a 09 09 09 09 20 20 20 22 5c 6e 20 28 ies..... "\n (
5bc0: 65 71 3f 20 74 65 73 74 6d 6f 64 65 20 27 74 6f eq? testmode 'to
5bd0: 70 6c 65 76 65 6c 29 3a 20 22 20 28 65 71 3f 20 plevel): " (eq?
5be0: 74 65 73 74 6d 6f 64 65 20 27 74 6f 70 6c 65 76 testmode 'toplev
5bf0: 65 6c 29 0a 09 09 09 09 20 20 20 22 5c 6e 20 28 el)..... "\n (
5c00: 6e 75 6c 6c 3f 20 6e 6f 6e 2d 63 6f 6d 70 6c 65 null? non-comple
5c10: 74 65 64 29 3a 20 20 20 20 22 20 28 6e 75 6c 6c ted): " (null
5c20: 3f 20 6e 6f 6e 2d 63 6f 6d 70 6c 65 74 65 64 29 ? non-completed)
5c30: 0a 09 09 09 09 20 20 20 22 5c 6e 20 72 65 72 75 ..... "\n reru
5c40: 6e 73 3a 20 20 20 20 20 20 20 20 20 20 22 20 72 ns: " r
5c50: 65 72 75 6e 73 0a 09 09 09 09 20 20 20 22 5c 6e eruns..... "\n
5c60: 20 69 74 65 6d 73 3a 20 20 20 20 20 20 20 20 20 items:
5c70: 20 20 22 20 69 74 65 6d 73 0a 09 09 09 09 20 20 " items.....
5c80: 20 22 5c 6e 20 63 61 6e 2d 72 75 6e 2d 6d 6f 72 "\n can-run-mor
5c90: 65 3a 20 20 20 20 22 20 63 61 6e 2d 72 75 6e 2d e: " can-run-
5ca0: 6d 6f 72 65 29 0a 09 09 20 20 20 20 20 20 3b 3b more)... ;;
5cb0: 20 28 74 68 72 65 61 64 2d 73 6c 65 65 70 21 20 (thread-sleep!
5cc0: 28 2b 20 30 2e 30 31 20 2a 67 6c 6f 62 61 6c 2d (+ 0.01 *global-
5cd0: 64 65 6c 74 61 2a 29 29 0a 09 09 20 20 20 20 20 delta*))...
5ce0: 20 28 63 6f 6e 64 20 3b 3b 20 49 4e 4e 45 52 20 (cond ;; INNER
5cf0: 43 4f 4e 44 20 23 32 0a 09 09 20 20 20 20 20 20 COND #2...
5d00: 20 28 28 6f 72 20 28 6e 75 6c 6c 3f 20 70 72 65 ((or (null? pre
5d10: 72 65 71 73 2d 6e 6f 74 2d 6d 65 74 29 20 3b 3b reqs-not-met) ;;
5d20: 20 61 6c 6c 20 70 72 65 72 65 71 73 20 6d 65 74 all prereqs met
5d30: 2c 20 66 69 72 65 20 6f 66 66 20 74 68 65 20 74 , fire off the t
5d40: 65 73 74 0a 09 09 09 20 20 20 20 3b 3b 20 6f 72 est.... ;; or
5d50: 2c 20 69 66 20 69 74 20 69 73 20 61 20 27 74 6f , if it is a 'to
5d60: 70 6c 65 76 65 6c 20 74 65 73 74 20 61 6e 64 20 plevel test and
5d70: 61 6c 6c 20 70 72 65 72 65 71 73 20 6e 6f 74 20 all prereqs not
5d80: 6d 65 74 20 61 72 65 20 43 4f 4d 50 4c 45 54 45 met are COMPLETE
5d90: 44 20 74 68 65 6e 20 6c 61 75 6e 63 68 0a 09 09 D then launch...
5da0: 09 20 20 20 20 28 61 6e 64 20 28 65 71 3f 20 74 . (and (eq? t
5db0: 65 73 74 6d 6f 64 65 20 27 74 6f 70 6c 65 76 65 estmode 'topleve
5dc0: 6c 29 0a 09 09 09 09 20 28 6e 75 6c 6c 3f 20 6e l)..... (null? n
5dd0: 6f 6e 2d 63 6f 6d 70 6c 65 74 65 64 29 29 29 0a on-completed))).
5de0: 09 09 09 28 6c 65 74 20 28 28 74 65 73 74 2d 6e ...(let ((test-n
5df0: 61 6d 65 20 28 74 65 73 74 73 3a 74 65 73 74 71 ame (tests:testq
5e00: 75 65 75 65 2d 67 65 74 2d 74 65 73 74 6e 61 6d ueue-get-testnam
5e10: 65 20 74 65 73 74 2d 72 65 63 6f 72 64 29 29 29 e test-record)))
5e20: 0a 09 09 09 20 20 28 73 65 74 65 6e 76 20 22 4d .... (setenv "M
5e30: 54 5f 54 45 53 54 5f 4e 41 4d 45 22 20 74 65 73 T_TEST_NAME" tes
5e40: 74 2d 6e 61 6d 65 29 20 3b 3b 20 0a 09 09 09 20 t-name) ;; ....
5e50: 20 28 73 65 74 65 6e 76 20 22 4d 54 5f 52 55 4e (setenv "MT_RUN
5e60: 4e 41 4d 45 22 20 20 20 72 75 6e 6e 61 6d 65 29 NAME" runname)
5e70: 0a 09 09 09 20 20 28 73 65 74 2d 6d 65 67 61 74 .... (set-megat
5e80: 65 73 74 2d 65 6e 76 2d 76 61 72 73 20 72 75 6e est-env-vars run
5e90: 2d 69 64 29 20 3b 3b 20 74 68 65 73 65 20 6d 61 -id) ;; these ma
5ea0: 79 20 62 65 20 6e 65 65 64 65 64 20 62 79 20 74 y be needed by t
5eb0: 68 65 20 6c 61 75 6e 63 68 69 6e 67 20 70 72 6f he launching pro
5ec0: 63 65 73 73 0a 09 09 09 20 20 28 6c 65 74 20 28 cess.... (let (
5ed0: 28 69 74 65 6d 73 2d 6c 69 73 74 20 28 69 74 65 (items-list (ite
5ee0: 6d 73 3a 67 65 74 2d 69 74 65 6d 73 2d 66 72 6f ms:get-items-fro
5ef0: 6d 2d 63 6f 6e 66 69 67 20 74 63 6f 6e 66 69 67 m-config tconfig
5f00: 29 29 29 0a 09 09 09 20 20 20 20 28 69 66 20 28 ))).... (if (
5f10: 6c 69 73 74 3f 20 69 74 65 6d 73 2d 6c 69 73 74 list? items-list
5f20: 29 0a 09 09 09 09 28 62 65 67 69 6e 0a 09 09 09 ).....(begin....
5f30: 09 20 20 28 74 65 73 74 73 3a 74 65 73 74 71 75 . (tests:testqu
5f40: 65 75 65 2d 73 65 74 2d 69 74 65 6d 73 21 20 74 eue-set-items! t
5f50: 65 73 74 2d 72 65 63 6f 72 64 20 69 74 65 6d 73 est-record items
5f60: 2d 6c 69 73 74 29 0a 09 09 09 09 20 20 28 74 68 -list)..... (th
5f70: 72 65 61 64 2d 73 6c 65 65 70 21 20 2a 67 6c 6f read-sleep! *glo
5f80: 62 61 6c 2d 64 65 6c 74 61 2a 29 0a 09 09 09 09 bal-delta*).....
5f90: 20 20 28 6c 6f 6f 70 20 68 65 64 20 74 61 6c 20 (loop hed tal
5fa0: 72 65 72 75 6e 73 29 29 0a 09 09 09 09 28 62 65 reruns)).....(be
5fb0: 67 69 6e 0a 09 09 09 09 20 20 28 64 65 62 75 67 gin..... (debug
5fc0: 3a 70 72 69 6e 74 20 30 20 22 45 52 52 4f 52 3a :print 0 "ERROR:
5fd0: 20 54 68 65 20 70 72 6f 63 20 66 72 6f 6d 20 72 The proc from r
5fe0: 65 61 64 69 6e 67 20 74 68 65 20 73 65 74 75 70 eading the setup
5ff0: 20 64 69 64 20 6e 6f 74 20 79 69 65 6c 64 20 61 did not yield a
6000: 20 6c 69 73 74 20 2d 20 70 6c 65 61 73 65 20 72 list - please r
6010: 65 70 6f 72 74 20 74 68 69 73 22 29 0a 09 09 09 eport this")....
6020: 09 20 20 28 65 78 69 74 20 31 29 29 29 29 29 29 . (exit 1))))))
6030: 0a 09 09 20 20 20 20 20 20 20 28 28 6e 75 6c 6c ... ((null
6040: 3f 20 66 61 69 6c 73 29 0a 09 09 09 28 64 65 62 ? fails)....(deb
6050: 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 34 20 ug:print-info 4
6060: 22 66 61 69 6c 73 20 69 73 20 6e 75 6c 6c 2c 20 "fails is null,
6070: 6d 6f 76 69 6e 67 20 6f 6e 20 69 6e 20 74 68 65 moving on in the
6080: 20 71 75 65 75 65 20 62 75 74 20 6b 65 65 70 69 queue but keepi
6090: 6e 67 20 22 20 68 65 64 20 22 20 66 6f 72 20 6e ng " hed " for n
60a0: 6f 77 22 29 0a 09 09 09 3b 3b 20 6f 6e 6c 79 20 ow")....;; only
60b0: 69 6e 63 72 65 6d 65 6e 74 20 6e 75 6d 2d 72 65 increment num-re
60c0: 74 72 69 65 73 20 77 68 65 6e 20 74 68 65 72 65 tries when there
60d0: 20 61 72 65 20 6e 6f 20 74 65 73 74 73 20 72 75 are no tests ru
60e0: 6e 69 6e 67 0a 09 09 09 28 69 66 20 28 65 71 3f ning....(if (eq?
60f0: 20 30 20 28 6c 69 73 74 2d 72 65 66 20 63 61 6e 0 (list-ref can
6100: 2d 72 75 6e 2d 6d 6f 72 65 20 31 29 29 0a 09 09 -run-more 1))...
6110: 09 20 20 20 20 28 62 65 67 69 6e 0a 09 09 09 20 . (begin....
6120: 20 20 20 20 20 28 69 66 20 28 3e 20 6e 75 6d 2d (if (> num-
6130: 72 65 74 72 69 65 73 20 31 30 30 29 20 3b 3b 20 retries 100) ;;
6140: 66 69 72 73 74 20 31 30 30 20 72 65 74 72 69 65 first 100 retrie
6150: 73 20 61 72 65 20 6c 6f 77 20 74 69 6d 65 20 63 s are low time c
6160: 6f 73 74 0a 09 09 09 09 20 20 28 74 68 72 65 61 ost..... (threa
6170: 64 2d 73 6c 65 65 70 21 20 28 2b 20 32 20 2a 67 d-sleep! (+ 2 *g
6180: 6c 6f 62 61 6c 2d 64 65 6c 74 61 2a 29 29 0a 09 lobal-delta*))..
6190: 09 09 09 20 20 28 74 68 72 65 61 64 2d 73 6c 65 ... (thread-sle
61a0: 65 70 21 20 28 2b 20 30 2e 30 31 20 2a 67 6c 6f ep! (+ 0.01 *glo
61b0: 62 61 6c 2d 64 65 6c 74 61 2a 29 29 29 0a 09 09 bal-delta*)))...
61c0: 09 20 20 20 20 20 20 28 73 65 74 21 20 6e 75 6d . (set! num
61d0: 2d 72 65 74 72 69 65 73 20 28 2b 20 6e 75 6d 2d -retries (+ num-
61e0: 72 65 74 72 69 65 73 20 31 29 29 29 29 0a 09 09 retries 1))))...
61f0: 09 28 69 66 20 28 3e 20 6e 75 6d 2d 72 65 74 72 .(if (> num-retr
6200: 69 65 73 20 20 6d 61 78 2d 72 65 74 72 69 65 73 ies max-retries
6210: 29 0a 09 09 09 20 20 20 20 28 69 66 20 28 6e 6f ).... (if (no
6220: 74 20 28 6e 75 6c 6c 3f 20 74 61 6c 29 29 0a 09 t (null? tal))..
6230: 09 09 09 28 6c 6f 6f 70 20 28 63 61 72 20 74 61 ...(loop (car ta
6240: 6c 29 28 63 64 72 20 74 61 6c 29 20 72 65 72 75 l)(cdr tal) reru
6250: 6e 73 29 29 0a 09 09 09 20 20 20 20 28 6c 6f 6f ns)).... (loo
6260: 70 20 28 63 61 72 20 6e 65 77 74 61 6c 29 28 63 p (car newtal)(c
6270: 64 72 20 6e 65 77 74 61 6c 29 20 72 65 72 75 6e dr newtal) rerun
6280: 73 29 29 29 20 3b 3b 20 61 6e 20 69 73 73 75 65 s))) ;; an issue
6290: 20 77 69 74 68 20 70 72 65 72 65 71 73 20 6e 6f with prereqs no
62a0: 74 20 79 65 74 20 6d 65 74 3f 0a 09 09 20 20 20 t yet met?...
62b0: 20 20 20 20 28 28 61 6e 64 20 28 6e 6f 74 20 28 ((and (not (
62c0: 6e 75 6c 6c 3f 20 66 61 69 6c 73 29 29 28 65 71 null? fails))(eq
62d0: 3f 20 74 65 73 74 6d 6f 64 65 20 27 6e 6f 72 6d ? testmode 'norm
62e0: 61 6c 29 29 0a 09 09 09 28 64 65 62 75 67 3a 70 al))....(debug:p
62f0: 72 69 6e 74 2d 69 6e 66 6f 20 31 20 22 74 65 73 rint-info 1 "tes
6300: 74 20 22 20 20 68 65 64 20 22 20 28 6d 6f 64 65 t " hed " (mode
6310: 3d 22 20 74 65 73 74 6d 6f 64 65 20 22 29 20 68 =" testmode ") h
6320: 61 73 20 66 61 69 6c 65 64 20 70 72 65 72 65 71 as failed prereq
6330: 75 69 73 69 74 65 28 73 29 3b 20 22 0a 09 09 09 uisite(s); "....
6340: 09 20 20 20 20 20 28 73 74 72 69 6e 67 2d 69 6e . (string-in
6350: 74 65 72 73 70 65 72 73 65 20 28 6d 61 70 20 28 tersperse (map (
6360: 6c 61 6d 62 64 61 20 28 74 29 28 63 6f 6e 63 20 lambda (t)(conc
6370: 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 74 65 73 (db:test-get-tes
6380: 74 6e 61 6d 65 20 74 29 20 22 3a 22 20 28 64 62 tname t) ":" (db
6390: 3a 74 65 73 74 2d 67 65 74 2d 73 74 61 74 65 20 :test-get-state
63a0: 74 29 22 2f 22 28 64 62 3a 74 65 73 74 2d 67 65 t)"/"(db:test-ge
63b0: 74 2d 73 74 61 74 75 73 20 74 29 29 29 20 66 61 t-status t))) fa
63c0: 69 6c 73 29 20 22 2c 20 22 29 0a 09 09 09 09 20 ils) ", ").....
63d0: 20 20 20 20 22 2c 20 72 65 6d 6f 76 69 6e 67 20 ", removing
63e0: 69 74 20 66 72 6f 6d 20 74 6f 2d 64 6f 20 6c 69 it from to-do li
63f0: 73 74 22 29 0a 09 09 09 28 69 66 20 28 6e 6f 74 st")....(if (not
6400: 20 28 6e 75 6c 6c 3f 20 74 61 6c 29 29 0a 09 09 (null? tal))...
6410: 09 20 20 20 20 28 62 65 67 69 6e 0a 09 09 09 20 . (begin....
6420: 20 20 20 20 20 28 74 68 72 65 61 64 2d 73 6c 65 (thread-sle
6430: 65 70 21 20 2a 67 6c 6f 62 61 6c 2d 64 65 6c 74 ep! *global-delt
6440: 61 2a 29 0a 09 09 09 20 20 20 20 20 20 28 6c 6f a*).... (lo
6450: 6f 70 20 28 63 61 72 20 74 61 6c 29 28 63 64 72 op (car tal)(cdr
6460: 20 74 61 6c 29 28 63 6f 6e 73 20 68 65 64 20 72 tal)(cons hed r
6470: 65 72 75 6e 73 29 29 29 29 29 0a 09 09 20 20 20 eruns)))))...
6480: 20 20 20 20 28 65 6c 73 65 0a 09 09 09 28 64 65 (else....(de
6490: 62 75 67 3a 70 72 69 6e 74 20 38 20 22 45 52 52 bug:print 8 "ERR
64a0: 4f 52 3a 20 4e 6f 20 68 61 6e 64 6c 65 72 20 66 OR: No handler f
64b0: 6f 72 20 74 68 69 73 20 63 6f 6e 64 69 74 69 6f or this conditio
64c0: 6e 2e 22 29 0a 09 09 09 28 74 68 72 65 61 64 2d n.")....(thread-
64d0: 73 6c 65 65 70 21 20 28 2b 20 31 20 2a 67 6c 6f sleep! (+ 1 *glo
64e0: 62 61 6c 2d 64 65 6c 74 61 2a 29 29 0a 09 09 09 bal-delta*))....
64f0: 28 6c 6f 6f 70 20 28 63 61 72 20 6e 65 77 74 61 (loop (car newta
6500: 6c 29 28 63 64 72 20 6e 65 77 74 61 6c 29 20 72 l)(cdr newtal) r
6510: 65 72 75 6e 73 29 29 29 29 20 3b 3b 20 45 4e 44 eruns)))) ;; END
6520: 20 4f 46 20 49 46 20 43 41 4e 20 52 55 4e 20 4d OF IF CAN RUN M
6530: 4f 52 45 0a 0a 09 09 20 20 20 20 3b 3b 20 69 66 ORE.... ;; if
6540: 20 63 61 6e 27 74 20 72 75 6e 20 6d 6f 72 65 20 can't run more
6550: 6a 75 73 74 20 6c 6f 6f 70 20 77 69 74 68 20 6e just loop with n
6560: 65 78 74 20 70 6f 73 73 69 62 6c 65 20 74 65 73 ext possible tes
6570: 74 0a 09 09 20 20 20 20 28 62 65 67 69 6e 0a 09 t... (begin..
6580: 09 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 . (debug:pr
6590: 69 6e 74 2d 69 6e 66 6f 20 34 20 22 70 72 6f 63 int-info 4 "proc
65a0: 65 73 73 69 6e 67 20 74 68 65 20 63 61 73 65 20 essing the case
65b0: 77 69 74 68 20 61 20 6c 61 6d 62 64 61 20 66 6f with a lambda fo
65c0: 72 20 69 74 65 6d 73 20 6f 72 20 27 68 61 76 65 r items or 'have
65d0: 2d 70 72 6f 63 65 64 75 72 65 2e 20 4d 6f 76 69 -procedure. Movi
65e0: 6e 67 20 74 68 72 6f 75 67 68 20 74 68 65 20 71 ng through the q
65f0: 75 65 75 65 20 77 69 74 68 6f 75 74 20 64 72 6f ueue without dro
6600: 70 70 69 6e 67 20 22 20 68 65 64 29 0a 09 09 20 pping " hed)...
6610: 20 20 20 20 20 28 74 68 72 65 61 64 2d 73 6c 65 (thread-sle
6620: 65 70 21 20 28 2b 20 31 20 2a 67 6c 6f 62 61 6c ep! (+ 1 *global
6630: 2d 64 65 6c 74 61 2a 29 29 0a 09 09 20 20 20 20 -delta*))...
6640: 20 20 28 6c 6f 6f 70 20 28 63 61 72 20 6e 65 77 (loop (car new
6650: 74 61 6c 29 28 63 64 72 20 6e 65 77 74 61 6c 29 tal)(cdr newtal)
6660: 20 72 65 72 75 6e 73 29 29 29 29 29 20 3b 3b 20 reruns))))) ;;
6670: 45 4e 44 20 4f 46 20 28 6f 72 20 28 70 72 6f 63 END OF (or (proc
6680: 65 64 75 72 65 3f 20 69 74 65 6d 73 29 28 65 71 edure? items)(eq
6690: 3f 20 69 74 65 6d 73 20 27 68 61 76 65 2d 70 72 ? items 'have-pr
66a0: 6f 63 65 64 75 72 65 29 29 0a 09 20 20 20 20 20 ocedure))..
66b0: 0a 09 20 20 20 20 20 3b 3b 20 74 68 69 73 20 63 .. ;; this c
66c0: 61 73 65 20 73 68 6f 75 6c 64 20 6e 6f 74 20 68 ase should not h
66d0: 61 70 70 65 6e 2c 20 61 64 64 65 64 20 74 6f 20 appen, added to
66e0: 68 65 6c 70 20 63 61 74 63 68 20 61 6e 79 20 62 help catch any b
66f0: 75 67 73 0a 09 20 20 20 20 20 28 28 61 6e 64 20 ugs.. ((and
6700: 28 6c 69 73 74 3f 20 69 74 65 6d 73 29 20 69 74 (list? items) it
6710: 65 6d 64 61 74 29 0a 09 20 20 20 20 20 20 28 64 emdat).. (d
6720: 65 62 75 67 3a 70 72 69 6e 74 20 30 20 22 45 52 ebug:print 0 "ER
6730: 52 4f 52 3a 20 53 68 6f 75 6c 64 20 6e 6f 74 20 ROR: Should not
6740: 68 61 76 65 20 61 20 6c 69 73 74 20 6f 66 20 69 have a list of i
6750: 74 65 6d 73 20 69 6e 20 61 20 74 65 73 74 20 61 tems in a test a
6760: 6e 64 20 74 68 65 20 69 74 65 6d 73 70 61 74 68 nd the itemspath
6770: 20 73 65 74 20 2d 20 70 6c 65 61 73 65 20 72 65 set - please re
6780: 70 6f 72 74 20 74 68 69 73 22 29 0a 09 20 20 20 port this")..
6790: 20 20 20 28 65 78 69 74 20 31 29 29 0a 09 20 20 (exit 1))..
67a0: 20 20 20 28 28 6e 6f 74 20 28 6e 75 6c 6c 3f 20 ((not (null?
67b0: 72 65 72 75 6e 73 29 29 0a 09 20 20 20 20 20 20 reruns))..
67c0: 28 6c 65 74 2a 20 28 28 6e 65 77 6c 73 74 20 28 (let* ((newlst (
67d0: 74 65 73 74 73 3a 66 69 6c 74 65 72 2d 6e 6f 6e tests:filter-non
67e0: 2d 72 75 6e 6e 61 62 6c 65 20 72 75 6e 2d 69 64 -runnable run-id
67f0: 20 74 61 6c 20 74 65 73 74 2d 72 65 63 6f 72 64 tal test-record
6800: 73 29 29 20 3b 3b 20 69 2e 65 2e 20 6e 6f 74 20 s)) ;; i.e. not
6810: 46 41 49 4c 2c 20 57 41 49 56 45 44 2c 20 49 4e FAIL, WAIVED, IN
6820: 43 4f 4d 50 4c 45 54 45 2c 20 50 41 53 53 2c 20 COMPLETE, PASS,
6830: 4b 49 4c 4c 45 44 2c 0a 09 09 20 20 20 20 20 28 KILLED,... (
6840: 6a 75 6e 6b 65 64 20 28 6c 73 65 74 2d 64 69 66 junked (lset-dif
6850: 66 65 72 65 6e 63 65 20 65 71 75 61 6c 3f 20 74 ference equal? t
6860: 61 6c 20 6e 65 77 6c 73 74 29 29 29 0a 09 09 28 al newlst)))...(
6870: 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f debug:print-info
6880: 20 34 20 22 66 75 6c 6c 20 64 72 6f 70 20 74 68 4 "full drop th
6890: 72 6f 75 67 68 2c 20 69 66 20 72 65 72 75 6e 73 rough, if reruns
68a0: 20 69 73 20 6c 65 73 73 20 74 68 61 6e 20 31 30 is less than 10
68b0: 30 20 77 65 20 77 69 6c 6c 20 66 6f 72 63 65 20 0 we will force
68c0: 72 65 74 72 79 20 74 68 65 6d 2c 20 72 65 72 75 retry them, reru
68d0: 6e 73 3d 22 20 72 65 72 75 6e 73 20 22 2c 20 74 ns=" reruns ", t
68e0: 61 6c 3d 22 20 74 61 6c 29 0a 09 09 28 69 66 20 al=" tal)...(if
68f0: 28 3c 20 6e 75 6d 2d 72 65 74 72 69 65 73 20 6d (< num-retries m
6900: 61 78 2d 72 65 74 72 69 65 73 29 0a 09 09 20 20 ax-retries)...
6910: 20 20 28 73 65 74 21 20 6e 65 77 6c 73 74 20 28 (set! newlst (
6920: 61 70 70 65 6e 64 20 72 65 72 75 6e 73 20 6e 65 append reruns ne
6930: 77 6c 73 74 29 29 29 0a 09 09 28 73 65 74 21 20 wlst)))...(set!
6940: 6e 75 6d 2d 72 65 74 72 69 65 73 20 28 2b 20 6e num-retries (+ n
6950: 75 6d 2d 72 65 74 72 69 65 73 20 31 29 29 0a 09 um-retries 1))..
6960: 09 28 74 68 72 65 61 64 2d 73 6c 65 65 70 21 20 .(thread-sleep!
6970: 28 2b 20 31 20 2a 67 6c 6f 62 61 6c 2d 64 65 6c (+ 1 *global-del
6980: 74 61 2a 29 29 0a 09 09 28 69 66 20 28 6e 6f 74 ta*))...(if (not
6990: 20 28 6e 75 6c 6c 3f 20 6e 65 77 6c 73 74 29 29 (null? newlst))
69a0: 0a 09 09 20 20 20 20 3b 3b 20 73 69 6e 63 65 20 ... ;; since
69b0: 72 65 72 75 6e 73 20 68 61 76 65 20 62 65 65 6e reruns have been
69c0: 20 74 61 63 6b 65 64 20 6f 6e 20 74 6f 20 6e 65 tacked on to ne
69d0: 77 6c 73 74 20 63 72 65 61 74 65 20 6e 65 77 20 wlst create new
69e0: 72 65 72 75 6e 73 20 66 72 6f 6d 20 6a 75 6e 6b reruns from junk
69f0: 65 64 0a 09 09 20 20 20 20 28 6c 6f 6f 70 20 28 ed... (loop (
6a00: 63 61 72 20 6e 65 77 6c 73 74 29 28 63 64 72 20 car newlst)(cdr
6a10: 6e 65 77 6c 73 74 29 28 64 65 6c 65 74 65 2d 64 newlst)(delete-d
6a20: 75 70 6c 69 63 61 74 65 73 20 6a 75 6e 6b 65 64 uplicates junked
6a30: 29 29 29 29 29 0a 09 20 20 20 20 20 28 28 6e 6f ))))).. ((no
6a40: 74 20 28 6e 75 6c 6c 3f 20 74 61 6c 29 29 0a 09 t (null? tal))..
6a50: 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 (debug:pri
6a60: 6e 74 2d 69 6e 66 6f 20 34 20 22 49 27 6d 20 70 nt-info 4 "I'm p
6a70: 72 65 74 74 79 20 73 75 72 65 20 49 20 73 68 6f retty sure I sho
6a80: 75 6c 64 6e 27 74 20 67 65 74 20 68 65 72 65 2e uldn't get here.
6a90: 22 29 29 0a 09 20 20 20 20 20 28 65 6c 73 65 0a ")).. (else.
6aa0: 09 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 . (debug:pr
6ab0: 69 6e 74 2d 69 6e 66 6f 20 34 20 22 45 78 69 74 int-info 4 "Exit
6ac0: 69 6e 67 20 6c 6f 6f 70 20 77 69 74 68 2e 2e 2e ing loop with...
6ad0: 5c 6e 20 20 68 65 64 3d 22 20 68 65 64 20 22 5c \n hed=" hed "\
6ae0: 6e 20 20 74 61 6c 3d 22 20 74 61 6c 20 22 5c 6e n tal=" tal "\n
6af0: 20 20 72 65 72 75 6e 73 3d 22 20 72 65 72 75 6e reruns=" rerun
6b00: 73 29 29 0a 09 20 20 20 20 20 29 29 29 29 20 3b s)).. )))) ;
6b10: 3b 20 4c 45 54 2a 20 28 28 74 65 73 74 2d 72 65 ; LET* ((test-re
6b20: 63 6f 72 64 0a 0a 20 20 20 20 3b 3b 20 77 65 20 cord.. ;; we
6b30: 67 65 74 20 68 65 72 65 20 6f 6e 20 22 64 72 6f get here on "dro
6b40: 70 20 74 68 72 6f 75 67 68 22 20 2d 20 6c 6f 6f p through" - loo
6b50: 70 20 66 6f 72 20 6e 65 78 74 20 74 65 73 74 20 p for next test
6b60: 69 6e 20 71 75 65 75 65 0a 20 20 20 20 3b 3b 20 in queue. ;;
6b70: 46 49 58 4d 45 21 21 21 21 20 54 48 49 53 20 53 FIXME!!!! THIS S
6b80: 48 4f 55 4c 44 20 4e 4f 54 20 52 45 51 55 49 52 HOULD NOT REQUIR
6b90: 45 20 41 4e 20 45 58 49 54 21 21 21 21 21 21 21 E AN EXIT!!!!!!!
6ba0: 0a 20 20 20 20 0a 20 20 20 20 28 64 65 62 75 67 . . (debug
6bb0: 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 31 20 22 41 :print-info 1 "A
6bc0: 6c 6c 20 74 65 73 74 73 20 6c 61 75 6e 63 68 65 ll tests launche
6bd0: 64 22 29 0a 20 20 20 20 28 74 68 72 65 61 64 2d d"). (thread-
6be0: 73 6c 65 65 70 21 20 30 2e 35 29 0a 20 20 20 20 sleep! 0.5).
6bf0: 3b 3b 20 46 49 58 4d 45 21 20 54 68 69 73 20 68 ;; FIXME! This h
6c00: 61 72 73 68 20 65 78 69 74 20 73 68 6f 75 6c 64 arsh exit should
6c10: 20 6e 6f 74 20 62 65 20 6e 65 63 65 73 73 61 72 not be necessar
6c20: 79 2e 2e 2e 2e 0a 20 20 20 20 3b 3b 20 28 69 66 y..... ;; (if
6c30: 20 28 6e 6f 74 20 2a 72 75 6e 72 65 6d 6f 74 65 (not *runremote
6c40: 2a 29 28 65 78 69 74 29 29 20 3b 3b 20 0a 20 20 *)(exit)) ;; .
6c50: 20 20 23 66 29 29 20 3b 3b 20 72 65 74 75 72 6e #f)) ;; return
6c60: 20 61 20 23 66 20 61 73 20 61 20 68 69 6e 74 20 a #f as a hint
6c70: 74 68 61 74 20 77 65 20 61 72 65 20 64 6f 6e 65 that we are done
6c80: 0a 20 20 3b 3b 20 48 65 72 65 20 77 65 20 6e 65 . ;; Here we ne
6c90: 65 64 20 74 6f 20 63 68 65 63 6b 20 74 68 61 74 ed to check that
6ca0: 20 61 6c 6c 20 74 68 65 20 74 65 73 74 73 20 72 all the tests r
6cb0: 65 6d 61 69 6e 69 6e 67 20 74 6f 20 62 65 20 72 emaining to be r
6cc0: 75 6e 20 61 72 65 20 65 6c 69 67 69 62 6c 65 20 un are eligible
6cd0: 74 6f 20 72 75 6e 0a 20 20 3b 3b 20 61 6e 64 20 to run. ;; and
6ce0: 61 72 65 20 6e 6f 74 20 62 6c 6f 63 6b 65 64 20 are not blocked
6cf0: 62 79 20 66 61 69 6c 65 64 0a 20 20 0a 0a 3b 3b by failed. ..;;
6d00: 20 70 61 72 65 6e 74 2d 74 65 73 74 20 69 73 20 parent-test is
6d10: 74 68 65 72 65 20 61 73 20 61 20 70 6c 61 63 65 there as a place
6d20: 68 6f 6c 64 65 72 20 66 6f 72 20 77 68 65 6e 20 holder for when
6d30: 70 61 72 65 6e 74 2d 74 65 73 74 73 20 63 61 6e parent-tests can
6d40: 20 62 65 20 72 75 6e 20 61 73 20 61 20 73 65 74 be run as a set
6d50: 75 70 20 73 74 65 70 0a 28 64 65 66 69 6e 65 20 up step.(define
6d60: 28 72 75 6e 3a 74 65 73 74 20 72 75 6e 2d 69 64 (run:test run-id
6d70: 20 72 75 6e 6e 61 6d 65 20 6b 65 79 76 61 6c 6c runname keyvall
6d80: 73 74 20 74 65 73 74 2d 72 65 63 6f 72 64 20 66 st test-record f
6d90: 6c 61 67 73 20 70 61 72 65 6e 74 2d 74 65 73 74 lags parent-test
6da0: 29 0a 20 20 3b 3b 20 41 6c 6c 20 74 68 65 73 65 ). ;; All these
6db0: 20 76 61 72 73 20 6d 69 67 68 74 20 62 65 20 72 vars might be r
6dc0: 65 66 65 72 65 6e 63 65 64 20 62 79 20 74 68 65 eferenced by the
6dd0: 20 74 65 73 74 63 6f 6e 66 69 67 20 66 69 6c 65 testconfig file
6de0: 20 72 65 61 64 65 72 0a 20 20 28 6c 65 74 2a 20 reader. (let*
6df0: 28 28 74 65 73 74 2d 6e 61 6d 65 20 20 20 20 28 ((test-name (
6e00: 74 65 73 74 73 3a 74 65 73 74 71 75 65 75 65 2d tests:testqueue-
6e10: 67 65 74 2d 74 65 73 74 6e 61 6d 65 20 20 20 74 get-testname t
6e20: 65 73 74 2d 72 65 63 6f 72 64 29 29 0a 09 20 28 est-record)).. (
6e30: 74 65 73 74 2d 77 61 69 74 6f 6e 73 20 28 74 65 test-waitons (te
6e40: 73 74 73 3a 74 65 73 74 71 75 65 75 65 2d 67 65 sts:testqueue-ge
6e50: 74 2d 77 61 69 74 6f 6e 73 20 20 20 20 74 65 73 t-waitons tes
6e60: 74 2d 72 65 63 6f 72 64 29 29 0a 09 20 28 74 65 t-record)).. (te
6e70: 73 74 2d 63 6f 6e 66 20 20 20 20 28 74 65 73 74 st-conf (test
6e80: 73 3a 74 65 73 74 71 75 65 75 65 2d 67 65 74 2d s:testqueue-get-
6e90: 74 65 73 74 63 6f 6e 66 69 67 20 74 65 73 74 2d testconfig test-
6ea0: 72 65 63 6f 72 64 29 29 0a 09 20 28 69 74 65 6d record)).. (item
6eb0: 64 61 74 20 20 20 20 20 20 28 74 65 73 74 73 3a dat (tests:
6ec0: 74 65 73 74 71 75 65 75 65 2d 67 65 74 2d 69 74 testqueue-get-it
6ed0: 65 6d 64 61 74 20 20 20 20 74 65 73 74 2d 72 65 emdat test-re
6ee0: 63 6f 72 64 29 29 0a 09 20 28 74 65 73 74 2d 70 cord)).. (test-p
6ef0: 61 74 68 20 20 20 20 28 63 6f 6e 63 20 2a 74 6f ath (conc *to
6f00: 70 70 61 74 68 2a 20 22 2f 74 65 73 74 73 2f 22 ppath* "/tests/"
6f10: 20 74 65 73 74 2d 6e 61 6d 65 29 29 20 3b 3b 20 test-name)) ;;
6f20: 63 6f 75 6c 64 20 75 73 65 20 74 65 73 74 73 3a could use tests:
6f30: 67 65 74 2d 74 65 73 74 63 6f 6e 66 69 67 20 68 get-testconfig h
6f40: 65 72 65 20 2e 2e 2e 0a 09 20 28 66 6f 72 63 65 ere ..... (force
6f50: 20 20 20 20 20 20 20 20 28 68 61 73 68 2d 74 61 (hash-ta
6f60: 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 ble-ref/default
6f70: 66 6c 61 67 73 20 22 2d 66 6f 72 63 65 22 20 23 flags "-force" #
6f80: 66 29 29 0a 09 20 28 72 65 72 75 6e 20 20 20 20 f)).. (rerun
6f90: 20 20 20 20 28 68 61 73 68 2d 74 61 62 6c 65 2d (hash-table-
6fa0: 72 65 66 2f 64 65 66 61 75 6c 74 20 66 6c 61 67 ref/default flag
6fb0: 73 20 22 2d 72 65 72 75 6e 22 20 23 66 29 29 0a s "-rerun" #f)).
6fc0: 09 20 28 6b 65 65 70 67 6f 69 6e 67 20 20 20 20 . (keepgoing
6fd0: 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f (hash-table-ref/
6fe0: 64 65 66 61 75 6c 74 20 66 6c 61 67 73 20 22 2d default flags "-
6ff0: 6b 65 65 70 67 6f 69 6e 67 22 20 23 66 29 29 0a keepgoing" #f)).
7000: 09 20 28 69 74 65 6d 2d 70 61 74 68 20 20 20 20 . (item-path
7010: 20 22 22 29 0a 09 20 28 64 62 20 20 20 20 20 20 "").. (db
7020: 20 20 20 20 20 23 66 29 29 0a 20 20 20 20 28 64 #f)). (d
7030: 65 62 75 67 3a 70 72 69 6e 74 20 34 0a 09 09 20 ebug:print 4...
7040: 22 74 65 73 74 2d 63 6f 6e 66 69 67 3a 20 22 20 "test-config: "
7050: 28 68 61 73 68 2d 74 61 62 6c 65 2d 3e 61 6c 69 (hash-table->ali
7060: 73 74 20 74 65 73 74 2d 63 6f 6e 66 29 0a 09 09 st test-conf)...
7070: 20 22 5c 6e 20 20 20 69 74 65 6d 64 61 74 3a 20 "\n itemdat:
7080: 22 20 69 74 65 6d 64 61 74 0a 09 09 20 29 0a 20 " itemdat... ).
7090: 20 20 20 3b 3b 20 73 65 74 74 69 6e 67 20 69 74 ;; setting it
70a0: 65 6d 64 61 74 20 74 6f 20 61 20 6c 69 73 74 20 emdat to a list
70b0: 69 66 20 69 74 20 69 73 20 23 66 0a 20 20 20 20 if it is #f.
70c0: 28 69 66 20 28 6e 6f 74 20 69 74 65 6d 64 61 74 (if (not itemdat
70d0: 29 28 73 65 74 21 20 69 74 65 6d 64 61 74 20 27 )(set! itemdat '
70e0: 28 29 29 29 0a 20 20 20 20 28 73 65 74 21 20 69 ())). (set! i
70f0: 74 65 6d 2d 70 61 74 68 20 28 69 74 65 6d 2d 6c tem-path (item-l
7100: 69 73 74 2d 3e 70 61 74 68 20 69 74 65 6d 64 61 ist->path itemda
7110: 74 29 29 0a 20 20 20 20 28 64 65 62 75 67 3a 70 t)). (debug:p
7120: 72 69 6e 74 20 32 20 22 41 74 74 65 6d 70 74 69 rint 2 "Attempti
7130: 6e 67 20 74 6f 20 6c 61 75 6e 63 68 20 74 65 73 ng to launch tes
7140: 74 20 22 20 74 65 73 74 2d 6e 61 6d 65 20 28 69 t " test-name (i
7150: 66 20 28 65 71 75 61 6c 3f 20 69 74 65 6d 2d 70 f (equal? item-p
7160: 61 74 68 20 22 2f 22 29 20 22 2f 22 20 69 74 65 ath "/") "/" ite
7170: 6d 2d 70 61 74 68 29 29 0a 20 20 20 20 28 73 65 m-path)). (se
7180: 74 65 6e 76 20 22 4d 54 5f 54 45 53 54 5f 4e 41 tenv "MT_TEST_NA
7190: 4d 45 22 20 74 65 73 74 2d 6e 61 6d 65 29 20 3b ME" test-name) ;
71a0: 3b 20 0a 20 20 20 20 28 73 65 74 65 6e 76 20 22 ; . (setenv "
71b0: 4d 54 5f 52 55 4e 4e 41 4d 45 22 20 20 20 72 75 MT_RUNNAME" ru
71c0: 6e 6e 61 6d 65 29 0a 20 20 20 20 28 73 65 74 2d nname). (set-
71d0: 6d 65 67 61 74 65 73 74 2d 65 6e 76 2d 76 61 72 megatest-env-var
71e0: 73 20 72 75 6e 2d 69 64 29 20 3b 3b 20 74 68 65 s run-id) ;; the
71f0: 73 65 20 6d 61 79 20 62 65 20 6e 65 65 64 65 64 se may be needed
7200: 20 62 79 20 74 68 65 20 6c 61 75 6e 63 68 69 6e by the launchin
7210: 67 20 70 72 6f 63 65 73 73 0a 20 20 20 20 28 63 g process. (c
7220: 68 61 6e 67 65 2d 64 69 72 65 63 74 6f 72 79 20 hange-directory
7230: 2a 74 6f 70 70 61 74 68 2a 29 0a 0a 20 20 20 20 *toppath*)..
7240: 3b 3b 20 48 65 72 65 20 69 73 20 77 68 65 72 65 ;; Here is where
7250: 20 74 68 65 20 74 65 73 74 5f 6d 65 74 61 20 74 the test_meta t
7260: 61 62 6c 65 20 69 73 20 62 65 73 74 20 75 70 64 able is best upd
7270: 61 74 65 64 0a 20 20 20 20 3b 3b 20 59 65 73 2c ated. ;; Yes,
7280: 20 61 6e 6f 74 68 65 72 20 75 73 65 20 6f 66 20 another use of
7290: 61 20 67 6c 6f 62 61 6c 20 66 6f 72 20 63 61 63 a global for cac
72a0: 68 69 6e 67 2e 20 4e 65 65 64 20 61 20 62 65 74 hing. Need a bet
72b0: 74 65 72 20 77 61 79 3f 0a 20 20 20 20 28 69 66 ter way?. (if
72c0: 20 28 6e 6f 74 20 28 68 61 73 68 2d 74 61 62 6c (not (hash-tabl
72d0: 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 2a 74 e-ref/default *t
72e0: 65 73 74 2d 6d 65 74 61 2d 75 70 64 61 74 65 64 est-meta-updated
72f0: 2a 20 74 65 73 74 2d 6e 61 6d 65 20 23 66 29 29 * test-name #f))
7300: 0a 20 20 20 20 20 20 20 20 28 62 65 67 69 6e 0a . (begin.
7310: 09 20 20 20 28 68 61 73 68 2d 74 61 62 6c 65 2d . (hash-table-
7320: 73 65 74 21 20 2a 74 65 73 74 2d 6d 65 74 61 2d set! *test-meta-
7330: 75 70 64 61 74 65 64 2a 20 74 65 73 74 2d 6e 61 updated* test-na
7340: 6d 65 20 23 74 29 0a 20 20 20 20 20 20 20 20 20 me #t).
7350: 20 20 28 6f 70 65 6e 2d 72 75 6e 2d 63 6c 6f 73 (open-run-clos
7360: 65 20 72 75 6e 73 3a 75 70 64 61 74 65 2d 74 65 e runs:update-te
7370: 73 74 5f 6d 65 74 61 20 64 62 20 74 65 73 74 2d st_meta db test-
7380: 6e 61 6d 65 20 74 65 73 74 2d 63 6f 6e 66 29 29 name test-conf))
7390: 29 0a 20 20 20 20 0a 20 20 20 20 3b 3b 20 28 6c ). . ;; (l
73a0: 61 6d 62 64 61 20 28 69 74 65 6d 64 61 74 29 20 ambda (itemdat)
73b0: 3b 3b 3b 20 28 28 72 69 70 65 6e 65 73 73 20 22 ;;; ((ripeness "
73c0: 6f 76 65 72 72 69 70 65 22 29 20 28 74 65 6d 70 overripe") (temp
73d0: 65 72 61 74 75 72 65 20 22 63 6f 6f 6c 22 29 20 erature "cool")
73e0: 28 73 65 61 73 6f 6e 20 22 73 75 6d 6d 65 72 22 (season "summer"
73f0: 29 29 0a 20 20 20 20 28 6c 65 74 2a 20 28 28 6e )). (let* ((n
7400: 65 77 2d 74 65 73 74 2d 70 61 74 68 20 28 73 74 ew-test-path (st
7410: 72 69 6e 67 2d 69 6e 74 65 72 73 70 65 72 73 65 ring-intersperse
7420: 20 28 63 6f 6e 73 20 74 65 73 74 2d 70 61 74 68 (cons test-path
7430: 20 28 6d 61 70 20 63 61 64 72 20 69 74 65 6d 64 (map cadr itemd
7440: 61 74 29 29 20 22 2f 22 29 29 0a 09 20 20 20 28 at)) "/")).. (
7450: 6e 65 77 2d 74 65 73 74 2d 6e 61 6d 65 20 28 69 new-test-name (i
7460: 66 20 28 65 71 75 61 6c 3f 20 69 74 65 6d 2d 70 f (equal? item-p
7470: 61 74 68 20 22 22 29 20 74 65 73 74 2d 6e 61 6d ath "") test-nam
7480: 65 20 28 63 6f 6e 63 20 74 65 73 74 2d 6e 61 6d e (conc test-nam
7490: 65 20 22 2f 22 20 69 74 65 6d 2d 70 61 74 68 29 e "/" item-path)
74a0: 29 29 20 3b 3b 20 6a 75 73 74 20 6e 65 65 64 20 )) ;; just need
74b0: 69 74 20 74 6f 20 62 65 20 75 6e 69 71 75 65 0a it to be unique.
74c0: 09 20 20 20 28 74 65 73 74 2d 69 64 20 20 20 20 . (test-id
74d0: 20 20 20 28 63 64 62 3a 72 65 6d 6f 74 65 2d 72 (cdb:remote-r
74e0: 75 6e 20 64 62 3a 67 65 74 2d 74 65 73 74 2d 69 un db:get-test-i
74f0: 64 20 23 66 20 20 72 75 6e 2d 69 64 20 74 65 73 d #f run-id tes
7500: 74 2d 6e 61 6d 65 20 69 74 65 6d 2d 70 61 74 68 t-name item-path
7510: 29 29 0a 09 20 20 20 28 74 65 73 74 64 61 74 20 )).. (testdat
7520: 20 20 20 20 20 20 28 63 64 62 3a 67 65 74 2d 74 (cdb:get-t
7530: 65 73 74 2d 69 6e 66 6f 2d 62 79 2d 69 64 20 2a est-info-by-id *
7540: 72 75 6e 72 65 6d 6f 74 65 2a 20 74 65 73 74 2d runremote* test-
7550: 69 64 29 29 29 0a 20 20 20 20 20 20 28 69 66 20 id))). (if
7560: 28 6e 6f 74 20 74 65 73 74 64 61 74 29 0a 09 20 (not testdat)..
7570: 20 28 62 65 67 69 6e 0a 09 20 20 20 20 3b 3b 20 (begin.. ;;
7580: 65 6e 73 75 72 65 20 74 68 61 74 20 74 68 65 20 ensure that the
7590: 70 61 74 68 20 65 78 69 73 74 73 20 62 65 66 6f path exists befo
75a0: 72 65 20 72 65 67 69 73 74 65 72 69 6e 67 20 74 re registering t
75b0: 68 65 20 74 65 73 74 0a 09 20 20 20 20 3b 3b 20 he test.. ;;
75c0: 4e 4f 50 45 3a 20 43 61 6e 6e 6f 74 21 20 44 6f NOPE: Cannot! Do
75d0: 6e 27 74 20 6b 6e 6f 77 20 79 65 74 20 77 68 69 n't know yet whi
75e0: 63 68 20 64 69 73 6b 20 61 72 65 61 20 77 69 6c ch disk area wil
75f0: 6c 20 62 65 20 61 73 73 69 67 6e 65 64 2e 2e 2e l be assigned...
7600: 2e 0a 09 20 20 20 20 3b 3b 20 28 73 79 73 74 65 ... ;; (syste
7610: 6d 20 28 63 6f 6e 63 20 22 6d 6b 64 69 72 20 2d m (conc "mkdir -
7620: 70 20 22 20 6e 65 77 2d 74 65 73 74 2d 70 61 74 p " new-test-pat
7630: 68 29 29 0a 09 20 20 20 20 3b 3b 0a 09 20 20 20 h)).. ;;..
7640: 20 3b 3b 20 28 6f 70 65 6e 2d 72 75 6e 2d 63 6c ;; (open-run-cl
7650: 6f 73 65 20 74 65 73 74 73 3a 72 65 67 69 73 74 ose tests:regist
7660: 65 72 2d 74 65 73 74 20 64 62 20 72 75 6e 2d 69 er-test db run-i
7670: 64 20 74 65 73 74 2d 6e 61 6d 65 20 69 74 65 6d d test-name item
7680: 2d 70 61 74 68 29 0a 09 20 20 20 20 3b 3b 0a 09 -path).. ;;..
7690: 20 20 20 20 3b 3b 20 4e 42 2f 2f 20 66 6f 72 20 ;; NB// for
76a0: 74 68 65 20 61 62 6f 76 65 20 6c 69 6e 65 2e 20 the above line.
76b0: 49 20 77 61 6e 74 20 74 68 65 20 74 65 73 74 20 I want the test
76c0: 74 6f 20 62 65 20 72 65 67 69 73 74 65 72 65 64 to be registered
76d0: 20 6c 6f 6e 67 20 62 65 66 6f 72 65 20 74 68 69 long before thi
76e0: 73 20 72 6f 75 74 69 6e 65 20 67 65 74 73 20 63 s routine gets c
76f0: 61 6c 6c 65 64 21 0a 09 20 20 20 20 3b 3b 0a 09 alled!.. ;;..
7700: 20 20 20 20 28 73 65 74 21 20 74 65 73 74 2d 69 (set! test-i
7710: 64 20 28 6f 70 65 6e 2d 72 75 6e 2d 63 6c 6f 73 d (open-run-clos
7720: 65 20 64 62 3a 67 65 74 2d 74 65 73 74 2d 69 64 e db:get-test-id
7730: 20 64 62 20 72 75 6e 2d 69 64 20 74 65 73 74 2d db run-id test-
7740: 6e 61 6d 65 20 69 74 65 6d 2d 70 61 74 68 29 29 name item-path))
7750: 0a 09 20 20 20 20 28 69 66 20 28 6e 6f 74 20 74 .. (if (not t
7760: 65 73 74 2d 69 64 29 0a 09 09 28 62 65 67 69 6e est-id)...(begin
7770: 0a 09 09 20 20 28 64 65 62 75 67 3a 70 72 69 6e ... (debug:prin
7780: 74 20 32 20 22 57 41 52 4e 3a 20 54 65 73 74 20 t 2 "WARN: Test
7790: 6e 6f 74 20 70 72 65 2d 63 72 65 61 74 65 64 3f not pre-created?
77a0: 20 74 65 73 74 2d 6e 61 6d 65 3d 22 20 74 65 73 test-name=" tes
77b0: 74 2d 6e 61 6d 65 20 22 2c 20 69 74 65 6d 2d 70 t-name ", item-p
77c0: 61 74 68 3d 22 20 69 74 65 6d 2d 70 61 74 68 20 ath=" item-path
77d0: 22 2c 20 72 75 6e 2d 69 64 3d 22 20 72 75 6e 2d ", run-id=" run-
77e0: 69 64 29 0a 09 09 20 20 28 6f 70 65 6e 2d 72 75 id)... (open-ru
77f0: 6e 2d 63 6c 6f 73 65 20 64 62 3a 74 65 73 74 73 n-close db:tests
7800: 2d 72 65 67 69 73 74 65 72 2d 74 65 73 74 20 23 -register-test #
7810: 66 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 6e 61 f run-id test-na
7820: 6d 65 20 69 74 65 6d 2d 70 61 74 68 29 0a 09 09 me item-path)...
7830: 20 20 28 73 65 74 21 20 74 65 73 74 2d 69 64 20 (set! test-id
7840: 28 6f 70 65 6e 2d 72 75 6e 2d 63 6c 6f 73 65 20 (open-run-close
7850: 64 62 3a 67 65 74 2d 74 65 73 74 2d 69 64 20 64 db:get-test-id d
7860: 62 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 6e 61 b run-id test-na
7870: 6d 65 20 69 74 65 6d 2d 70 61 74 68 29 29 29 29 me item-path))))
7880: 0a 09 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 .. (debug:pri
7890: 6e 74 2d 69 6e 66 6f 20 34 20 22 74 65 73 74 2d nt-info 4 "test-
78a0: 69 64 3d 22 20 74 65 73 74 2d 69 64 20 22 2c 20 id=" test-id ",
78b0: 72 75 6e 2d 69 64 3d 22 20 72 75 6e 2d 69 64 20 run-id=" run-id
78c0: 22 2c 20 74 65 73 74 2d 6e 61 6d 65 3d 22 20 74 ", test-name=" t
78d0: 65 73 74 2d 6e 61 6d 65 20 22 2c 20 69 74 65 6d est-name ", item
78e0: 2d 70 61 74 68 3d 5c 22 22 20 69 74 65 6d 2d 70 -path=\"" item-p
78f0: 61 74 68 20 22 5c 22 22 29 0a 09 20 20 20 20 28 ath "\"").. (
7900: 73 65 74 21 20 74 65 73 74 64 61 74 20 28 63 64 set! testdat (cd
7910: 62 3a 67 65 74 2d 74 65 73 74 2d 69 6e 66 6f 2d b:get-test-info-
7920: 62 79 2d 69 64 20 2a 72 75 6e 72 65 6d 6f 74 65 by-id *runremote
7930: 2a 20 74 65 73 74 2d 69 64 29 29 29 29 0a 20 20 * test-id)))).
7940: 20 20 20 20 28 73 65 74 21 20 74 65 73 74 2d 69 (set! test-i
7950: 64 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 69 d (db:test-get-i
7960: 64 20 74 65 73 74 64 61 74 29 29 0a 20 20 20 20 d testdat)).
7970: 20 20 28 63 68 61 6e 67 65 2d 64 69 72 65 63 74 (change-direct
7980: 6f 72 79 20 74 65 73 74 2d 70 61 74 68 29 0a 20 ory test-path).
7990: 20 20 20 20 20 28 63 61 73 65 20 28 69 66 20 66 (case (if f
79a0: 6f 72 63 65 20 3b 3b 20 28 61 72 67 73 3a 67 65 orce ;; (args:ge
79b0: 74 2d 61 72 67 20 22 2d 66 6f 72 63 65 22 29 0a t-arg "-force").
79c0: 09 09 27 4e 4f 54 5f 53 54 41 52 54 45 44 0a 09 ..'NOT_STARTED..
79d0: 09 28 69 66 20 74 65 73 74 64 61 74 0a 09 09 20 .(if testdat...
79e0: 20 20 20 28 73 74 72 69 6e 67 2d 3e 73 79 6d 62 (string->symb
79f0: 6f 6c 20 28 74 65 73 74 3a 67 65 74 2d 73 74 61 ol (test:get-sta
7a00: 74 65 20 74 65 73 74 64 61 74 29 29 0a 09 09 20 te testdat))...
7a10: 20 20 20 27 66 61 69 6c 65 64 2d 74 6f 2d 69 6e 'failed-to-in
7a20: 73 65 72 74 29 29 0a 09 28 28 66 61 69 6c 65 64 sert))..((failed
7a30: 2d 74 6f 2d 69 6e 73 65 72 74 29 0a 09 20 28 64 -to-insert).. (d
7a40: 65 62 75 67 3a 70 72 69 6e 74 20 30 20 22 45 52 ebug:print 0 "ER
7a50: 52 4f 52 3a 20 46 61 69 6c 65 64 20 74 6f 20 69 ROR: Failed to i
7a60: 6e 73 65 72 74 20 74 68 65 20 72 65 63 6f 72 64 nsert the record
7a70: 20 69 6e 74 6f 20 74 68 65 20 64 62 22 29 29 0a into the db")).
7a80: 09 28 28 4e 4f 54 5f 53 54 41 52 54 45 44 20 43 .((NOT_STARTED C
7a90: 4f 4d 50 4c 45 54 45 44 20 44 45 4c 45 54 45 44 OMPLETED DELETED
7aa0: 29 0a 09 20 28 6c 65 74 20 28 28 72 75 6e 66 6c ).. (let ((runfl
7ab0: 61 67 20 23 66 29 29 0a 09 20 20 20 28 63 6f 6e ag #f)).. (con
7ac0: 64 0a 09 20 20 20 20 3b 3b 20 2d 66 6f 72 63 65 d.. ;; -force
7ad0: 2c 20 72 75 6e 20 6e 6f 20 6d 61 74 74 65 72 20 , run no matter
7ae0: 77 68 61 74 0a 09 20 20 20 20 28 66 6f 72 63 65 what.. (force
7af0: 20 28 73 65 74 21 20 72 75 6e 66 6c 61 67 20 23 (set! runflag #
7b00: 74 29 29 0a 09 20 20 20 20 3b 3b 20 4e 4f 54 5f t)).. ;; NOT_
7b10: 53 54 41 52 54 45 44 2c 20 72 75 6e 20 6e 6f 20 STARTED, run no
7b20: 6d 61 74 74 65 72 20 77 68 61 74 0a 09 20 20 20 matter what..
7b30: 20 28 28 6d 65 6d 62 65 72 20 28 74 65 73 74 3a ((member (test:
7b40: 67 65 74 2d 73 74 61 74 65 20 74 65 73 74 64 61 get-state testda
7b50: 74 29 20 27 28 22 44 45 4c 45 54 45 44 22 20 22 t) '("DELETED" "
7b60: 4e 4f 54 5f 53 54 41 52 54 45 44 22 29 29 28 73 NOT_STARTED"))(s
7b70: 65 74 21 20 72 75 6e 66 6c 61 67 20 23 74 29 29 et! runflag #t))
7b80: 0a 09 20 20 20 20 3b 3b 20 6e 6f 74 20 2d 72 65 .. ;; not -re
7b90: 72 75 6e 20 61 6e 64 20 50 41 53 53 2c 20 57 41 run and PASS, WA
7ba0: 52 4e 20 6f 72 20 43 48 45 43 4b 2c 20 64 6f 20 RN or CHECK, do
7bb0: 6e 6f 20 72 75 6e 0a 09 20 20 20 20 28 28 61 6e no run.. ((an
7bc0: 64 20 28 6f 72 20 28 6e 6f 74 20 72 65 72 75 6e d (or (not rerun
7bd0: 29 0a 09 09 20 20 20 20 20 20 6b 65 65 70 67 6f )... keepgo
7be0: 69 6e 67 29 0a 09 09 20 20 3b 3b 20 52 65 71 75 ing)... ;; Requ
7bf0: 69 72 65 20 74 6f 20 66 6f 72 63 65 20 72 65 2d ire to force re-
7c00: 72 75 6e 20 66 6f 72 20 43 4f 4d 50 4c 45 54 45 run for COMPLETE
7c10: 44 20 6f 72 20 2a 61 6e 79 74 68 69 6e 67 2a 20 D or *anything*
7c20: 2b 20 50 41 53 53 2c 57 41 52 4e 20 6f 72 20 43 + PASS,WARN or C
7c30: 48 45 43 4b 0a 09 09 20 20 28 6f 72 20 28 6d 65 HECK... (or (me
7c40: 6d 62 65 72 20 28 74 65 73 74 3a 67 65 74 2d 73 mber (test:get-s
7c50: 74 61 74 75 73 20 74 65 73 74 64 61 74 29 20 27 tatus testdat) '
7c60: 28 22 50 41 53 53 22 20 22 57 41 52 4e 22 20 22 ("PASS" "WARN" "
7c70: 43 48 45 43 4b 22 29 29 0a 09 09 20 20 20 20 20 CHECK"))...
7c80: 20 28 6d 65 6d 62 65 72 20 28 74 65 73 74 3a 67 (member (test:g
7c90: 65 74 2d 73 74 61 74 65 20 20 74 65 73 74 64 61 et-state testda
7ca0: 74 29 20 27 28 22 43 4f 4d 50 4c 45 54 45 44 22 t) '("COMPLETED"
7cb0: 29 29 29 29 20 0a 09 20 20 20 20 20 28 64 65 62 )))) .. (deb
7cc0: 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 32 20 ug:print-info 2
7cd0: 22 72 75 6e 6e 69 6e 67 20 74 65 73 74 20 22 20 "running test "
7ce0: 74 65 73 74 2d 6e 61 6d 65 20 22 2f 22 20 69 74 test-name "/" it
7cf0: 65 6d 2d 70 61 74 68 20 22 20 73 75 70 70 72 65 em-path " suppre
7d00: 73 73 65 64 20 61 73 20 69 74 20 69 73 20 22 20 ssed as it is "
7d10: 28 74 65 73 74 3a 67 65 74 2d 73 74 61 74 65 20 (test:get-state
7d20: 74 65 73 74 64 61 74 29 20 22 20 61 6e 64 20 22 testdat) " and "
7d30: 20 28 74 65 73 74 3a 67 65 74 2d 73 74 61 74 75 (test:get-statu
7d40: 73 20 74 65 73 74 64 61 74 29 29 0a 09 20 20 20 s testdat))..
7d50: 20 20 28 73 65 74 21 20 72 75 6e 66 6c 61 67 20 (set! runflag
7d60: 23 66 29 29 0a 09 20 20 20 20 3b 3b 20 2d 72 65 #f)).. ;; -re
7d70: 72 75 6e 20 61 6e 64 20 73 74 61 74 75 73 20 69 run and status i
7d80: 73 20 6f 6e 65 20 6f 66 20 74 68 65 20 73 70 65 s one of the spe
7d90: 63 69 66 65 64 2c 20 72 75 6e 20 69 74 0a 09 20 cifed, run it..
7da0: 20 20 20 28 28 61 6e 64 20 72 65 72 75 6e 0a 09 ((and rerun..
7db0: 09 20 20 28 6c 65 74 2a 20 28 28 72 65 72 75 6e . (let* ((rerun
7dc0: 6c 73 74 20 20 20 28 73 74 72 69 6e 67 2d 73 70 lst (string-sp
7dd0: 6c 69 74 20 72 65 72 75 6e 20 22 2c 22 29 29 0a lit rerun ",")).
7de0: 09 09 09 20 28 6d 75 73 74 2d 72 65 72 75 6e 20 ... (must-rerun
7df0: 28 6d 65 6d 62 65 72 20 28 74 65 73 74 3a 67 65 (member (test:ge
7e00: 74 2d 73 74 61 74 75 73 20 74 65 73 74 64 61 74 t-status testdat
7e10: 29 20 72 65 72 75 6e 6c 73 74 29 29 29 0a 09 09 ) rerunlst)))...
7e20: 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 (debug:print
7e30: 2d 69 6e 66 6f 20 33 20 22 2d 72 65 72 75 6e 20 -info 3 "-rerun
7e40: 6c 69 73 74 3a 20 22 20 72 65 72 75 6e 20 22 2c list: " rerun ",
7e50: 20 74 65 73 74 2d 73 74 61 74 75 73 3a 20 22 20 test-status: "
7e60: 28 74 65 73 74 3a 67 65 74 2d 73 74 61 74 75 73 (test:get-status
7e70: 20 74 65 73 74 64 61 74 29 22 2c 20 6d 75 73 74 testdat)", must
7e80: 2d 72 65 72 75 6e 3a 20 22 20 6d 75 73 74 2d 72 -rerun: " must-r
7e90: 65 72 75 6e 29 0a 09 09 20 20 20 20 6d 75 73 74 erun)... must
7ea0: 2d 72 65 72 75 6e 29 29 0a 09 20 20 20 20 20 28 -rerun)).. (
7eb0: 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f debug:print-info
7ec0: 20 32 20 22 52 65 72 75 6e 20 66 6f 72 63 65 64 2 "Rerun forced
7ed0: 20 66 6f 72 20 74 65 73 74 20 22 20 74 65 73 74 for test " test
7ee0: 2d 6e 61 6d 65 20 22 2f 22 20 69 74 65 6d 2d 70 -name "/" item-p
7ef0: 61 74 68 29 0a 09 20 20 20 20 20 28 73 65 74 21 ath).. (set!
7f00: 20 72 75 6e 66 6c 61 67 20 23 74 29 29 0a 09 20 runflag #t))..
7f10: 20 20 20 3b 3b 20 2d 6b 65 65 70 67 6f 69 6e 67 ;; -keepgoing
7f20: 2c 20 64 6f 20 6e 6f 74 20 72 65 72 75 6e 20 46 , do not rerun F
7f30: 41 49 4c 0a 09 20 20 20 20 28 28 61 6e 64 20 6b AIL.. ((and k
7f40: 65 65 70 67 6f 69 6e 67 0a 09 09 20 20 28 6d 65 eepgoing... (me
7f50: 6d 62 65 72 20 28 74 65 73 74 3a 67 65 74 2d 73 mber (test:get-s
7f60: 74 61 74 75 73 20 74 65 73 74 64 61 74 29 20 27 tatus testdat) '
7f70: 28 22 46 41 49 4c 22 29 29 29 0a 09 20 20 20 20 ("FAIL")))..
7f80: 20 28 73 65 74 21 20 72 75 6e 66 6c 61 67 20 23 (set! runflag #
7f90: 66 29 29 0a 09 20 20 20 20 28 28 61 6e 64 20 28 f)).. ((and (
7fa0: 6e 6f 74 20 72 65 72 75 6e 29 0a 09 09 20 20 28 not rerun)... (
7fb0: 6d 65 6d 62 65 72 20 28 74 65 73 74 3a 67 65 74 member (test:get
7fc0: 2d 73 74 61 74 75 73 20 74 65 73 74 64 61 74 29 -status testdat)
7fd0: 20 27 28 22 46 41 49 4c 22 20 22 6e 2f 61 22 29 '("FAIL" "n/a")
7fe0: 29 29 0a 09 20 20 20 20 20 28 73 65 74 21 20 72 )).. (set! r
7ff0: 75 6e 66 6c 61 67 20 23 74 29 29 0a 09 20 20 20 unflag #t))..
8000: 20 28 65 6c 73 65 20 28 73 65 74 21 20 72 75 6e (else (set! run
8010: 66 6c 61 67 20 23 66 29 29 29 0a 09 20 20 20 28 flag #f))).. (
8020: 64 65 62 75 67 3a 70 72 69 6e 74 20 36 20 22 52 debug:print 6 "R
8030: 55 4e 4e 49 4e 47 20 3d 3e 20 72 75 6e 66 6c 61 UNNING => runfla
8040: 67 3a 20 22 20 72 75 6e 66 6c 61 67 20 22 20 53 g: " runflag " S
8050: 54 41 54 45 3a 20 22 20 28 74 65 73 74 3a 67 65 TATE: " (test:ge
8060: 74 2d 73 74 61 74 65 20 74 65 73 74 64 61 74 29 t-state testdat)
8070: 20 22 20 53 54 41 54 55 53 3a 20 22 20 28 74 65 " STATUS: " (te
8080: 73 74 3a 67 65 74 2d 73 74 61 74 75 73 20 74 65 st:get-status te
8090: 73 74 64 61 74 29 29 0a 09 20 20 20 28 69 66 20 stdat)).. (if
80a0: 28 6e 6f 74 20 72 75 6e 66 6c 61 67 29 0a 09 20 (not runflag)..
80b0: 20 20 20 20 20 20 28 69 66 20 28 6e 6f 74 20 70 (if (not p
80c0: 61 72 65 6e 74 2d 74 65 73 74 29 0a 09 09 20 20 arent-test)...
80d0: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 31 20 (debug:print 1
80e0: 22 4e 4f 54 45 3a 20 4e 6f 74 20 73 74 61 72 74 "NOTE: Not start
80f0: 69 6e 67 20 74 65 73 74 20 22 20 6e 65 77 2d 74 ing test " new-t
8100: 65 73 74 2d 6e 61 6d 65 20 22 20 61 73 20 69 74 est-name " as it
8110: 20 69 73 20 73 74 61 74 65 20 5c 22 22 20 28 74 is state \"" (t
8120: 65 73 74 3a 67 65 74 2d 73 74 61 74 65 20 74 65 est:get-state te
8130: 73 74 64 61 74 29 20 0a 09 09 09 09 22 5c 22 20 stdat) ....."\"
8140: 61 6e 64 20 73 74 61 74 75 73 20 5c 22 22 20 28 and status \"" (
8150: 74 65 73 74 3a 67 65 74 2d 73 74 61 74 75 73 20 test:get-status
8160: 74 65 73 74 64 61 74 29 20 22 5c 22 2c 20 75 73 testdat) "\", us
8170: 65 20 2d 72 65 72 75 6e 20 5c 22 22 20 28 74 65 e -rerun \"" (te
8180: 73 74 3a 67 65 74 2d 73 74 61 74 75 73 20 74 65 st:get-status te
8190: 73 74 64 61 74 29 0a 20 20 20 20 20 20 20 20 20 stdat).
81a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
81b0: 20 20 20 20 20 20 20 22 5c 22 20 6f 72 20 2d 66 "\" or -f
81c0: 6f 72 63 65 20 74 6f 20 6f 76 65 72 72 69 64 65 orce to override
81d0: 22 29 29 0a 09 20 20 20 20 20 20 20 3b 3b 20 4e ")).. ;; N
81e0: 4f 54 45 3a 20 4e 6f 20 6c 6f 6e 67 65 72 20 62 OTE: No longer b
81f0: 65 20 63 68 65 63 6b 69 6e 67 20 70 72 65 72 65 e checking prere
8200: 71 75 69 73 69 74 65 73 20 68 65 72 65 21 20 57 quisites here! W
8210: 69 6c 6c 20 6e 65 76 65 72 20 67 65 74 20 68 65 ill never get he
8220: 72 65 20 75 6e 6c 65 73 73 20 70 72 65 72 65 71 re unless prereq
8230: 73 20 61 72 65 0a 09 20 20 20 20 20 20 20 3b 3b s are.. ;;
8240: 20 20 20 20 20 20 20 61 6c 72 65 61 64 79 20 6d already m
8250: 65 74 2e 0a 09 20 20 20 20 20 20 20 28 69 66 20 et... (if
8260: 28 6e 6f 74 20 28 6c 61 75 6e 63 68 2d 74 65 73 (not (launch-tes
8270: 74 20 23 66 20 72 75 6e 2d 69 64 20 72 75 6e 6e t #f run-id runn
8280: 61 6d 65 20 74 65 73 74 2d 63 6f 6e 66 20 6b 65 ame test-conf ke
8290: 79 76 61 6c 6c 73 74 20 74 65 73 74 2d 6e 61 6d yvallst test-nam
82a0: 65 20 74 65 73 74 2d 70 61 74 68 20 69 74 65 6d e test-path item
82b0: 64 61 74 20 66 6c 61 67 73 29 29 0a 09 09 20 20 dat flags))...
82c0: 20 28 62 65 67 69 6e 0a 09 09 20 20 20 20 20 28 (begin... (
82d0: 70 72 69 6e 74 20 22 45 52 52 4f 52 3a 20 46 61 print "ERROR: Fa
82e0: 69 6c 65 64 20 74 6f 20 6c 61 75 6e 63 68 20 74 iled to launch t
82f0: 68 65 20 74 65 73 74 2e 20 45 78 69 74 69 6e 67 he test. Exiting
8300: 20 61 73 20 73 6f 6f 6e 20 61 73 20 70 6f 73 73 as soon as poss
8310: 69 62 6c 65 22 29 0a 09 09 20 20 20 20 20 28 73 ible")... (s
8320: 65 74 21 20 2a 67 6c 6f 62 61 6c 65 78 69 74 73 et! *globalexits
8330: 74 61 74 75 73 2a 20 31 29 20 3b 3b 20 0a 09 09 tatus* 1) ;; ...
8340: 20 20 20 20 20 28 70 72 6f 63 65 73 73 2d 73 69 (process-si
8350: 67 6e 61 6c 20 28 63 75 72 72 65 6e 74 2d 70 72 gnal (current-pr
8360: 6f 63 65 73 73 2d 69 64 29 20 73 69 67 6e 61 6c ocess-id) signal
8370: 2f 6b 69 6c 6c 29 29 29 29 29 29 0a 09 28 28 4b /kill))))))..((K
8380: 49 4c 4c 45 44 29 20 0a 09 20 28 64 65 62 75 67 ILLED) .. (debug
8390: 3a 70 72 69 6e 74 20 31 20 22 4e 4f 54 45 3a 20 :print 1 "NOTE:
83a0: 22 20 6e 65 77 2d 74 65 73 74 2d 6e 61 6d 65 20 " new-test-name
83b0: 22 20 69 73 20 61 6c 72 65 61 64 79 20 72 75 6e " is already run
83c0: 6e 69 6e 67 20 6f 72 20 77 61 73 20 65 78 70 6c ning or was expl
83d0: 69 63 74 6c 79 20 6b 69 6c 6c 65 64 2c 20 75 73 ictly killed, us
83e0: 65 20 2d 66 6f 72 63 65 20 74 6f 20 6c 61 75 6e e -force to laun
83f0: 63 68 20 69 74 2e 22 29 29 0a 09 28 28 4c 41 55 ch it."))..((LAU
8400: 4e 43 48 45 44 20 52 45 4d 4f 54 45 48 4f 53 54 NCHED REMOTEHOST
8410: 53 54 41 52 54 20 52 55 4e 4e 49 4e 47 29 20 20 START RUNNING)
8420: 0a 09 20 28 69 66 20 28 3e 20 28 2d 20 28 63 75 .. (if (> (- (cu
8430: 72 72 65 6e 74 2d 73 65 63 6f 6e 64 73 29 28 2b rrent-seconds)(+
8440: 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 65 76 (db:test-get-ev
8450: 65 6e 74 5f 74 69 6d 65 20 74 65 73 74 64 61 74 ent_time testdat
8460: 29 0a 09 09 09 09 20 20 20 20 20 20 20 28 64 62 )..... (db
8470: 3a 74 65 73 74 2d 67 65 74 2d 72 75 6e 5f 64 75 :test-get-run_du
8480: 72 61 74 69 6f 6e 20 74 65 73 74 64 61 74 29 29 ration testdat))
8490: 29 0a 09 09 36 30 30 29 20 3b 3b 20 69 2e 65 2e )...600) ;; i.e.
84a0: 20 6e 6f 20 75 70 64 61 74 65 20 66 6f 72 20 6d no update for m
84b0: 6f 72 65 20 74 68 61 6e 20 36 30 30 20 73 65 63 ore than 600 sec
84c0: 6f 6e 64 73 0a 09 20 20 20 20 20 28 62 65 67 69 onds.. (begi
84d0: 6e 0a 09 20 20 20 20 20 20 20 28 64 65 62 75 67 n.. (debug
84e0: 3a 70 72 69 6e 74 20 30 20 22 57 41 52 4e 49 4e :print 0 "WARNIN
84f0: 47 3a 20 54 65 73 74 20 22 20 74 65 73 74 2d 6e G: Test " test-n
8500: 61 6d 65 20 22 20 61 70 70 65 61 72 73 20 74 6f ame " appears to
8510: 20 62 65 20 64 65 61 64 2e 20 46 6f 72 63 69 6e be dead. Forcin
8520: 67 20 69 74 20 74 6f 20 73 74 61 74 65 20 49 4e g it to state IN
8530: 43 4f 4d 50 4c 45 54 45 20 61 6e 64 20 73 74 61 COMPLETE and sta
8540: 74 75 73 20 53 54 55 43 4b 2f 44 45 41 44 22 29 tus STUCK/DEAD")
8550: 0a 09 20 20 20 20 20 20 20 28 74 65 73 74 73 3a .. (tests:
8560: 74 65 73 74 2d 73 65 74 2d 73 74 61 74 75 73 21 test-set-status!
8570: 20 74 65 73 74 2d 69 64 20 22 49 4e 43 4f 4d 50 test-id "INCOMP
8580: 4c 45 54 45 22 20 22 53 54 55 43 4b 2f 44 45 41 LETE" "STUCK/DEA
8590: 44 22 20 22 54 65 73 74 20 69 73 20 73 74 75 63 D" "Test is stuc
85a0: 6b 20 6f 72 20 64 65 61 64 22 20 23 66 29 29 0a k or dead" #f)).
85b0: 09 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 . (debug:pri
85c0: 6e 74 20 32 20 22 4e 4f 54 45 3a 20 22 20 74 65 nt 2 "NOTE: " te
85d0: 73 74 2d 6e 61 6d 65 20 22 20 69 73 20 61 6c 72 st-name " is alr
85e0: 65 61 64 79 20 72 75 6e 6e 69 6e 67 22 29 29 29 eady running")))
85f0: 0a 09 28 65 6c 73 65 20 20 20 20 20 20 20 28 64 ..(else (d
8600: 65 62 75 67 3a 70 72 69 6e 74 20 30 20 22 45 52 ebug:print 0 "ER
8610: 52 4f 52 3a 20 46 61 69 6c 65 64 20 74 6f 20 6c ROR: Failed to l
8620: 61 75 6e 63 68 20 74 65 73 74 20 22 20 6e 65 77 aunch test " new
8630: 2d 74 65 73 74 2d 6e 61 6d 65 20 22 2e 20 55 6e -test-name ". Un
8640: 72 65 63 6f 67 6e 69 73 65 64 20 73 74 61 74 65 recognised state
8650: 20 22 20 28 74 65 73 74 3a 67 65 74 2d 73 74 61 " (test:get-sta
8660: 74 65 20 74 65 73 74 64 61 74 29 29 29 29 29 29 te testdat))))))
8670: 29 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d )..;;===========
8680: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8690: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
86a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
86b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 45 ===========.;; E
86c0: 4e 44 20 4f 46 20 4e 45 57 20 53 54 55 46 46 0a ND OF NEW STUFF.
86d0: 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;;==============
86e0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
86f0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8700: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8710: 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 28 64 65 66 69 6e ========..(defin
8720: 65 20 28 67 65 74 2d 64 69 72 2d 75 70 2d 6e 20 e (get-dir-up-n
8730: 64 69 72 20 2e 20 70 61 72 61 6d 73 29 20 0a 20 dir . params) .
8740: 20 28 6c 65 74 20 28 28 64 70 61 72 74 73 20 20 (let ((dparts
8750: 28 73 74 72 69 6e 67 2d 73 70 6c 69 74 20 64 69 (string-split di
8760: 72 20 22 2f 22 29 29 0a 09 28 63 6f 75 6e 74 20 r "/"))..(count
8770: 20 20 28 69 66 20 28 6e 75 6c 6c 3f 20 70 61 72 (if (null? par
8780: 61 6d 73 29 20 31 20 28 63 61 72 20 70 61 72 61 ams) 1 (car para
8790: 6d 73 29 29 29 29 0a 20 20 20 20 28 63 6f 6e 63 ms)))). (conc
87a0: 20 22 2f 22 20 28 73 74 72 69 6e 67 2d 69 6e 74 "/" (string-int
87b0: 65 72 73 70 65 72 73 65 20 0a 09 20 20 20 20 20 ersperse ..
87c0: 20 20 28 74 61 6b 65 20 64 70 61 72 74 73 20 28 (take dparts (
87d0: 2d 20 28 6c 65 6e 67 74 68 20 64 70 61 72 74 73 - (length dparts
87e0: 29 20 63 6f 75 6e 74 29 29 0a 09 20 20 20 20 20 ) count))..
87f0: 20 20 22 2f 22 29 29 29 29 0a 3b 3b 20 52 65 6d "/")))).;; Rem
8800: 6f 76 65 20 72 75 6e 73 0a 3b 3b 20 66 69 65 6c ove runs.;; fiel
8810: 64 73 20 61 72 65 20 70 61 73 73 69 6e 67 20 69 ds are passing i
8820: 6e 20 74 68 72 6f 75 67 68 20 0a 3b 3b 20 61 63 n through .;; ac
8830: 74 69 6f 6e 3a 0a 3b 3b 20 20 20 20 27 72 65 6d tion:.;; 'rem
8840: 6f 76 65 2d 72 75 6e 73 0a 3b 3b 20 20 20 20 27 ove-runs.;; '
8850: 73 65 74 2d 73 74 61 74 65 2d 73 74 61 74 75 73 set-state-status
8860: 0a 3b 3b 0a 3b 3b 20 4e 42 2f 2f 20 73 68 6f 75 .;;.;; NB// shou
8870: 6c 64 20 70 61 73 73 20 69 6e 20 6b 65 79 73 3f ld pass in keys?
8880: 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 72 75 6e .;;.(define (run
8890: 73 3a 6f 70 65 72 61 74 65 2d 6f 6e 20 61 63 74 s:operate-on act
88a0: 69 6f 6e 20 72 75 6e 6e 61 6d 65 70 61 74 74 20 ion runnamepatt
88b0: 74 65 73 74 70 61 74 74 20 23 21 6b 65 79 20 28 testpatt #!key (
88c0: 73 74 61 74 65 20 23 66 29 28 73 74 61 74 75 73 state #f)(status
88d0: 20 23 66 29 28 6e 65 77 2d 73 74 61 74 65 2d 73 #f)(new-state-s
88e0: 74 61 74 75 73 20 23 66 29 29 0a 20 20 28 6c 65 tatus #f)). (le
88f0: 74 2a 20 28 28 64 62 20 20 20 20 20 20 20 20 20 t* ((db
8900: 20 20 23 66 29 0a 09 20 28 6b 65 79 73 20 20 20 #f).. (keys
8910: 20 20 20 20 20 20 28 6f 70 65 6e 2d 72 75 6e 2d (open-run-
8920: 63 6c 6f 73 65 20 64 62 3a 67 65 74 2d 6b 65 79 close db:get-key
8930: 73 20 64 62 29 29 0a 09 20 28 72 75 6e 64 61 74 s db)).. (rundat
8940: 20 20 20 20 20 20 20 28 6f 70 65 6e 2d 72 75 6e (open-run
8950: 2d 63 6c 6f 73 65 20 72 75 6e 73 3a 67 65 74 2d -close runs:get-
8960: 72 75 6e 73 2d 62 79 2d 70 61 74 74 20 64 62 20 runs-by-patt db
8970: 6b 65 79 73 20 72 75 6e 6e 61 6d 65 70 61 74 74 keys runnamepatt
8980: 29 29 0a 09 20 28 68 65 61 64 65 72 20 20 20 20 )).. (header
8990: 20 20 20 28 76 65 63 74 6f 72 2d 72 65 66 20 72 (vector-ref r
89a0: 75 6e 64 61 74 20 30 29 29 0a 09 20 28 72 75 6e undat 0)).. (run
89b0: 73 20 20 20 20 20 20 20 20 20 28 76 65 63 74 6f s (vecto
89c0: 72 2d 72 65 66 20 72 75 6e 64 61 74 20 31 29 29 r-ref rundat 1))
89d0: 0a 09 20 28 73 74 61 74 65 73 20 20 20 20 20 20 .. (states
89e0: 20 28 69 66 20 73 74 61 74 65 20 20 28 73 74 72 (if state (str
89f0: 69 6e 67 2d 73 70 6c 69 74 20 73 74 61 74 65 20 ing-split state
8a00: 20 22 2c 22 29 20 27 28 29 29 29 0a 09 20 28 73 ",") '())).. (s
8a10: 74 61 74 75 73 65 73 20 20 20 20 20 28 69 66 20 tatuses (if
8a20: 73 74 61 74 75 73 20 28 73 74 72 69 6e 67 2d 73 status (string-s
8a30: 70 6c 69 74 20 73 74 61 74 75 73 20 22 2c 22 29 plit status ",")
8a40: 20 27 28 29 29 29 0a 09 20 28 73 74 61 74 65 2d '())).. (state-
8a50: 73 74 61 74 75 73 20 28 69 66 20 28 73 74 72 69 status (if (stri
8a60: 6e 67 3f 20 6e 65 77 2d 73 74 61 74 65 2d 73 74 ng? new-state-st
8a70: 61 74 75 73 29 20 28 73 74 72 69 6e 67 2d 73 70 atus) (string-sp
8a80: 6c 69 74 20 6e 65 77 2d 73 74 61 74 65 2d 73 74 lit new-state-st
8a90: 61 74 75 73 20 22 2c 22 29 20 27 28 23 66 20 23 atus ",") '(#f #
8aa0: 66 29 29 29 29 0a 20 20 20 20 28 64 65 62 75 67 f)))). (debug
8ab0: 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 34 20 22 72 :print-info 4 "r
8ac0: 75 6e 73 3a 6f 70 65 72 61 74 65 2d 6f 6e 20 3d uns:operate-on =
8ad0: 3e 20 48 65 61 64 65 72 3a 20 22 20 68 65 61 64 > Header: " head
8ae0: 65 72 20 22 20 61 63 74 69 6f 6e 3a 20 22 20 61 er " action: " a
8af0: 63 74 69 6f 6e 20 22 20 6e 65 77 2d 73 74 61 74 ction " new-stat
8b00: 65 2d 73 74 61 74 75 73 3a 20 22 20 6e 65 77 2d e-status: " new-
8b10: 73 74 61 74 65 2d 73 74 61 74 75 73 29 0a 20 20 state-status).
8b20: 20 20 28 69 66 20 28 3e 20 32 20 28 6c 65 6e 67 (if (> 2 (leng
8b30: 74 68 20 73 74 61 74 65 2d 73 74 61 74 75 73 29 th state-status)
8b40: 29 0a 09 28 62 65 67 69 6e 0a 09 20 20 28 64 65 )..(begin.. (de
8b50: 62 75 67 3a 70 72 69 6e 74 20 30 20 22 45 52 52 bug:print 0 "ERR
8b60: 4f 52 3a 20 74 68 65 20 70 61 72 61 6d 65 74 65 OR: the paramete
8b70: 72 20 74 6f 20 2d 73 65 74 2d 73 74 61 74 65 2d r to -set-state-
8b80: 73 74 61 74 75 73 20 69 73 20 61 20 63 6f 6d 6d status is a comm
8b90: 61 20 64 65 6c 69 6d 69 74 65 64 20 73 74 72 69 a delimited stri
8ba0: 6e 67 2e 20 45 2e 67 2e 20 43 4f 4d 50 4c 45 54 ng. E.g. COMPLET
8bb0: 45 44 2c 46 41 49 4c 22 29 0a 09 20 20 28 65 78 ED,FAIL").. (ex
8bc0: 69 74 29 29 29 0a 20 20 20 20 28 66 6f 72 2d 65 it))). (for-e
8bd0: 61 63 68 0a 20 20 20 20 20 28 6c 61 6d 62 64 61 ach. (lambda
8be0: 20 28 72 75 6e 29 0a 20 20 20 20 20 20 20 28 6c (run). (l
8bf0: 65 74 20 28 28 72 75 6e 6b 65 79 20 28 73 74 72 et ((runkey (str
8c00: 69 6e 67 2d 69 6e 74 65 72 73 70 65 72 73 65 20 ing-intersperse
8c10: 28 6d 61 70 20 28 6c 61 6d 62 64 61 20 28 6b 29 (map (lambda (k)
8c20: 0a 09 09 09 09 09 09 28 64 62 3a 67 65 74 2d 76 .......(db:get-v
8c30: 61 6c 75 65 2d 62 79 2d 68 65 61 64 65 72 20 72 alue-by-header r
8c40: 75 6e 20 68 65 61 64 65 72 20 28 76 65 63 74 6f un header (vecto
8c50: 72 2d 72 65 66 20 6b 20 30 29 29 29 20 6b 65 79 r-ref k 0))) key
8c60: 73 29 20 22 2f 22 29 29 0a 09 20 20 20 20 20 28 s) "/")).. (
8c70: 64 69 72 73 2d 74 6f 2d 72 65 6d 6f 76 65 20 28 dirs-to-remove (
8c80: 6d 61 6b 65 2d 68 61 73 68 2d 74 61 62 6c 65 29 make-hash-table)
8c90: 29 29 0a 09 20 28 6c 65 74 2a 20 28 28 72 75 6e )).. (let* ((run
8ca0: 2d 69 64 20 20 20 20 28 64 62 3a 67 65 74 2d 76 -id (db:get-v
8cb0: 61 6c 75 65 2d 62 79 2d 68 65 61 64 65 72 20 72 alue-by-header r
8cc0: 75 6e 20 68 65 61 64 65 72 20 22 69 64 22 29 29 un header "id"))
8cd0: 0a 09 09 28 72 75 6e 2d 73 74 61 74 65 20 28 64 ...(run-state (d
8ce0: 62 3a 67 65 74 2d 76 61 6c 75 65 2d 62 79 2d 68 b:get-value-by-h
8cf0: 65 61 64 65 72 20 72 75 6e 20 68 65 61 64 65 72 eader run header
8d00: 20 22 73 74 61 74 65 22 29 29 0a 09 09 28 74 65 "state"))...(te
8d10: 73 74 73 20 20 20 20 20 28 69 66 20 28 6e 6f 74 sts (if (not
8d20: 20 28 65 71 75 61 6c 3f 20 72 75 6e 2d 73 74 61 (equal? run-sta
8d30: 74 65 20 22 6c 6f 63 6b 65 64 22 29 29 0a 09 09 te "locked"))...
8d40: 09 20 20 20 20 20 20 20 28 6f 70 65 6e 2d 72 75 . (open-ru
8d50: 6e 2d 63 6c 6f 73 65 20 64 62 3a 67 65 74 2d 74 n-close db:get-t
8d60: 65 73 74 73 2d 66 6f 72 2d 72 75 6e 20 64 62 20 ests-for-run db
8d70: 72 75 6e 2d 69 64 0a 09 09 09 09 09 09 20 20 20 run-id.......
8d80: 20 20 20 74 65 73 74 70 61 74 74 20 73 74 61 74 testpatt stat
8d90: 65 73 20 73 74 61 74 75 73 65 73 0a 09 09 09 09 es statuses.....
8da0: 09 09 20 20 20 20 20 20 6e 6f 74 2d 69 6e 3a 20 .. not-in:
8db0: 20 23 66 0a 09 09 09 09 09 09 20 20 20 20 20 20 #f.......
8dc0: 73 6f 72 74 2d 62 79 3a 20 28 63 61 73 65 20 61 sort-by: (case a
8dd0: 63 74 69 6f 6e 0a 09 09 09 09 09 09 09 09 20 28 ction......... (
8de0: 28 72 65 6d 6f 76 65 2d 72 75 6e 73 29 20 27 72 (remove-runs) 'r
8df0: 75 6e 64 69 72 29 0a 09 09 09 09 09 09 09 09 20 undir).........
8e00: 28 65 6c 73 65 20 20 20 20 20 20 20 20 20 20 27 (else '
8e10: 65 76 65 6e 74 5f 74 69 6d 65 29 29 29 0a 09 09 event_time)))...
8e20: 09 20 20 20 20 20 20 20 27 28 29 29 29 0a 09 09 . '()))...
8e30: 28 6c 61 73 74 74 70 61 74 68 20 22 2f 64 6f 65 (lasttpath "/doe
8e40: 73 2f 6e 6f 74 2f 65 78 69 73 74 2f 49 2f 68 6f s/not/exist/I/ho
8e50: 70 65 22 29 29 0a 09 20 20 20 28 64 65 62 75 67 pe")).. (debug
8e60: 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 34 20 22 72 :print-info 4 "r
8e70: 75 6e 73 3a 6f 70 65 72 61 74 65 2d 6f 6e 20 72 uns:operate-on r
8e80: 75 6e 3d 22 20 72 75 6e 20 22 2c 20 68 65 61 64 un=" run ", head
8e90: 65 72 3d 22 20 68 65 61 64 65 72 29 0a 09 20 20 er=" header)..
8ea0: 20 28 69 66 20 28 6e 6f 74 20 28 6e 75 6c 6c 3f (if (not (null?
8eb0: 20 74 65 73 74 73 29 29 0a 09 20 20 20 20 20 20 tests))..
8ec0: 20 28 62 65 67 69 6e 0a 09 09 20 28 63 61 73 65 (begin... (case
8ed0: 20 61 63 74 69 6f 6e 0a 09 09 20 20 20 28 28 72 action... ((r
8ee0: 65 6d 6f 76 65 2d 72 75 6e 73 29 0a 09 09 20 20 emove-runs)...
8ef0: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 31 (debug:print 1
8f00: 20 22 52 65 6d 6f 76 69 6e 67 20 74 65 73 74 73 "Removing tests
8f10: 20 66 6f 72 20 72 75 6e 3a 20 22 20 72 75 6e 6b for run: " runk
8f20: 65 79 20 22 20 22 20 28 64 62 3a 67 65 74 2d 76 ey " " (db:get-v
8f30: 61 6c 75 65 2d 62 79 2d 68 65 61 64 65 72 20 72 alue-by-header r
8f40: 75 6e 20 68 65 61 64 65 72 20 22 72 75 6e 6e 61 un header "runna
8f50: 6d 65 22 29 29 29 0a 09 09 20 20 20 28 28 73 65 me")))... ((se
8f60: 74 2d 73 74 61 74 65 2d 73 74 61 74 75 73 29 0a t-state-status).
8f70: 09 09 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 .. (debug:pri
8f80: 6e 74 20 31 20 22 4d 6f 64 69 66 79 69 6e 67 20 nt 1 "Modifying
8f90: 73 74 61 74 65 20 61 6e 64 20 73 74 61 75 73 20 state and staus
8fa0: 66 6f 72 20 74 65 73 74 73 20 66 6f 72 20 72 75 for tests for ru
8fb0: 6e 3a 20 22 20 72 75 6e 6b 65 79 20 22 20 22 20 n: " runkey " "
8fc0: 28 64 62 3a 67 65 74 2d 76 61 6c 75 65 2d 62 79 (db:get-value-by
8fd0: 2d 68 65 61 64 65 72 20 72 75 6e 20 68 65 61 64 -header run head
8fe0: 65 72 20 22 72 75 6e 6e 61 6d 65 22 29 29 29 0a er "runname"))).
8ff0: 09 09 20 20 20 28 28 70 72 69 6e 74 2d 72 75 6e .. ((print-run
9000: 29 0a 09 09 20 20 20 20 28 64 65 62 75 67 3a 70 )... (debug:p
9010: 72 69 6e 74 20 31 20 22 50 72 69 6e 74 69 6e 67 rint 1 "Printing
9020: 20 69 6e 66 6f 20 66 6f 72 20 72 75 6e 20 22 20 info for run "
9030: 72 75 6e 6b 65 79 20 22 2c 20 72 75 6e 3d 22 20 runkey ", run="
9040: 72 75 6e 20 22 2c 20 74 65 73 74 73 3d 22 20 74 run ", tests=" t
9050: 65 73 74 73 20 22 2c 20 68 65 61 64 65 72 3d 22 ests ", header="
9060: 20 68 65 61 64 65 72 29 0a 09 09 20 20 20 20 61 header)... a
9070: 63 74 69 6f 6e 29 0a 09 09 20 20 20 28 65 6c 73 ction)... (els
9080: 65 0a 09 09 20 20 20 20 28 64 65 62 75 67 3a 70 e... (debug:p
9090: 72 69 6e 74 2d 69 6e 66 6f 20 30 20 22 61 63 74 rint-info 0 "act
90a0: 69 6f 6e 20 6e 6f 74 20 72 65 63 6f 67 6e 69 73 ion not recognis
90b0: 65 64 20 22 20 61 63 74 69 6f 6e 29 29 29 0a 09 ed " action)))..
90c0: 09 20 28 66 6f 72 2d 65 61 63 68 0a 09 09 20 20 . (for-each...
90d0: 28 6c 61 6d 62 64 61 20 28 74 65 73 74 29 0a 09 (lambda (test)..
90e0: 09 20 20 20 20 28 6c 65 74 2a 20 28 28 69 74 65 . (let* ((ite
90f0: 6d 2d 70 61 74 68 20 28 64 62 3a 74 65 73 74 2d m-path (db:test-
9100: 67 65 74 2d 69 74 65 6d 2d 70 61 74 68 20 74 65 get-item-path te
9110: 73 74 29 29 0a 09 09 09 20 20 20 28 74 65 73 74 st)).... (test
9120: 2d 6e 61 6d 65 20 28 64 62 3a 74 65 73 74 2d 67 -name (db:test-g
9130: 65 74 2d 74 65 73 74 6e 61 6d 65 20 74 65 73 74 et-testname test
9140: 29 29 0a 09 09 09 20 20 20 28 72 75 6e 2d 64 69 )).... (run-di
9150: 72 20 20 20 28 64 62 3a 74 65 73 74 2d 67 65 74 r (db:test-get
9160: 2d 72 75 6e 64 69 72 20 74 65 73 74 29 29 20 20 -rundir test))
9170: 20 20 3b 3b 20 72 75 6e 20 64 69 72 20 69 73 20 ;; run dir is
9180: 66 72 6f 6d 20 74 68 65 20 6c 69 6e 6b 20 74 72 from the link tr
9190: 65 65 0a 09 09 09 20 20 20 28 72 65 61 6c 2d 64 ee.... (real-d
91a0: 69 72 20 20 28 69 66 20 28 66 69 6c 65 2d 65 78 ir (if (file-ex
91b0: 69 73 74 73 3f 20 72 75 6e 2d 64 69 72 29 0a 09 ists? run-dir)..
91c0: 09 09 09 09 20 20 28 72 65 73 6f 6c 76 65 2d 70 .... (resolve-p
91d0: 61 74 68 6e 61 6d 65 20 72 75 6e 2d 64 69 72 29 athname run-dir)
91e0: 0a 09 09 09 09 09 20 20 23 66 29 29 0a 09 09 09 ...... #f))....
91f0: 20 20 20 28 74 65 73 74 2d 69 64 20 20 20 28 64 (test-id (d
9200: 62 3a 74 65 73 74 2d 67 65 74 2d 69 64 20 74 65 b:test-get-id te
9210: 73 74 29 29 29 0a 09 09 20 20 20 20 20 20 3b 3b st)))... ;;
9220: 20 20 20 28 74 64 62 20 20 20 20 20 20 20 28 64 (tdb (d
9230: 62 3a 6f 70 65 6e 2d 74 65 73 74 2d 64 62 20 72 b:open-test-db r
9240: 75 6e 2d 64 69 72 29 29 29 0a 09 09 20 20 20 20 un-dir)))...
9250: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 (debug:print-i
9260: 6e 66 6f 20 34 20 22 74 65 73 74 3d 22 20 74 65 nfo 4 "test=" te
9270: 73 74 29 20 3b 3b 20 20 20 22 20 28 64 62 3a 74 st) ;; " (db:t
9280: 65 73 74 2d 67 65 74 2d 74 65 73 74 6e 61 6d 65 est-get-testname
9290: 20 74 65 73 74 29 20 22 20 69 64 3a 20 22 20 28 test) " id: " (
92a0: 64 62 3a 74 65 73 74 2d 67 65 74 2d 69 64 20 74 db:test-get-id t
92b0: 65 73 74 29 20 22 20 22 20 69 74 65 6d 2d 70 61 est) " " item-pa
92c0: 74 68 20 22 20 61 63 74 69 6f 6e 3a 20 22 20 61 th " action: " a
92d0: 63 74 69 6f 6e 29 0a 09 09 20 20 20 20 20 20 28 ction)... (
92e0: 63 61 73 65 20 61 63 74 69 6f 6e 0a 09 09 09 28 case action....(
92f0: 28 72 65 6d 6f 76 65 2d 72 75 6e 73 29 20 3b 3b (remove-runs) ;;
9300: 20 74 68 65 20 74 64 62 20 69 73 20 66 6f 72 20 the tdb is for
9310: 66 75 74 75 72 65 20 70 6f 73 73 69 62 6c 65 2e future possible.
9320: 20 0a 09 09 09 20 28 6f 70 65 6e 2d 72 75 6e 2d .... (open-run-
9330: 63 6c 6f 73 65 20 64 62 3a 64 65 6c 65 74 65 2d close db:delete-
9340: 74 65 73 74 2d 72 65 63 6f 72 64 73 20 64 62 20 test-records db
9350: 23 66 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d #f (db:test-get-
9360: 69 64 20 74 65 73 74 29 29 0a 09 09 09 20 28 64 id test)).... (d
9370: 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 ebug:print-info
9380: 31 20 22 41 74 74 65 6d 70 74 69 6e 67 20 74 6f 1 "Attempting to
9390: 20 72 65 6d 6f 76 65 20 22 20 28 69 66 20 72 65 remove " (if re
93a0: 61 6c 2d 64 69 72 20 28 63 6f 6e 63 20 22 20 64 al-dir (conc " d
93b0: 69 72 20 22 20 72 65 61 6c 2d 64 69 72 20 22 20 ir " real-dir "
93c0: 61 6e 64 20 22 29 20 22 22 29 20 22 20 6c 69 6e and ") "") " lin
93d0: 6b 20 22 20 72 75 6e 2d 64 69 72 29 0a 09 09 09 k " run-dir)....
93e0: 20 28 69 66 20 28 61 6e 64 20 72 65 61 6c 2d 64 (if (and real-d
93f0: 69 72 20 0a 09 09 09 09 20 20 28 3e 20 28 73 74 ir ..... (> (st
9400: 72 69 6e 67 2d 6c 65 6e 67 74 68 20 72 65 61 6c ring-length real
9410: 2d 64 69 72 29 20 35 29 0a 09 09 09 09 20 20 28 -dir) 5)..... (
9420: 66 69 6c 65 2d 65 78 69 73 74 73 3f 20 72 65 61 file-exists? rea
9430: 6c 2d 64 69 72 29 29 20 3b 3b 20 62 61 64 20 68 l-dir)) ;; bad h
9440: 65 75 72 69 73 74 69 63 20 62 75 74 20 73 68 6f euristic but sho
9450: 75 6c 64 20 70 72 65 76 65 6e 74 20 2f 74 6d 70 uld prevent /tmp
9460: 20 2f 68 6f 6d 65 20 65 74 63 2e 0a 09 09 09 20 /home etc.....
9470: 20 20 20 20 28 62 65 67 69 6e 20 3b 3b 20 6c 65 (begin ;; le
9480: 74 2a 20 28 28 72 65 61 6c 70 61 74 68 20 28 72 t* ((realpath (r
9490: 65 73 6f 6c 76 65 2d 70 61 74 68 6e 61 6d 65 20 esolve-pathname
94a0: 72 75 6e 2d 64 69 72 29 29 29 0a 09 09 09 20 20 run-dir)))....
94b0: 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e (debug:prin
94c0: 74 2d 69 6e 66 6f 20 31 20 22 52 65 63 75 72 73 t-info 1 "Recurs
94d0: 69 76 65 6c 79 20 72 65 6d 6f 76 69 6e 67 20 22 ively removing "
94e0: 20 72 65 61 6c 2d 64 69 72 29 0a 09 09 09 20 20 real-dir)....
94f0: 20 20 20 20 20 28 69 66 20 28 66 69 6c 65 2d 65 (if (file-e
9500: 78 69 73 74 73 3f 20 72 65 61 6c 2d 64 69 72 29 xists? real-dir)
9510: 0a 09 09 09 09 20 20 20 28 69 66 20 28 3e 20 28 ..... (if (> (
9520: 73 79 73 74 65 6d 20 28 63 6f 6e 63 20 22 72 6d system (conc "rm
9530: 20 2d 72 66 20 22 20 72 65 61 6c 2d 64 69 72 29 -rf " real-dir)
9540: 29 20 30 29 0a 09 09 09 09 20 20 20 20 20 20 20 ) 0).....
9550: 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 22 (debug:print 0 "
9560: 45 52 52 4f 52 3a 20 54 68 65 72 65 20 77 61 73 ERROR: There was
9570: 20 61 20 70 72 6f 62 6c 65 6d 20 72 65 6d 6f 76 a problem remov
9580: 69 6e 67 20 22 20 72 65 61 6c 2d 64 69 72 20 22 ing " real-dir "
9590: 20 77 69 74 68 20 72 6d 20 2d 66 22 29 29 0a 09 with rm -f"))..
95a0: 09 09 09 20 20 20 28 64 65 62 75 67 3a 70 72 69 ... (debug:pri
95b0: 6e 74 20 30 20 22 57 41 52 4e 49 4e 47 3a 20 74 nt 0 "WARNING: t
95c0: 65 73 74 20 64 69 72 20 22 20 72 65 61 6c 2d 64 est dir " real-d
95d0: 69 72 20 22 20 61 70 70 65 61 72 73 20 74 6f 20 ir " appears to
95e0: 6e 6f 74 20 65 78 69 73 74 20 6f 72 20 69 73 20 not exist or is
95f0: 6e 6f 74 20 72 65 61 64 61 62 6c 65 22 29 29 29 not readable")))
9600: 0a 09 09 09 20 20 20 20 20 28 69 66 20 72 65 61 .... (if rea
9610: 6c 2d 64 69 72 20 0a 09 09 09 09 20 28 64 65 62 l-dir ..... (deb
9620: 75 67 3a 70 72 69 6e 74 20 30 20 22 57 41 52 4e ug:print 0 "WARN
9630: 49 4e 47 3a 20 64 69 72 65 63 74 6f 72 79 20 22 ING: directory "
9640: 20 72 65 61 6c 2d 64 69 72 20 22 20 64 6f 65 73 real-dir " does
9650: 20 6e 6f 74 20 65 78 69 73 74 22 29 0a 09 09 09 not exist")....
9660: 09 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 . (debug:print 0
9670: 20 22 57 41 52 4e 49 4e 47 3a 20 6e 6f 20 72 65 "WARNING: no re
9680: 61 6c 20 64 69 72 65 63 74 6f 72 79 20 63 6f 72 al directory cor
9690: 72 6f 73 70 6f 6e 64 69 6e 67 20 74 6f 20 6c 69 rosponding to li
96a0: 6e 6b 20 22 20 72 75 6e 2d 64 69 72 20 22 2c 20 nk " run-dir ",
96b0: 6e 6f 74 68 69 6e 67 20 64 6f 6e 65 22 29 29 29 nothing done")))
96c0: 0a 09 09 09 20 28 69 66 20 28 73 79 6d 62 6f 6c .... (if (symbol
96d0: 69 63 2d 6c 69 6e 6b 3f 20 72 75 6e 2d 64 69 72 ic-link? run-dir
96e0: 29 0a 09 09 09 20 20 20 20 20 28 62 65 67 69 6e ).... (begin
96f0: 0a 09 09 09 20 20 20 20 20 20 20 28 64 65 62 75 .... (debu
9700: 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 31 20 22 g:print-info 1 "
9710: 52 65 6d 6f 76 69 6e 67 20 73 79 6d 6c 69 6e 6b Removing symlink
9720: 20 22 20 72 75 6e 2d 64 69 72 29 0a 09 09 09 20 " run-dir)....
9730: 20 20 20 20 20 20 28 64 65 6c 65 74 65 2d 66 69 (delete-fi
9740: 6c 65 20 72 75 6e 2d 64 69 72 29 29 0a 09 09 09 le run-dir))....
9750: 20 20 20 20 20 28 69 66 20 28 64 69 72 65 63 74 (if (direct
9760: 6f 72 79 3f 20 72 75 6e 2d 64 69 72 29 0a 09 09 ory? run-dir)...
9770: 09 09 20 28 69 66 20 28 3e 20 28 64 69 72 65 63 .. (if (> (direc
9780: 74 6f 72 79 2d 66 6f 6c 64 20 28 6c 61 6d 62 64 tory-fold (lambd
9790: 61 20 28 66 20 78 29 28 2b 20 31 20 78 29 29 20 a (f x)(+ 1 x))
97a0: 30 20 72 75 6e 2d 64 69 72 29 20 30 29 0a 09 09 0 run-dir) 0)...
97b0: 09 09 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 .. (debug:pr
97c0: 69 6e 74 20 30 20 22 57 41 52 4e 49 4e 47 3a 20 int 0 "WARNING:
97d0: 72 65 66 75 73 69 6e 67 20 74 6f 20 72 65 6d 6f refusing to remo
97e0: 76 65 20 22 20 72 75 6e 2d 64 69 72 20 22 20 61 ve " run-dir " a
97f0: 73 20 69 74 20 69 73 20 6e 6f 74 20 65 6d 70 74 s it is not empt
9800: 79 22 29 0a 09 09 09 09 20 20 20 20 20 28 64 65 y")..... (de
9810: 6c 65 74 65 2d 64 69 72 65 63 74 6f 72 79 20 72 lete-directory r
9820: 75 6e 2d 64 69 72 29 29 20 3b 3b 20 69 74 20 73 un-dir)) ;; it s
9830: 68 6f 75 6c 64 20 62 65 20 65 6d 70 74 79 20 62 hould be empty b
9840: 79 20 68 65 72 65 20 42 55 47 20 42 55 47 2c 20 y here BUG BUG,
9850: 61 64 64 20 65 72 72 6f 72 20 63 61 74 63 68 0a add error catch.
9860: 09 09 09 09 20 28 69 66 20 72 75 6e 2d 64 69 72 .... (if run-dir
9870: 0a 09 09 09 09 20 20 20 20 20 28 64 65 62 75 67 ..... (debug
9880: 3a 70 72 69 6e 74 20 30 20 22 57 41 52 4e 49 4e :print 0 "WARNIN
9890: 47 3a 20 6e 6f 74 20 72 65 6d 6f 76 69 6e 67 20 G: not removing
98a0: 22 20 72 75 6e 2d 64 69 72 20 22 20 61 73 20 69 " run-dir " as i
98b0: 74 20 65 69 74 68 65 72 20 64 6f 65 73 6e 27 74 t either doesn't
98c0: 20 65 78 69 73 74 20 6f 72 20 69 73 20 6e 6f 74 exist or is not
98d0: 20 61 20 73 79 6d 6c 69 6e 6b 22 29 0a 09 09 09 a symlink")....
98e0: 09 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 . (debug:pri
98f0: 6e 74 20 30 20 22 4e 4f 54 45 3a 20 74 68 65 20 nt 0 "NOTE: the
9900: 72 75 6e 20 64 69 72 20 66 6f 72 20 74 68 69 73 run dir for this
9910: 20 74 65 73 74 20 69 73 20 75 6e 64 65 66 69 6e test is undefin
9920: 65 64 2e 20 54 65 73 74 20 6d 61 79 20 68 61 76 ed. Test may hav
9930: 65 20 61 6c 72 65 61 64 79 20 62 65 65 6e 20 64 e already been d
9940: 65 6c 65 74 65 64 2e 22 29 29 0a 09 09 09 09 20 eleted.")).....
9950: 29 29 29 0a 09 09 09 28 28 73 65 74 2d 73 74 61 )))....((set-sta
9960: 74 65 2d 73 74 61 74 75 73 29 0a 09 09 09 20 28 te-status).... (
9970: 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f debug:print-info
9980: 20 32 20 22 6e 65 77 20 73 74 61 74 65 20 22 20 2 "new state "
9990: 28 63 61 72 20 73 74 61 74 65 2d 73 74 61 74 75 (car state-statu
99a0: 73 29 20 22 2c 20 6e 65 77 20 73 74 61 74 75 73 s) ", new status
99b0: 20 22 20 28 63 61 64 72 20 73 74 61 74 65 2d 73 " (cadr state-s
99c0: 74 61 74 75 73 29 29 0a 09 09 09 20 28 6f 70 65 tatus)).... (ope
99d0: 6e 2d 72 75 6e 2d 63 6c 6f 73 65 20 64 62 3a 74 n-run-close db:t
99e0: 65 73 74 2d 73 65 74 2d 73 74 61 74 65 2d 73 74 est-set-state-st
99f0: 61 74 75 73 2d 62 79 2d 69 64 20 64 62 20 28 64 atus-by-id db (d
9a00: 62 3a 74 65 73 74 2d 67 65 74 2d 69 64 20 74 65 b:test-get-id te
9a10: 73 74 29 20 28 63 61 72 20 73 74 61 74 65 2d 73 st) (car state-s
9a20: 74 61 74 75 73 29 28 63 61 64 72 20 73 74 61 74 tatus)(cadr stat
9a30: 65 2d 73 74 61 74 75 73 29 20 23 66 29 29 29 29 e-status) #f))))
9a40: 29 0a 09 09 20 20 28 73 6f 72 74 20 74 65 73 74 )... (sort test
9a50: 73 20 28 6c 61 6d 62 64 61 20 28 61 20 62 29 28 s (lambda (a b)(
9a60: 6c 65 74 20 28 28 64 69 72 61 20 28 64 62 3a 74 let ((dira (db:t
9a70: 65 73 74 2d 67 65 74 2d 72 75 6e 64 69 72 20 61 est-get-rundir a
9a80: 29 29 0a 09 09 09 09 09 09 20 28 64 69 72 62 20 ))....... (dirb
9a90: 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 72 75 6e (db:test-get-run
9aa0: 64 69 72 20 62 29 29 29 0a 09 09 09 09 09 20 20 dir b)))......
9ab0: 20 20 20 28 69 66 20 28 61 6e 64 20 28 73 74 72 (if (and (str
9ac0: 69 6e 67 3f 20 64 69 72 61 29 28 73 74 72 69 6e ing? dira)(strin
9ad0: 67 3f 20 64 69 72 62 29 29 0a 09 09 09 09 09 09 g? dirb)).......
9ae0: 20 28 3e 20 28 73 74 72 69 6e 67 2d 6c 65 6e 67 (> (string-leng
9af0: 74 68 20 64 69 72 61 29 28 73 74 72 69 6e 67 2d th dira)(string-
9b00: 6c 65 6e 67 74 68 20 64 69 72 62 29 29 0a 09 09 length dirb))...
9b10: 09 09 09 09 20 23 66 29 29 29 29 29 29 29 0a 09 .... #f)))))))..
9b20: 20 20 20 3b 3b 20 72 65 6d 6f 76 65 20 74 68 65 ;; remove the
9b30: 20 72 75 6e 20 69 66 20 7a 65 72 6f 20 74 65 73 run if zero tes
9b40: 74 73 20 72 65 6d 61 69 6e 0a 09 20 20 20 28 69 ts remain.. (i
9b50: 66 20 28 65 71 3f 20 61 63 74 69 6f 6e 20 27 72 f (eq? action 'r
9b60: 65 6d 6f 76 65 2d 72 75 6e 73 29 0a 09 20 20 20 emove-runs)..
9b70: 20 20 20 20 28 6c 65 74 20 28 28 72 65 6d 74 65 (let ((remte
9b80: 73 74 73 20 28 6f 70 65 6e 2d 72 75 6e 2d 63 6c sts (open-run-cl
9b90: 6f 73 65 20 64 62 3a 67 65 74 2d 74 65 73 74 73 ose db:get-tests
9ba0: 2d 66 6f 72 2d 72 75 6e 20 64 62 20 28 64 62 3a -for-run db (db:
9bb0: 67 65 74 2d 76 61 6c 75 65 2d 62 79 2d 68 65 61 get-value-by-hea
9bc0: 64 65 72 20 72 75 6e 20 68 65 61 64 65 72 20 22 der run header "
9bd0: 69 64 22 29 20 23 66 20 27 28 22 44 45 4c 45 54 id") #f '("DELET
9be0: 45 44 22 29 20 27 28 22 6e 2f 61 22 29 20 6e 6f ED") '("n/a") no
9bf0: 74 2d 69 6e 3a 20 23 74 29 29 29 0a 09 09 20 28 t-in: #t)))... (
9c00: 69 66 20 28 6e 75 6c 6c 3f 20 72 65 6d 74 65 73 if (null? remtes
9c10: 74 73 29 20 3b 3b 20 6e 6f 20 6d 6f 72 65 20 74 ts) ;; no more t
9c20: 65 73 74 73 20 72 65 6d 61 69 6e 69 6e 67 0a 09 ests remaining..
9c30: 09 20 20 20 20 20 28 6c 65 74 2a 20 28 28 64 70 . (let* ((dp
9c40: 61 72 74 73 20 20 28 73 74 72 69 6e 67 2d 73 70 arts (string-sp
9c50: 6c 69 74 20 6c 61 73 74 74 70 61 74 68 20 22 2f lit lasttpath "/
9c60: 22 29 29 0a 09 09 09 20 20 20 20 28 72 75 6e 70 ")).... (runp
9c70: 61 74 68 20 28 63 6f 6e 63 20 22 2f 22 20 28 73 ath (conc "/" (s
9c80: 74 72 69 6e 67 2d 69 6e 74 65 72 73 70 65 72 73 tring-interspers
9c90: 65 20 0a 09 09 09 09 09 09 28 74 61 6b 65 20 64 e .......(take d
9ca0: 70 61 72 74 73 20 28 2d 20 28 6c 65 6e 67 74 68 parts (- (length
9cb0: 20 64 70 61 72 74 73 29 20 31 29 29 0a 09 09 09 dparts) 1))....
9cc0: 09 09 09 22 2f 22 29 29 29 29 0a 09 09 20 20 20 ..."/"))))...
9cd0: 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 (debug:print
9ce0: 20 31 20 22 52 65 6d 6f 76 69 6e 67 20 72 75 6e 1 "Removing run
9cf0: 3a 20 22 20 72 75 6e 6b 65 79 20 22 20 22 20 28 : " runkey " " (
9d00: 64 62 3a 67 65 74 2d 76 61 6c 75 65 2d 62 79 2d db:get-value-by-
9d10: 68 65 61 64 65 72 20 72 75 6e 20 68 65 61 64 65 header run heade
9d20: 72 20 22 72 75 6e 6e 61 6d 65 22 29 20 22 20 61 r "runname") " a
9d30: 6e 64 20 72 65 6c 61 74 65 64 20 72 65 63 6f 72 nd related recor
9d40: 64 22 29 0a 09 09 20 20 20 20 20 20 20 28 6f 70 d")... (op
9d50: 65 6e 2d 72 75 6e 2d 63 6c 6f 73 65 20 64 62 3a en-run-close db:
9d60: 64 65 6c 65 74 65 2d 72 75 6e 20 64 62 20 72 75 delete-run db ru
9d70: 6e 2d 69 64 29 0a 09 09 20 20 20 20 20 20 20 3b n-id)... ;
9d80: 3b 20 54 68 69 73 20 69 73 20 61 20 70 72 65 74 ; This is a pret
9d90: 74 79 20 67 6f 6f 64 20 70 6c 61 63 65 20 74 6f ty good place to
9da0: 20 70 75 72 67 65 20 6f 6c 64 20 44 45 4c 45 54 purge old DELET
9db0: 45 44 20 74 65 73 74 73 0a 09 09 20 20 20 20 20 ED tests...
9dc0: 20 20 28 6f 70 65 6e 2d 72 75 6e 2d 63 6c 6f 73 (open-run-clos
9dd0: 65 20 64 62 3a 64 65 6c 65 74 65 2d 74 65 73 74 e db:delete-test
9de0: 73 2d 66 6f 72 2d 72 75 6e 20 64 62 20 72 75 6e s-for-run db run
9df0: 2d 69 64 29 0a 09 09 20 20 20 20 20 20 20 28 6f -id)... (o
9e00: 70 65 6e 2d 72 75 6e 2d 63 6c 6f 73 65 20 64 62 pen-run-close db
9e10: 3a 64 65 6c 65 74 65 2d 6f 6c 64 2d 64 65 6c 65 :delete-old-dele
9e20: 74 65 64 2d 74 65 73 74 2d 72 65 63 6f 72 64 73 ted-test-records
9e30: 20 64 62 29 0a 09 09 20 20 20 20 20 20 20 28 6f db)... (o
9e40: 70 65 6e 2d 72 75 6e 2d 63 6c 6f 73 65 20 64 62 pen-run-close db
9e50: 3a 73 65 74 2d 76 61 72 20 64 62 20 22 44 45 4c :set-var db "DEL
9e60: 45 54 45 44 5f 54 45 53 54 53 22 20 28 63 75 72 ETED_TESTS" (cur
9e70: 72 65 6e 74 2d 73 65 63 6f 6e 64 73 29 29 0a 09 rent-seconds))..
9e80: 09 20 20 20 20 20 20 20 3b 3b 20 6e 65 65 64 20 . ;; need
9e90: 74 6f 20 66 69 67 75 72 65 20 6f 75 74 20 74 68 to figure out th
9ea0: 65 20 70 61 74 68 20 74 6f 20 74 68 65 20 72 75 e path to the ru
9eb0: 6e 20 64 69 72 20 61 6e 64 20 72 65 6d 6f 76 65 n dir and remove
9ec0: 20 69 74 20 69 66 20 65 6d 70 74 79 0a 09 09 20 it if empty...
9ed0: 20 20 20 20 20 20 3b 3b 20 20 20 20 28 69 66 20 ;; (if
9ee0: 28 6e 75 6c 6c 3f 20 28 67 6c 6f 62 20 28 63 6f (null? (glob (co
9ef0: 6e 63 20 72 75 6e 70 61 74 68 20 22 2f 2a 22 29 nc runpath "/*")
9f00: 29 29 0a 09 09 20 20 20 20 20 20 20 3b 3b 20 20 ))... ;;
9f10: 20 20 20 20 20 20 28 62 65 67 69 6e 0a 09 09 20 (begin...
9f20: 20 20 20 20 20 20 3b 3b 20 09 20 28 64 65 62 75 ;; . (debu
9f30: 67 3a 70 72 69 6e 74 20 31 20 22 52 65 6d 6f 76 g:print 1 "Remov
9f40: 69 6e 67 20 72 75 6e 20 64 69 72 20 22 20 72 75 ing run dir " ru
9f50: 6e 70 61 74 68 29 0a 09 09 20 20 20 20 20 20 20 npath)...
9f60: 3b 3b 20 09 20 28 73 79 73 74 65 6d 20 28 63 6f ;; . (system (co
9f70: 6e 63 20 22 72 6d 64 69 72 20 2d 70 20 22 20 72 nc "rmdir -p " r
9f80: 75 6e 70 61 74 68 29 29 29 29 0a 09 09 20 20 20 unpath))))...
9f90: 20 20 20 20 29 29 29 29 29 0a 09 20 29 29 0a 20 ))))).. )).
9fa0: 20 20 20 20 72 75 6e 73 29 29 0a 20 20 23 74 29 runs)). #t)
9fb0: 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ..;;============
9fc0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
9fd0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
9fe0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
9ff0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 52 6f ==========.;; Ro
a000: 75 74 69 6e 65 73 20 66 6f 72 20 6d 61 6e 69 70 utines for manip
a010: 75 6c 61 74 69 6e 67 20 72 75 6e 73 0a 3b 3b 3d ulating runs.;;=
a020: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
a030: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
a040: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
a050: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
a060: 3d 3d 3d 3d 3d 0a 0a 3b 3b 20 53 69 6e 63 65 20 =====..;; Since
a070: 6d 61 6e 79 20 63 61 6c 6c 73 20 74 6f 20 61 20 many calls to a
a080: 72 75 6e 20 72 65 71 75 69 72 65 20 70 72 65 74 run require pret
a090: 74 79 20 6d 75 63 68 20 74 68 65 20 73 61 6d 65 ty much the same
a0a0: 20 73 65 74 75 70 20 0a 3b 3b 20 74 68 69 73 20 setup .;; this
a0b0: 77 72 61 70 70 65 72 20 69 73 20 75 73 65 64 20 wrapper is used
a0c0: 74 6f 20 72 65 64 75 63 65 20 74 68 65 20 72 65 to reduce the re
a0d0: 70 6c 69 63 61 74 69 6f 6e 20 6f 66 20 63 6f 64 plication of cod
a0e0: 65 0a 28 64 65 66 69 6e 65 20 28 67 65 6e 65 72 e.(define (gener
a0f0: 61 6c 2d 72 75 6e 2d 63 61 6c 6c 20 73 77 69 74 al-run-call swit
a100: 63 68 6e 61 6d 65 20 61 63 74 69 6f 6e 2d 64 65 chname action-de
a110: 73 63 20 70 72 6f 63 29 0a 20 20 28 6c 65 74 20 sc proc). (let
a120: 28 28 72 75 6e 6e 61 6d 65 20 28 61 72 67 73 3a ((runname (args:
a130: 67 65 74 2d 61 72 67 20 22 3a 72 75 6e 6e 61 6d get-arg ":runnam
a140: 65 22 29 29 0a 09 28 74 61 72 67 65 74 20 20 28 e"))..(target (
a150: 69 66 20 28 61 72 67 73 3a 67 65 74 2d 61 72 67 if (args:get-arg
a160: 20 22 2d 74 61 72 67 65 74 22 29 0a 09 09 20 20 "-target")...
a170: 20 20 20 28 61 72 67 73 3a 67 65 74 2d 61 72 67 (args:get-arg
a180: 20 22 2d 74 61 72 67 65 74 22 29 0a 09 09 20 20 "-target")...
a190: 20 20 20 28 61 72 67 73 3a 67 65 74 2d 61 72 67 (args:get-arg
a1a0: 20 22 2d 72 65 71 74 61 72 67 22 29 29 29 0a 09 "-reqtarg")))..
a1b0: 28 74 68 31 20 20 20 20 20 23 66 29 29 0a 20 20 (th1 #f)).
a1c0: 20 20 28 63 6f 6e 64 0a 20 20 20 20 20 28 28 6e (cond. ((n
a1d0: 6f 74 20 74 61 72 67 65 74 29 0a 20 20 20 20 20 ot target).
a1e0: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 (debug:print 0
a1f0: 22 45 52 52 4f 52 3a 20 4d 69 73 73 69 6e 67 20 "ERROR: Missing
a200: 72 65 71 75 69 72 65 64 20 70 61 72 61 6d 65 74 required paramet
a210: 65 72 20 66 6f 72 20 22 20 73 77 69 74 63 68 6e er for " switchn
a220: 61 6d 65 20 22 2c 20 79 6f 75 20 6d 75 73 74 20 ame ", you must
a230: 73 70 65 63 69 66 79 20 74 68 65 20 74 61 72 67 specify the targ
a240: 65 74 20 77 69 74 68 20 2d 74 61 72 67 65 74 22 et with -target"
a250: 29 0a 20 20 20 20 20 20 28 65 78 69 74 20 33 29 ). (exit 3)
a260: 29 0a 20 20 20 20 20 28 28 6e 6f 74 20 72 75 6e ). ((not run
a270: 6e 61 6d 65 29 0a 20 20 20 20 20 20 28 64 65 62 name). (deb
a280: 75 67 3a 70 72 69 6e 74 20 30 20 22 45 52 52 4f ug:print 0 "ERRO
a290: 52 3a 20 4d 69 73 73 69 6e 67 20 72 65 71 75 69 R: Missing requi
a2a0: 72 65 64 20 70 61 72 61 6d 65 74 65 72 20 66 6f red parameter fo
a2b0: 72 20 22 20 73 77 69 74 63 68 6e 61 6d 65 20 22 r " switchname "
a2c0: 2c 20 79 6f 75 20 6d 75 73 74 20 73 70 65 63 69 , you must speci
a2d0: 66 79 20 74 68 65 20 72 75 6e 20 6e 61 6d 65 20 fy the run name
a2e0: 77 69 74 68 20 3a 72 75 6e 6e 61 6d 65 20 72 75 with :runname ru
a2f0: 6e 6e 61 6d 65 22 29 0a 20 20 20 20 20 20 28 65 nname"). (e
a300: 78 69 74 20 33 29 29 0a 20 20 20 20 20 28 65 6c xit 3)). (el
a310: 73 65 0a 20 20 20 20 20 20 28 6c 65 74 20 28 28 se. (let ((
a320: 64 62 20 20 20 23 66 29 0a 09 20 20 20 20 28 6b db #f).. (k
a330: 65 79 73 20 23 66 29 29 0a 09 28 69 66 20 28 6e eys #f))..(if (n
a340: 6f 74 20 28 73 65 74 75 70 2d 66 6f 72 2d 72 75 ot (setup-for-ru
a350: 6e 29 29 0a 09 20 20 20 20 28 62 65 67 69 6e 20 n)).. (begin
a360: 0a 09 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 .. (debug:p
a370: 72 69 6e 74 20 30 20 22 46 61 69 6c 65 64 20 74 rint 0 "Failed t
a380: 6f 20 73 65 74 75 70 2c 20 65 78 69 74 69 6e 67 o setup, exiting
a390: 22 29 0a 09 20 20 20 20 20 20 28 65 78 69 74 20 ").. (exit
a3a0: 31 29 29 29 0a 09 28 69 66 20 28 61 72 67 73 3a 1)))..(if (args:
a3b0: 67 65 74 2d 61 72 67 20 22 2d 73 65 72 76 65 72 get-arg "-server
a3c0: 22 29 0a 09 20 20 20 20 28 6f 70 65 6e 2d 72 75 ").. (open-ru
a3d0: 6e 2d 63 6c 6f 73 65 20 73 65 72 76 65 72 3a 73 n-close server:s
a3e0: 74 61 72 74 20 64 62 20 28 61 72 67 73 3a 67 65 tart db (args:ge
a3f0: 74 2d 61 72 67 20 22 2d 73 65 72 76 65 72 22 29 t-arg "-server")
a400: 29 0a 20 09 20 20 20 20 28 69 66 20 28 6e 6f 74 ). . (if (not
a410: 20 28 6f 72 20 28 61 72 67 73 3a 67 65 74 2d 61 (or (args:get-a
a420: 72 67 20 22 2d 72 75 6e 61 6c 6c 22 29 20 20 20 rg "-runall")
a430: 20 20 3b 3b 20 72 75 6e 61 6c 6c 20 61 6e 64 20 ;; runall and
a440: 72 75 6e 74 65 73 74 73 20 61 72 65 20 61 6c 6c runtests are all
a450: 6f 77 65 64 20 74 6f 20 62 65 20 73 65 72 76 65 owed to be serve
a460: 72 73 0a 20 09 09 09 20 28 61 72 67 73 3a 67 65 rs. ... (args:ge
a470: 74 2d 61 72 67 20 22 2d 72 75 6e 74 65 73 74 73 t-arg "-runtests
a480: 22 29 29 29 0a 09 09 28 73 65 72 76 65 72 3a 63 ")))...(server:c
a490: 6c 69 65 6e 74 2d 73 65 74 75 70 29 20 3b 3b 20 lient-setup) ;;
a4a0: 54 68 69 73 20 69 73 20 61 20 64 75 70 6c 69 63 This is a duplic
a4b0: 61 74 65 20 73 74 61 72 74 75 70 21 21 21 3f 3f ate startup!!!??
a4c0: 3f 20 42 55 47 3f 0a 09 09 29 29 0a 09 28 73 65 ? BUG?...))..(se
a4d0: 74 21 20 6b 65 79 73 20 28 6f 70 65 6e 2d 72 75 t! keys (open-ru
a4e0: 6e 2d 63 6c 6f 73 65 20 64 62 3a 67 65 74 2d 6b n-close db:get-k
a4f0: 65 79 73 20 64 62 29 29 0a 09 3b 3b 20 68 61 76 eys db))..;; hav
a500: 65 20 65 6e 6f 75 67 68 20 74 6f 20 70 72 6f 63 e enough to proc
a510: 65 73 73 20 2d 74 61 72 67 65 74 20 6f 72 20 2d ess -target or -
a520: 72 65 71 74 61 72 67 20 68 65 72 65 0a 09 28 69 reqtarg here..(i
a530: 66 20 28 61 72 67 73 3a 67 65 74 2d 61 72 67 20 f (args:get-arg
a540: 22 2d 72 65 71 74 61 72 67 22 29 0a 09 20 20 20 "-reqtarg")..
a550: 20 28 6c 65 74 2a 20 28 28 72 75 6e 63 6f 6e 66 (let* ((runconf
a560: 69 67 66 20 28 63 6f 6e 63 20 20 2a 74 6f 70 70 igf (conc *topp
a570: 61 74 68 2a 20 22 2f 72 75 6e 63 6f 6e 66 69 67 ath* "/runconfig
a580: 73 2e 63 6f 6e 66 69 67 22 29 29 20 3b 3b 20 44 s.config")) ;; D
a590: 4f 20 4e 4f 54 20 45 56 41 4c 55 41 54 45 20 41 O NOT EVALUATE A
a5a0: 4c 4c 20 0a 09 09 20 20 20 28 72 75 6e 63 6f 6e LL ... (runcon
a5b0: 66 69 67 20 20 28 72 65 61 64 2d 63 6f 6e 66 69 fig (read-confi
a5c0: 67 20 72 75 6e 63 6f 6e 66 69 67 66 20 23 66 20 g runconfigf #f
a5d0: 23 66 20 65 6e 76 69 72 6f 6e 2d 70 61 74 74 3a #f environ-patt:
a5e0: 20 23 66 29 29 29 20 0a 09 20 20 20 20 20 20 28 #f))) .. (
a5f0: 69 66 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 if (hash-table-r
a600: 65 66 2f 64 65 66 61 75 6c 74 20 72 75 6e 63 6f ef/default runco
a610: 6e 66 69 67 20 28 61 72 67 73 3a 67 65 74 2d 61 nfig (args:get-a
a620: 72 67 20 22 2d 72 65 71 74 61 72 67 22 29 20 23 rg "-reqtarg") #
a630: 66 29 0a 09 09 20 20 28 6b 65 79 73 3a 74 61 72 f)... (keys:tar
a640: 67 65 74 2d 73 65 74 2d 61 72 67 73 20 6b 65 79 get-set-args key
a650: 73 20 28 61 72 67 73 3a 67 65 74 2d 61 72 67 20 s (args:get-arg
a660: 22 2d 72 65 71 74 61 72 67 22 29 20 61 72 67 73 "-reqtarg") args
a670: 3a 61 72 67 2d 68 61 73 68 29 0a 09 09 20 20 28 :arg-hash)... (
a680: 62 65 67 69 6e 0a 09 09 20 20 20 20 28 64 65 62 begin... (deb
a690: 75 67 3a 70 72 69 6e 74 20 30 20 22 45 52 52 4f ug:print 0 "ERRO
a6a0: 52 3a 20 5b 22 20 28 61 72 67 73 3a 67 65 74 2d R: [" (args:get-
a6b0: 61 72 67 20 22 2d 72 65 71 74 61 72 67 22 29 20 arg "-reqtarg")
a6c0: 22 5d 20 6e 6f 74 20 66 6f 75 6e 64 20 69 6e 20 "] not found in
a6d0: 22 20 72 75 6e 63 6f 6e 66 69 67 66 29 0a 09 09 " runconfigf)...
a6e0: 20 20 20 20 28 69 66 20 64 62 20 28 73 71 6c 69 (if db (sqli
a6f0: 74 65 33 3a 66 69 6e 61 6c 69 7a 65 21 20 64 62 te3:finalize! db
a700: 29 29 0a 09 09 20 20 20 20 28 65 78 69 74 20 31 ))... (exit 1
a710: 29 29 29 29 0a 09 20 20 20 20 28 69 66 20 28 61 )))).. (if (a
a720: 72 67 73 3a 67 65 74 2d 61 72 67 20 22 2d 74 61 rgs:get-arg "-ta
a730: 72 67 65 74 22 29 0a 09 09 28 6b 65 79 73 3a 74 rget")...(keys:t
a740: 61 72 67 65 74 2d 73 65 74 2d 61 72 67 73 20 6b arget-set-args k
a750: 65 79 73 20 28 61 72 67 73 3a 67 65 74 2d 61 72 eys (args:get-ar
a760: 67 20 22 2d 74 61 72 67 65 74 22 20 61 72 67 73 g "-target" args
a770: 3a 61 72 67 2d 68 61 73 68 29 20 61 72 67 73 3a :arg-hash) args:
a780: 61 72 67 2d 68 61 73 68 29 29 29 0a 09 28 69 66 arg-hash)))..(if
a790: 20 28 6e 6f 74 20 28 63 61 72 20 2a 63 6f 6e 66 (not (car *conf
a7a0: 69 67 69 6e 66 6f 2a 29 29 0a 09 20 20 20 20 28 iginfo*)).. (
a7b0: 62 65 67 69 6e 0a 09 20 20 20 20 20 20 28 64 65 begin.. (de
a7c0: 62 75 67 3a 70 72 69 6e 74 20 30 20 22 45 52 52 bug:print 0 "ERR
a7d0: 4f 52 3a 20 41 74 74 65 6d 70 74 65 64 20 74 6f OR: Attempted to
a7e0: 20 22 20 61 63 74 69 6f 6e 2d 64 65 73 63 20 22 " action-desc "
a7f0: 20 62 75 74 20 72 75 6e 20 61 72 65 61 20 63 6f but run area co
a800: 6e 66 69 67 20 66 69 6c 65 20 6e 6f 74 20 66 6f nfig file not fo
a810: 75 6e 64 22 29 0a 09 20 20 20 20 20 20 28 65 78 und").. (ex
a820: 69 74 20 31 29 29 0a 09 20 20 20 20 3b 3b 20 45 it 1)).. ;; E
a830: 78 74 72 61 63 74 20 6f 75 74 20 73 74 75 66 66 xtract out stuff
a840: 20 6e 65 65 64 65 64 20 69 6e 20 6d 6f 73 74 20 needed in most
a850: 6f 72 20 6d 61 6e 79 20 63 61 6c 6c 73 0a 09 20 or many calls..
a860: 20 20 20 3b 3b 20 68 65 72 65 20 74 68 65 6e 20 ;; here then
a870: 63 61 6c 6c 20 70 72 6f 63 0a 09 20 20 20 20 28 call proc.. (
a880: 6c 65 74 2a 20 28 28 6b 65 79 6e 61 6d 65 73 20 let* ((keynames
a890: 20 20 28 6d 61 70 20 6b 65 79 3a 67 65 74 2d 66 (map key:get-f
a8a0: 69 65 6c 64 6e 61 6d 65 20 6b 65 79 73 29 29 0a ieldname keys)).
a8b0: 09 09 20 20 20 28 6b 65 79 76 61 6c 6c 73 74 20 .. (keyvallst
a8c0: 20 28 6b 65 79 73 2d 3e 76 61 6c 6c 69 73 74 20 (keys->vallist
a8d0: 6b 65 79 73 20 23 74 29 29 29 0a 09 20 20 20 20 keys #t)))..
a8e0: 20 20 28 70 72 6f 63 20 74 61 72 67 65 74 20 72 (proc target r
a8f0: 75 6e 6e 61 6d 65 20 6b 65 79 73 20 6b 65 79 6e unname keys keyn
a900: 61 6d 65 73 20 6b 65 79 76 61 6c 6c 73 74 29 29 ames keyvallst))
a910: 29 0a 09 28 69 66 20 74 68 31 20 28 74 68 72 65 )..(if th1 (thre
a920: 61 64 2d 6a 6f 69 6e 21 20 74 68 31 29 29 0a 09 ad-join! th1))..
a930: 28 69 66 20 64 62 20 28 73 71 6c 69 74 65 33 3a (if db (sqlite3:
a940: 66 69 6e 61 6c 69 7a 65 21 20 64 62 29 29 0a 09 finalize! db))..
a950: 28 73 65 74 21 20 2a 64 69 64 73 6f 6d 65 74 68 (set! *didsometh
a960: 69 6e 67 2a 20 23 74 29 29 29 29 29 29 0a 0a 3b ing* #t))))))..;
a970: 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;===============
a980: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
a990: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
a9a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
a9b0: 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 4c 6f 63 6b 2f =======.;; Lock/
a9c0: 75 6e 6c 6f 63 6b 20 72 75 6e 73 0a 3b 3b 3d 3d unlock runs.;;==
a9d0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
a9e0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
a9f0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
aa00: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
aa10: 3d 3d 3d 3d 0a 0a 28 64 65 66 69 6e 65 20 28 72 ====..(define (r
aa20: 75 6e 73 3a 68 61 6e 64 6c 65 2d 6c 6f 63 6b 69 uns:handle-locki
aa30: 6e 67 20 74 61 72 67 65 74 20 6b 65 79 73 20 72 ng target keys r
aa40: 75 6e 6e 61 6d 65 20 6c 6f 63 6b 20 75 6e 6c 6f unname lock unlo
aa50: 63 6b 20 75 73 65 72 29 0a 20 20 28 6c 65 74 2a ck user). (let*
aa60: 20 28 28 64 62 20 20 20 20 20 20 20 23 66 29 0a ((db #f).
aa70: 09 20 28 72 75 6e 64 61 74 20 20 20 28 6f 70 65 . (rundat (ope
aa80: 6e 2d 72 75 6e 2d 63 6c 6f 73 65 20 72 75 6e 73 n-run-close runs
aa90: 3a 67 65 74 2d 72 75 6e 73 2d 62 79 2d 70 61 74 :get-runs-by-pat
aaa0: 74 20 64 62 20 6b 65 79 73 20 72 75 6e 6e 61 6d t db keys runnam
aab0: 65 29 29 0a 09 20 28 68 65 61 64 65 72 20 20 20 e)).. (header
aac0: 28 76 65 63 74 6f 72 2d 72 65 66 20 72 75 6e 64 (vector-ref rund
aad0: 61 74 20 30 29 29 0a 09 20 28 72 75 6e 73 20 20 at 0)).. (runs
aae0: 20 20 20 28 76 65 63 74 6f 72 2d 72 65 66 20 72 (vector-ref r
aaf0: 75 6e 64 61 74 20 31 29 29 29 0a 20 20 20 20 28 undat 1))). (
ab00: 66 6f 72 2d 65 61 63 68 20 28 6c 61 6d 62 64 61 for-each (lambda
ab10: 20 28 72 75 6e 29 0a 09 09 28 6c 65 74 20 28 28 (run)...(let ((
ab20: 72 75 6e 2d 69 64 20 28 64 62 3a 67 65 74 2d 76 run-id (db:get-v
ab30: 61 6c 75 65 2d 62 79 2d 68 65 61 64 65 72 20 72 alue-by-header r
ab40: 75 6e 20 68 65 61 64 65 72 20 22 69 64 22 29 29 un header "id"))
ab50: 29 0a 09 09 20 20 28 69 66 20 28 6f 72 20 6c 6f )... (if (or lo
ab60: 63 6b 0a 09 09 09 20 20 28 61 6e 64 20 75 6e 6c ck.... (and unl
ab70: 6f 63 6b 0a 09 09 09 20 20 20 20 20 20 20 28 62 ock.... (b
ab80: 65 67 69 6e 0a 09 09 09 09 20 28 70 72 69 6e 74 egin..... (print
ab90: 20 22 44 6f 20 79 6f 75 20 72 65 61 6c 6c 79 20 "Do you really
aba0: 77 69 73 68 20 74 6f 20 75 6e 6c 6f 63 6b 20 72 wish to unlock r
abb0: 75 6e 20 22 20 72 75 6e 2d 69 64 20 22 3f 5c 6e un " run-id "?\n
abc0: 20 20 20 79 2f 6e 3a 20 22 29 0a 09 09 09 09 20 y/n: ").....
abd0: 28 65 71 75 61 6c 3f 20 22 79 22 20 28 72 65 61 (equal? "y" (rea
abe0: 64 2d 6c 69 6e 65 29 29 29 29 29 0a 09 09 20 20 d-line)))))...
abf0: 20 20 20 20 28 6f 70 65 6e 2d 72 75 6e 2d 63 6c (open-run-cl
ac00: 6f 73 65 20 64 62 3a 6c 6f 63 6b 2f 75 6e 6c 6f ose db:lock/unlo
ac10: 63 6b 2d 72 75 6e 20 64 62 20 72 75 6e 2d 69 64 ck-run db run-id
ac20: 20 6c 6f 63 6b 20 75 6e 6c 6f 63 6b 20 75 73 65 lock unlock use
ac30: 72 29 0a 09 09 20 20 20 20 20 20 28 64 65 62 75 r)... (debu
ac40: 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 30 20 22 g:print-info 0 "
ac50: 53 6b 69 70 70 69 6e 67 20 6c 6f 63 6b 2f 75 6e Skipping lock/un
ac60: 6c 6f 63 6b 20 6f 6e 20 22 20 72 75 6e 2d 69 64 lock on " run-id
ac70: 29 29 29 29 0a 09 20 20 20 20 20 20 72 75 6e 73 )))).. runs
ac80: 29 29 29 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ))).;;==========
ac90: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
aca0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
acb0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
acc0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 ============.;;
acd0: 52 6f 6c 6c 75 70 20 72 75 6e 73 0a 3b 3b 3d 3d Rollup runs.;;==
ace0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
acf0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
ad00: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
ad10: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
ad20: 3d 3d 3d 3d 0a 0a 3b 3b 20 55 70 64 61 74 65 20 ====..;; Update
ad30: 74 68 65 20 74 65 73 74 5f 6d 65 74 61 20 74 61 the test_meta ta
ad40: 62 6c 65 20 66 6f 72 20 74 68 69 73 20 74 65 73 ble for this tes
ad50: 74 0a 28 64 65 66 69 6e 65 20 28 72 75 6e 73 3a t.(define (runs:
ad60: 75 70 64 61 74 65 2d 74 65 73 74 5f 6d 65 74 61 update-test_meta
ad70: 20 64 62 20 74 65 73 74 2d 6e 61 6d 65 20 74 65 db test-name te
ad80: 73 74 2d 63 6f 6e 66 29 0a 20 20 28 6c 65 74 20 st-conf). (let
ad90: 28 28 63 75 72 72 72 65 63 6f 72 64 20 28 6f 70 ((currrecord (op
ada0: 65 6e 2d 72 75 6e 2d 63 6c 6f 73 65 20 64 62 3a en-run-close db:
adb0: 74 65 73 74 6d 65 74 61 2d 67 65 74 2d 72 65 63 testmeta-get-rec
adc0: 6f 72 64 20 64 62 20 74 65 73 74 2d 6e 61 6d 65 ord db test-name
add0: 29 29 29 0a 20 20 20 20 28 69 66 20 28 6e 6f 74 ))). (if (not
ade0: 20 63 75 72 72 72 65 63 6f 72 64 29 0a 09 28 62 currrecord)..(b
adf0: 65 67 69 6e 0a 09 20 20 28 73 65 74 21 20 63 75 egin.. (set! cu
ae00: 72 72 72 65 63 6f 72 64 20 28 6d 61 6b 65 2d 76 rrrecord (make-v
ae10: 65 63 74 6f 72 20 31 30 20 23 66 29 29 0a 09 20 ector 10 #f))..
ae20: 20 28 6f 70 65 6e 2d 72 75 6e 2d 63 6c 6f 73 65 (open-run-close
ae30: 20 64 62 3a 74 65 73 74 6d 65 74 61 2d 61 64 64 db:testmeta-add
ae40: 2d 72 65 63 6f 72 64 20 64 62 20 74 65 73 74 2d -record db test-
ae50: 6e 61 6d 65 29 29 29 0a 20 20 20 20 28 66 6f 72 name))). (for
ae60: 2d 65 61 63 68 20 0a 20 20 20 20 20 28 6c 61 6d -each . (lam
ae70: 62 64 61 20 28 6b 65 79 29 0a 20 20 20 20 20 20 bda (key).
ae80: 20 28 6c 65 74 2a 20 28 28 69 64 78 20 28 63 61 (let* ((idx (ca
ae90: 64 72 20 6b 65 79 29 29 0a 09 20 20 20 20 20 20 dr key))..
aea0: 28 66 6c 64 20 28 63 61 72 20 20 6b 65 79 29 29 (fld (car key))
aeb0: 0a 09 20 20 20 20 20 20 28 76 61 6c 20 28 63 6f .. (val (co
aec0: 6e 66 69 67 2d 6c 6f 6f 6b 75 70 20 74 65 73 74 nfig-lookup test
aed0: 2d 63 6f 6e 66 20 22 74 65 73 74 5f 6d 65 74 61 -conf "test_meta
aee0: 22 20 66 6c 64 29 29 29 0a 09 20 3b 3b 20 28 64 " fld))).. ;; (d
aef0: 65 62 75 67 3a 70 72 69 6e 74 20 35 20 22 69 64 ebug:print 5 "id
af00: 78 3a 20 22 20 69 64 78 20 22 20 66 6c 64 3a 20 x: " idx " fld:
af10: 22 20 66 6c 64 20 22 20 76 61 6c 3a 20 22 20 76 " fld " val: " v
af20: 61 6c 29 0a 09 20 28 69 66 20 28 61 6e 64 20 76 al).. (if (and v
af30: 61 6c 20 28 6e 6f 74 20 28 65 71 75 61 6c 3f 20 al (not (equal?
af40: 28 76 65 63 74 6f 72 2d 72 65 66 20 63 75 72 72 (vector-ref curr
af50: 72 65 63 6f 72 64 20 69 64 78 29 20 76 61 6c 29 record idx) val)
af60: 29 29 0a 09 20 20 20 20 20 28 62 65 67 69 6e 0a )).. (begin.
af70: 09 20 20 20 20 20 20 20 28 70 72 69 6e 74 20 22 . (print "
af80: 55 70 64 61 74 69 6e 67 20 22 20 74 65 73 74 2d Updating " test-
af90: 6e 61 6d 65 20 22 20 22 20 66 6c 64 20 22 20 74 name " " fld " t
afa0: 6f 20 22 20 76 61 6c 29 0a 09 20 20 20 20 20 20 o " val)..
afb0: 20 28 6f 70 65 6e 2d 72 75 6e 2d 63 6c 6f 73 65 (open-run-close
afc0: 20 64 62 3a 74 65 73 74 6d 65 74 61 2d 75 70 64 db:testmeta-upd
afd0: 61 74 65 2d 66 69 65 6c 64 20 64 62 20 74 65 73 ate-field db tes
afe0: 74 2d 6e 61 6d 65 20 66 6c 64 20 76 61 6c 29 29 t-name fld val))
aff0: 29 29 29 0a 20 20 20 20 20 27 28 28 22 61 75 74 ))). '(("aut
b000: 68 6f 72 22 20 32 29 28 22 6f 77 6e 65 72 22 20 hor" 2)("owner"
b010: 33 29 28 22 64 65 73 63 72 69 70 74 69 6f 6e 22 3)("description"
b020: 20 34 29 28 22 72 65 76 69 65 77 65 64 22 20 35 4)("reviewed" 5
b030: 29 28 22 74 61 67 73 22 20 39 29 29 29 29 29 0a )("tags" 9))))).
b040: 0a 3b 3b 20 55 70 64 61 74 65 20 74 65 73 74 5f .;; Update test_
b050: 6d 65 74 61 20 66 6f 72 20 61 6c 6c 20 74 65 73 meta for all tes
b060: 74 73 0a 28 64 65 66 69 6e 65 20 28 72 75 6e 73 ts.(define (runs
b070: 3a 75 70 64 61 74 65 2d 61 6c 6c 2d 74 65 73 74 :update-all-test
b080: 5f 6d 65 74 61 20 64 62 29 0a 20 20 28 6c 65 74 _meta db). (let
b090: 20 28 28 74 65 73 74 2d 6e 61 6d 65 73 20 28 67 ((test-names (g
b0a0: 65 74 2d 61 6c 6c 2d 6c 65 67 61 6c 2d 74 65 73 et-all-legal-tes
b0b0: 74 73 29 29 29 0a 20 20 20 20 28 66 6f 72 2d 65 ts))). (for-e
b0c0: 61 63 68 20 0a 20 20 20 20 20 28 6c 61 6d 62 64 ach . (lambd
b0d0: 61 20 28 74 65 73 74 2d 6e 61 6d 65 29 0a 20 20 a (test-name).
b0e0: 20 20 20 20 20 28 6c 65 74 2a 20 28 28 74 65 73 (let* ((tes
b0f0: 74 2d 70 61 74 68 20 20 20 20 28 63 6f 6e 63 20 t-path (conc
b100: 2a 74 6f 70 70 61 74 68 2a 20 22 2f 74 65 73 74 *toppath* "/test
b110: 73 2f 22 20 74 65 73 74 2d 6e 61 6d 65 29 29 0a s/" test-name)).
b120: 09 20 20 20 20 20 20 28 74 65 73 74 2d 63 6f 6e . (test-con
b130: 66 69 67 66 20 28 63 6f 6e 63 20 74 65 73 74 2d figf (conc test-
b140: 70 61 74 68 20 22 2f 74 65 73 74 63 6f 6e 66 69 path "/testconfi
b150: 67 22 29 29 0a 09 20 20 20 20 20 20 28 74 65 73 g")).. (tes
b160: 74 65 78 69 73 74 73 20 20 20 28 61 6e 64 20 28 texists (and (
b170: 66 69 6c 65 2d 65 78 69 73 74 73 3f 20 74 65 73 file-exists? tes
b180: 74 2d 63 6f 6e 66 69 67 66 29 28 66 69 6c 65 2d t-configf)(file-
b190: 72 65 61 64 2d 61 63 63 65 73 73 3f 20 74 65 73 read-access? tes
b1a0: 74 2d 63 6f 6e 66 69 67 66 29 29 29 0a 09 20 20 t-configf)))..
b1b0: 20 20 20 20 3b 3b 20 72 65 61 64 20 63 6f 6e 66 ;; read conf
b1c0: 69 67 73 20 77 69 74 68 20 74 72 69 63 6b 73 20 igs with tricks
b1d0: 74 75 72 6e 65 64 20 6f 66 66 20 28 69 2e 65 2e turned off (i.e.
b1e0: 20 6e 6f 20 73 79 73 74 65 6d 29 0a 09 20 20 20 no system)..
b1f0: 20 20 20 28 74 65 73 74 2d 63 6f 6e 66 20 20 20 (test-conf
b200: 20 28 69 66 20 74 65 73 74 65 78 69 73 74 73 20 (if testexists
b210: 28 72 65 61 64 2d 63 6f 6e 66 69 67 20 74 65 73 (read-config tes
b220: 74 2d 63 6f 6e 66 69 67 66 20 23 66 20 23 66 29 t-configf #f #f)
b230: 28 6d 61 6b 65 2d 68 61 73 68 2d 74 61 62 6c 65 (make-hash-table
b240: 29 29 29 29 0a 09 20 3b 3b 20 75 73 65 20 74 68 )))).. ;; use th
b250: 65 20 6f 70 65 6e 2d 72 75 6e 2d 63 6c 6f 73 65 e open-run-close
b260: 20 69 6e 73 74 65 61 64 20 6f 66 20 70 61 73 73 instead of pass
b270: 69 6e 67 20 69 6e 20 64 62 0a 09 20 28 72 75 6e ing in db.. (run
b280: 73 3a 75 70 64 61 74 65 2d 74 65 73 74 5f 6d 65 s:update-test_me
b290: 74 61 20 23 66 20 74 65 73 74 2d 6e 61 6d 65 20 ta #f test-name
b2a0: 74 65 73 74 2d 63 6f 6e 66 29 29 29 0a 20 20 20 test-conf))).
b2b0: 20 20 74 65 73 74 2d 6e 61 6d 65 73 29 29 29 0a test-names))).
b2c0: 0a 3b 3b 20 54 68 69 73 20 63 6f 75 6c 64 20 70 .;; This could p
b2d0: 72 6f 62 61 62 6c 79 20 62 65 20 72 65 66 61 63 robably be refac
b2e0: 74 6f 72 65 64 20 69 6e 74 6f 20 6f 6e 65 20 63 tored into one c
b2f0: 6f 6d 70 6c 65 78 20 71 75 65 72 79 20 2e 2e 2e omplex query ...
b300: 0a 28 64 65 66 69 6e 65 20 28 72 75 6e 73 3a 72 .(define (runs:r
b310: 6f 6c 6c 75 70 2d 72 75 6e 20 6b 65 79 73 20 6b ollup-run keys k
b320: 65 79 76 61 6c 6c 73 74 20 72 75 6e 6e 61 6d 65 eyvallst runname
b330: 20 75 73 65 72 29 20 3b 3b 20 77 61 73 20 74 61 user) ;; was ta
b340: 72 67 65 74 2c 20 6e 6f 77 20 6b 65 79 76 61 6c rget, now keyval
b350: 6c 73 74 0a 20 20 28 64 65 62 75 67 3a 70 72 69 lst. (debug:pri
b360: 6e 74 20 34 20 22 72 75 6e 73 3a 72 6f 6c 6c 75 nt 4 "runs:rollu
b370: 70 2d 72 75 6e 2c 20 6b 65 79 73 3a 20 22 20 6b p-run, keys: " k
b380: 65 79 73 20 22 20 6b 65 79 76 61 6c 6c 73 74 3a eys " keyvallst:
b390: 20 22 20 6b 65 79 76 61 6c 6c 73 74 20 22 20 3a " keyvallst " :
b3a0: 72 75 6e 6e 61 6d 65 20 22 20 72 75 6e 6e 61 6d runname " runnam
b3b0: 65 20 22 20 75 73 65 72 3a 20 22 20 75 73 65 72 e " user: " user
b3c0: 29 0a 20 20 28 6c 65 74 2a 20 28 28 64 62 20 20 ). (let* ((db
b3d0: 20 20 20 20 20 20 20 20 20 20 20 20 23 66 29 20 #f)
b3e0: 3b 3b 20 28 6b 65 79 76 61 6c 6c 6c 73 74 20 20 ;; (keyvalllst
b3f0: 20 20 20 20 28 6b 65 79 73 3a 74 61 72 67 65 74 (keys:target
b400: 2d 3e 6b 65 79 76 61 6c 20 6b 65 79 73 20 74 61 ->keyval keys ta
b410: 72 67 65 74 29 29 0a 09 20 28 6e 65 77 2d 72 75 rget)).. (new-ru
b420: 6e 2d 69 64 20 20 20 20 20 20 28 6f 70 65 6e 2d n-id (open-
b430: 72 75 6e 2d 63 6c 6f 73 65 20 72 75 6e 73 3a 72 run-close runs:r
b440: 65 67 69 73 74 65 72 2d 72 75 6e 20 64 62 20 6b egister-run db k
b450: 65 79 73 20 6b 65 79 76 61 6c 6c 73 74 20 72 75 eys keyvallst ru
b460: 6e 6e 61 6d 65 20 22 6e 65 77 22 20 22 6e 2f 61 nname "new" "n/a
b470: 22 20 75 73 65 72 29 29 0a 09 20 28 70 72 65 76 " user)).. (prev
b480: 2d 74 65 73 74 73 20 20 20 20 20 20 28 6f 70 65 -tests (ope
b490: 6e 2d 72 75 6e 2d 63 6c 6f 73 65 20 74 65 73 74 n-run-close test
b4a0: 3a 67 65 74 2d 6d 61 74 63 68 69 6e 67 2d 70 72 :get-matching-pr
b4b0: 65 76 69 6f 75 73 2d 74 65 73 74 2d 72 75 6e 2d evious-test-run-
b4c0: 72 65 63 6f 72 64 73 20 64 62 20 6e 65 77 2d 72 records db new-r
b4d0: 75 6e 2d 69 64 20 22 25 22 20 22 25 22 29 29 0a un-id "%" "%")).
b4e0: 09 20 28 63 75 72 72 2d 74 65 73 74 73 20 20 20 . (curr-tests
b4f0: 20 20 20 28 6f 70 65 6e 2d 72 75 6e 2d 63 6c 6f (open-run-clo
b500: 73 65 20 64 62 3a 67 65 74 2d 74 65 73 74 73 2d se db:get-tests-
b510: 66 6f 72 2d 72 75 6e 20 64 62 20 6e 65 77 2d 72 for-run db new-r
b520: 75 6e 2d 69 64 20 22 25 2f 25 22 20 27 28 29 20 un-id "%/%" '()
b530: 27 28 29 29 29 0a 09 20 28 63 75 72 72 2d 74 65 '())).. (curr-te
b540: 73 74 73 2d 68 61 73 68 20 28 6d 61 6b 65 2d 68 sts-hash (make-h
b550: 61 73 68 2d 74 61 62 6c 65 29 29 29 0a 20 20 20 ash-table))).
b560: 20 28 6f 70 65 6e 2d 72 75 6e 2d 63 6c 6f 73 65 (open-run-close
b570: 20 64 62 3a 75 70 64 61 74 65 2d 72 75 6e 2d 65 db:update-run-e
b580: 76 65 6e 74 5f 74 69 6d 65 20 64 62 20 6e 65 77 vent_time db new
b590: 2d 72 75 6e 2d 69 64 29 0a 20 20 20 20 3b 3b 20 -run-id). ;;
b5a0: 69 6e 64 65 78 20 74 68 65 20 61 6c 72 65 61 64 index the alread
b5b0: 79 20 73 61 76 65 64 20 74 65 73 74 73 20 62 79 y saved tests by
b5c0: 20 74 65 73 74 6e 61 6d 65 20 61 6e 64 20 69 74 testname and it
b5d0: 65 6d 64 61 74 20 69 6e 20 63 75 72 72 2d 74 65 emdat in curr-te
b5e0: 73 74 73 2d 68 61 73 68 0a 20 20 20 20 28 66 6f sts-hash. (fo
b5f0: 72 2d 65 61 63 68 0a 20 20 20 20 20 28 6c 61 6d r-each. (lam
b600: 62 64 61 20 28 74 65 73 74 64 61 74 29 0a 20 20 bda (testdat).
b610: 20 20 20 20 20 28 6c 65 74 2a 20 28 28 74 65 73 (let* ((tes
b620: 74 6e 61 6d 65 20 20 28 64 62 3a 74 65 73 74 2d tname (db:test-
b630: 67 65 74 2d 74 65 73 74 6e 61 6d 65 20 74 65 73 get-testname tes
b640: 74 64 61 74 29 29 0a 09 20 20 20 20 20 20 28 69 tdat)).. (i
b650: 74 65 6d 2d 70 61 74 68 20 28 64 62 3a 74 65 73 tem-path (db:tes
b660: 74 2d 67 65 74 2d 69 74 65 6d 2d 70 61 74 68 20 t-get-item-path
b670: 74 65 73 74 64 61 74 29 29 0a 09 20 20 20 20 20 testdat))..
b680: 20 28 66 75 6c 6c 2d 6e 61 6d 65 20 28 63 6f 6e (full-name (con
b690: 63 20 74 65 73 74 6e 61 6d 65 20 22 2f 22 20 69 c testname "/" i
b6a0: 74 65 6d 2d 70 61 74 68 29 29 29 0a 09 20 28 68 tem-path))).. (h
b6b0: 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 63 ash-table-set! c
b6c0: 75 72 72 2d 74 65 73 74 73 2d 68 61 73 68 20 66 urr-tests-hash f
b6d0: 75 6c 6c 2d 6e 61 6d 65 20 74 65 73 74 64 61 74 ull-name testdat
b6e0: 29 29 29 0a 20 20 20 20 20 63 75 72 72 2d 74 65 ))). curr-te
b6f0: 73 74 73 29 0a 20 20 20 20 3b 3b 20 4e 4f 50 45 sts). ;; NOPE
b700: 3a 20 4e 6f 6e 2d 6f 70 74 69 6d 61 6c 20 61 70 : Non-optimal ap
b710: 70 72 6f 61 63 68 2e 20 54 72 79 20 74 68 69 73 proach. Try this
b720: 20 69 6e 73 74 65 61 64 2e 0a 20 20 20 20 3b 3b instead.. ;;
b730: 20 20 20 31 2e 20 74 65 73 74 73 20 61 72 65 20 1. tests are
b740: 72 65 63 65 69 76 65 64 20 69 6e 20 61 20 6c 69 received in a li
b750: 73 74 2c 20 6d 6f 73 74 20 72 65 63 65 6e 74 20 st, most recent
b760: 66 69 72 73 74 0a 20 20 20 20 3b 3b 20 20 20 32 first. ;; 2
b770: 2e 20 72 65 70 6c 61 63 65 20 74 68 65 20 72 6f . replace the ro
b780: 6c 6c 75 70 20 74 65 73 74 20 77 69 74 68 20 74 llup test with t
b790: 68 65 20 6e 65 77 20 2a 61 6c 77 61 79 73 2a 0a he new *always*.
b7a0: 20 20 20 20 28 66 6f 72 2d 65 61 63 68 20 0a 20 (for-each .
b7b0: 20 20 20 20 28 6c 61 6d 62 64 61 20 28 74 65 73 (lambda (tes
b7c0: 74 64 61 74 29 0a 20 20 20 20 20 20 20 28 6c 65 tdat). (le
b7d0: 74 2a 20 28 28 74 65 73 74 6e 61 6d 65 20 20 28 t* ((testname (
b7e0: 64 62 3a 74 65 73 74 2d 67 65 74 2d 74 65 73 74 db:test-get-test
b7f0: 6e 61 6d 65 20 74 65 73 74 64 61 74 29 29 0a 09 name testdat))..
b800: 20 20 20 20 20 20 28 69 74 65 6d 2d 70 61 74 68 (item-path
b810: 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 69 74 (db:test-get-it
b820: 65 6d 2d 70 61 74 68 20 74 65 73 74 64 61 74 29 em-path testdat)
b830: 29 0a 09 20 20 20 20 20 20 28 66 75 6c 6c 2d 6e ).. (full-n
b840: 61 6d 65 20 28 63 6f 6e 63 20 74 65 73 74 6e 61 ame (conc testna
b850: 6d 65 20 22 2f 22 20 69 74 65 6d 2d 70 61 74 68 me "/" item-path
b860: 29 29 0a 09 20 20 20 20 20 20 28 70 72 65 76 2d )).. (prev-
b870: 74 65 73 74 2d 64 61 74 20 28 68 61 73 68 2d 74 test-dat (hash-t
b880: 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 able-ref/default
b890: 20 63 75 72 72 2d 74 65 73 74 73 2d 68 61 73 68 curr-tests-hash
b8a0: 20 66 75 6c 6c 2d 6e 61 6d 65 20 23 66 29 29 0a full-name #f)).
b8b0: 09 20 20 20 20 20 20 28 74 65 73 74 2d 73 74 65 . (test-ste
b8c0: 70 73 20 20 20 20 20 20 28 6f 70 65 6e 2d 72 75 ps (open-ru
b8d0: 6e 2d 63 6c 6f 73 65 20 64 62 3a 67 65 74 2d 73 n-close db:get-s
b8e0: 74 65 70 73 2d 66 6f 72 2d 74 65 73 74 20 64 62 teps-for-test db
b8f0: 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 69 64 (db:test-get-id
b900: 20 74 65 73 74 64 61 74 29 29 29 0a 09 20 20 20 testdat)))..
b910: 20 20 20 28 6e 65 77 2d 74 65 73 74 2d 72 65 63 (new-test-rec
b920: 6f 72 64 20 23 66 29 29 0a 09 20 3b 3b 20 72 65 ord #f)).. ;; re
b930: 70 6c 61 63 65 20 74 68 65 73 65 20 77 69 74 68 place these with
b940: 20 69 6e 73 65 72 74 20 2e 2e 2e 20 73 65 6c 65 insert ... sele
b950: 63 74 0a 09 20 28 61 70 70 6c 79 20 73 71 6c 69 ct.. (apply sqli
b960: 74 65 33 3a 65 78 65 63 75 74 65 20 0a 09 09 64 te3:execute ...d
b970: 62 20 0a 09 09 28 63 6f 6e 63 20 22 49 4e 53 45 b ...(conc "INSE
b980: 52 54 20 4f 52 20 52 45 50 4c 41 43 45 20 49 4e RT OR REPLACE IN
b990: 54 4f 20 74 65 73 74 73 20 28 72 75 6e 5f 69 64 TO tests (run_id
b9a0: 2c 74 65 73 74 6e 61 6d 65 2c 73 74 61 74 65 2c ,testname,state,
b9b0: 73 74 61 74 75 73 2c 65 76 65 6e 74 5f 74 69 6d status,event_tim
b9c0: 65 2c 68 6f 73 74 2c 63 70 75 6c 6f 61 64 2c 64 e,host,cpuload,d
b9d0: 69 73 6b 66 72 65 65 2c 75 6e 61 6d 65 2c 72 75 iskfree,uname,ru
b9e0: 6e 64 69 72 2c 69 74 65 6d 5f 70 61 74 68 2c 72 ndir,item_path,r
b9f0: 75 6e 5f 64 75 72 61 74 69 6f 6e 2c 66 69 6e 61 un_duration,fina
ba00: 6c 5f 6c 6f 67 66 2c 63 6f 6d 6d 65 6e 74 29 20 l_logf,comment)
ba10: 22 0a 09 09 20 20 20 20 20 20 22 56 41 4c 55 45 "... "VALUE
ba20: 53 20 28 3f 2c 3f 2c 3f 2c 3f 2c 3f 2c 3f 2c 3f S (?,?,?,?,?,?,?
ba30: 2c 3f 2c 3f 2c 3f 2c 3f 2c 3f 2c 3f 2c 3f 29 3b ,?,?,?,?,?,?,?);
ba40: 22 29 0a 09 09 6e 65 77 2d 72 75 6e 2d 69 64 20 ")...new-run-id
ba50: 28 63 64 64 72 20 28 76 65 63 74 6f 72 2d 3e 6c (cddr (vector->l
ba60: 69 73 74 20 74 65 73 74 64 61 74 29 29 29 0a 09 ist testdat)))..
ba70: 20 28 73 65 74 21 20 6e 65 77 2d 74 65 73 74 64 (set! new-testd
ba80: 61 74 20 28 63 61 72 20 28 6f 70 65 6e 2d 72 75 at (car (open-ru
ba90: 6e 2d 63 6c 6f 73 65 20 64 62 3a 67 65 74 2d 74 n-close db:get-t
baa0: 65 73 74 73 2d 66 6f 72 2d 72 75 6e 20 64 62 20 ests-for-run db
bab0: 6e 65 77 2d 72 75 6e 2d 69 64 20 28 63 6f 6e 63 new-run-id (conc
bac0: 20 74 65 73 74 6e 61 6d 65 20 22 2f 22 20 69 74 testname "/" it
bad0: 65 6d 2d 70 61 74 68 29 20 27 28 29 20 27 28 29 em-path) '() '()
bae0: 29 29 29 0a 09 20 28 68 61 73 68 2d 74 61 62 6c ))).. (hash-tabl
baf0: 65 2d 73 65 74 21 20 63 75 72 72 2d 74 65 73 74 e-set! curr-test
bb00: 73 2d 68 61 73 68 20 66 75 6c 6c 2d 6e 61 6d 65 s-hash full-name
bb10: 20 6e 65 77 2d 74 65 73 74 64 61 74 29 20 3b 3b new-testdat) ;;
bb20: 20 74 68 69 73 20 63 6f 75 6c 64 20 62 65 20 63 this could be c
bb30: 6f 6e 66 75 73 69 6e 67 2c 20 77 68 69 63 68 20 onfusing, which
bb40: 72 65 63 6f 72 64 20 73 68 6f 75 6c 64 20 67 6f record should go
bb50: 20 69 6e 74 6f 20 74 68 65 20 6c 6f 6f 6b 75 70 into the lookup
bb60: 20 74 61 62 6c 65 3f 0a 09 20 3b 3b 20 4e 6f 77 table?.. ;; Now
bb70: 20 64 75 70 6c 69 63 61 74 65 20 74 68 65 20 74 duplicate the t
bb80: 65 73 74 20 73 74 65 70 73 0a 09 20 28 64 65 62 est steps.. (deb
bb90: 75 67 3a 70 72 69 6e 74 20 34 20 22 43 6f 70 79 ug:print 4 "Copy
bba0: 69 6e 67 20 72 65 63 6f 72 64 73 20 69 6e 20 74 ing records in t
bbb0: 65 73 74 5f 73 74 65 70 73 20 66 72 6f 6d 20 74 est_steps from t
bbc0: 65 73 74 5f 69 64 3d 22 20 28 64 62 3a 74 65 73 est_id=" (db:tes
bbd0: 74 2d 67 65 74 2d 69 64 20 74 65 73 74 64 61 74 t-get-id testdat
bbe0: 29 20 22 20 74 6f 20 22 20 28 64 62 3a 74 65 73 ) " to " (db:tes
bbf0: 74 2d 67 65 74 2d 69 64 20 6e 65 77 2d 74 65 73 t-get-id new-tes
bc00: 74 64 61 74 29 29 0a 09 20 28 6f 70 65 6e 2d 72 tdat)).. (open-r
bc10: 75 6e 2d 63 6c 6f 73 65 20 0a 09 20 20 28 6c 61 un-close .. (la
bc20: 6d 62 64 61 20 28 29 0a 09 20 20 20 20 28 73 71 mbda ().. (sq
bc30: 6c 69 74 65 33 3a 65 78 65 63 75 74 65 20 0a 09 lite3:execute ..
bc40: 20 20 20 20 20 64 62 20 0a 09 20 20 20 20 20 28 db .. (
bc50: 63 6f 6e 63 20 22 49 4e 53 45 52 54 20 4f 52 20 conc "INSERT OR
bc60: 52 45 50 4c 41 43 45 20 49 4e 54 4f 20 74 65 73 REPLACE INTO tes
bc70: 74 5f 73 74 65 70 73 20 28 74 65 73 74 5f 69 64 t_steps (test_id
bc80: 2c 73 74 65 70 6e 61 6d 65 2c 73 74 61 74 65 2c ,stepname,state,
bc90: 73 74 61 74 75 73 2c 65 76 65 6e 74 5f 74 69 6d status,event_tim
bca0: 65 2c 63 6f 6d 6d 65 6e 74 29 20 22 0a 09 09 20 e,comment) "...
bcb0: 20 20 22 53 45 4c 45 43 54 20 22 20 28 64 62 3a "SELECT " (db:
bcc0: 74 65 73 74 2d 67 65 74 2d 69 64 20 6e 65 77 2d test-get-id new-
bcd0: 74 65 73 74 64 61 74 29 20 22 2c 73 74 65 70 6e testdat) ",stepn
bce0: 61 6d 65 2c 73 74 61 74 65 2c 73 74 61 74 75 73 ame,state,status
bcf0: 2c 65 76 65 6e 74 5f 74 69 6d 65 2c 63 6f 6d 6d ,event_time,comm
bd00: 65 6e 74 20 46 52 4f 4d 20 74 65 73 74 5f 73 74 ent FROM test_st
bd10: 65 70 73 20 57 48 45 52 45 20 74 65 73 74 5f 69 eps WHERE test_i
bd20: 64 3d 3f 3b 22 29 0a 09 20 20 20 20 20 28 64 62 d=?;").. (db
bd30: 3a 74 65 73 74 2d 67 65 74 2d 69 64 20 74 65 73 :test-get-id tes
bd40: 74 64 61 74 29 29 0a 09 20 20 20 20 3b 3b 20 4e tdat)).. ;; N
bd50: 6f 77 20 64 75 70 6c 69 63 61 74 65 20 74 68 65 ow duplicate the
bd60: 20 74 65 73 74 20 64 61 74 61 0a 09 20 20 20 20 test data..
bd70: 28 64 65 62 75 67 3a 70 72 69 6e 74 20 34 20 22 (debug:print 4 "
bd80: 43 6f 70 79 69 6e 67 20 72 65 63 6f 72 64 73 20 Copying records
bd90: 69 6e 20 74 65 73 74 5f 64 61 74 61 20 66 72 6f in test_data fro
bda0: 6d 20 74 65 73 74 5f 69 64 3d 22 20 28 64 62 3a m test_id=" (db:
bdb0: 74 65 73 74 2d 67 65 74 2d 69 64 20 74 65 73 74 test-get-id test
bdc0: 64 61 74 29 20 22 20 74 6f 20 22 20 28 64 62 3a dat) " to " (db:
bdd0: 74 65 73 74 2d 67 65 74 2d 69 64 20 6e 65 77 2d test-get-id new-
bde0: 74 65 73 74 64 61 74 29 29 0a 09 20 20 20 20 28 testdat)).. (
bdf0: 73 71 6c 69 74 65 33 3a 65 78 65 63 75 74 65 20 sqlite3:execute
be00: 0a 09 20 20 20 20 20 64 62 20 0a 09 20 20 20 20 .. db ..
be10: 20 28 63 6f 6e 63 20 22 49 4e 53 45 52 54 20 4f (conc "INSERT O
be20: 52 20 52 45 50 4c 41 43 45 20 49 4e 54 4f 20 74 R REPLACE INTO t
be30: 65 73 74 5f 64 61 74 61 20 28 74 65 73 74 5f 69 est_data (test_i
be40: 64 2c 63 61 74 65 67 6f 72 79 2c 76 61 72 69 61 d,category,varia
be50: 62 6c 65 2c 76 61 6c 75 65 2c 65 78 70 65 63 74 ble,value,expect
be60: 65 64 2c 74 6f 6c 2c 75 6e 69 74 73 2c 63 6f 6d ed,tol,units,com
be70: 6d 65 6e 74 29 20 22 0a 09 09 20 20 20 22 53 45 ment) "... "SE
be80: 4c 45 43 54 20 22 20 28 64 62 3a 74 65 73 74 2d LECT " (db:test-
be90: 67 65 74 2d 69 64 20 6e 65 77 2d 74 65 73 74 64 get-id new-testd
bea0: 61 74 29 20 22 2c 63 61 74 65 67 6f 72 79 2c 76 at) ",category,v
beb0: 61 72 69 61 62 6c 65 2c 76 61 6c 75 65 2c 65 78 ariable,value,ex
bec0: 70 65 63 74 65 64 2c 74 6f 6c 2c 75 6e 69 74 73 pected,tol,units
bed0: 2c 63 6f 6d 6d 65 6e 74 20 46 52 4f 4d 20 74 65 ,comment FROM te
bee0: 73 74 5f 64 61 74 61 20 57 48 45 52 45 20 74 65 st_data WHERE te
bef0: 73 74 5f 69 64 3d 3f 3b 22 29 0a 09 20 20 20 20 st_id=?;")..
bf00: 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 69 64 (db:test-get-id
bf10: 20 74 65 73 74 64 61 74 29 29 29 29 0a 09 20 29 testdat)))).. )
bf20: 29 0a 20 20 20 20 20 70 72 65 76 2d 74 65 73 74 ). prev-test
bf30: 73 29 29 29 0a 09 20 0a 20 20 20 20 20 0a s))).. . .