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: 6f 70 65 6e 2d 72 75 6e 2d 63 6c 6f 73 65 20 74 open-run-close t
67e0: 65 73 74 73 3a 66 69 6c 74 65 72 2d 6e 6f 6e 2d ests:filter-non-
67f0: 72 75 6e 6e 61 62 6c 65 20 23 66 20 72 75 6e 2d runnable #f run-
6800: 69 64 20 74 61 6c 20 74 65 73 74 2d 72 65 63 6f id tal test-reco
6810: 72 64 73 29 29 20 3b 3b 20 69 2e 65 2e 20 6e 6f rds)) ;; i.e. no
6820: 74 20 46 41 49 4c 2c 20 57 41 49 56 45 44 2c 20 t FAIL, WAIVED,
6830: 49 4e 43 4f 4d 50 4c 45 54 45 2c 20 50 41 53 53 INCOMPLETE, PASS
6840: 2c 20 4b 49 4c 4c 45 44 2c 0a 09 09 20 20 20 20 , KILLED,...
6850: 20 28 6a 75 6e 6b 65 64 20 28 6c 73 65 74 2d 64 (junked (lset-d
6860: 69 66 66 65 72 65 6e 63 65 20 65 71 75 61 6c 3f ifference equal?
6870: 20 74 61 6c 20 6e 65 77 6c 73 74 29 29 29 0a 09 tal newlst)))..
6880: 09 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e .(debug:print-in
6890: 66 6f 20 34 20 22 66 75 6c 6c 20 64 72 6f 70 20 fo 4 "full drop
68a0: 74 68 72 6f 75 67 68 2c 20 69 66 20 72 65 72 75 through, if reru
68b0: 6e 73 20 69 73 20 6c 65 73 73 20 74 68 61 6e 20 ns is less than
68c0: 31 30 30 20 77 65 20 77 69 6c 6c 20 66 6f 72 63 100 we will forc
68d0: 65 20 72 65 74 72 79 20 74 68 65 6d 2c 20 72 65 e retry them, re
68e0: 72 75 6e 73 3d 22 20 72 65 72 75 6e 73 20 22 2c runs=" reruns ",
68f0: 20 74 61 6c 3d 22 20 74 61 6c 29 0a 09 09 28 69 tal=" tal)...(i
6900: 66 20 28 3c 20 6e 75 6d 2d 72 65 74 72 69 65 73 f (< num-retries
6910: 20 6d 61 78 2d 72 65 74 72 69 65 73 29 0a 09 09 max-retries)...
6920: 20 20 20 20 28 73 65 74 21 20 6e 65 77 6c 73 74 (set! newlst
6930: 20 28 61 70 70 65 6e 64 20 72 65 72 75 6e 73 20 (append reruns
6940: 6e 65 77 6c 73 74 29 29 29 0a 09 09 28 73 65 74 newlst)))...(set
6950: 21 20 6e 75 6d 2d 72 65 74 72 69 65 73 20 28 2b ! num-retries (+
6960: 20 6e 75 6d 2d 72 65 74 72 69 65 73 20 31 29 29 num-retries 1))
6970: 0a 09 09 28 74 68 72 65 61 64 2d 73 6c 65 65 70 ...(thread-sleep
6980: 21 20 28 2b 20 31 20 2a 67 6c 6f 62 61 6c 2d 64 ! (+ 1 *global-d
6990: 65 6c 74 61 2a 29 29 0a 09 09 28 69 66 20 28 6e elta*))...(if (n
69a0: 6f 74 20 28 6e 75 6c 6c 3f 20 6e 65 77 6c 73 74 ot (null? newlst
69b0: 29 29 0a 09 09 20 20 20 20 3b 3b 20 73 69 6e 63 ))... ;; sinc
69c0: 65 20 72 65 72 75 6e 73 20 68 61 76 65 20 62 65 e reruns have be
69d0: 65 6e 20 74 61 63 6b 65 64 20 6f 6e 20 74 6f 20 en tacked on to
69e0: 6e 65 77 6c 73 74 20 63 72 65 61 74 65 20 6e 65 newlst create ne
69f0: 77 20 72 65 72 75 6e 73 20 66 72 6f 6d 20 6a 75 w reruns from ju
6a00: 6e 6b 65 64 0a 09 09 20 20 20 20 28 6c 6f 6f 70 nked... (loop
6a10: 20 28 63 61 72 20 6e 65 77 6c 73 74 29 28 63 64 (car newlst)(cd
6a20: 72 20 6e 65 77 6c 73 74 29 28 64 65 6c 65 74 65 r newlst)(delete
6a30: 2d 64 75 70 6c 69 63 61 74 65 73 20 6a 75 6e 6b -duplicates junk
6a40: 65 64 29 29 29 29 29 0a 09 20 20 20 20 20 28 28 ed))))).. ((
6a50: 6e 6f 74 20 28 6e 75 6c 6c 3f 20 74 61 6c 29 29 not (null? tal))
6a60: 0a 09 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 .. (debug:p
6a70: 72 69 6e 74 2d 69 6e 66 6f 20 34 20 22 49 27 6d rint-info 4 "I'm
6a80: 20 70 72 65 74 74 79 20 73 75 72 65 20 49 20 73 pretty sure I s
6a90: 68 6f 75 6c 64 6e 27 74 20 67 65 74 20 68 65 72 houldn't get her
6aa0: 65 2e 22 29 29 0a 09 20 20 20 20 20 28 65 6c 73 e.")).. (els
6ab0: 65 0a 09 20 20 20 20 20 20 28 64 65 62 75 67 3a e.. (debug:
6ac0: 70 72 69 6e 74 2d 69 6e 66 6f 20 34 20 22 45 78 print-info 4 "Ex
6ad0: 69 74 69 6e 67 20 6c 6f 6f 70 20 77 69 74 68 2e iting loop with.
6ae0: 2e 2e 5c 6e 20 20 68 65 64 3d 22 20 68 65 64 20 ..\n hed=" hed
6af0: 22 5c 6e 20 20 74 61 6c 3d 22 20 74 61 6c 20 22 "\n tal=" tal "
6b00: 5c 6e 20 20 72 65 72 75 6e 73 3d 22 20 72 65 72 \n reruns=" rer
6b10: 75 6e 73 29 29 0a 09 20 20 20 20 20 29 29 29 29 uns)).. ))))
6b20: 20 3b 3b 20 4c 45 54 2a 20 28 28 74 65 73 74 2d ;; LET* ((test-
6b30: 72 65 63 6f 72 64 0a 0a 20 20 20 20 3b 3b 20 77 record.. ;; w
6b40: 65 20 67 65 74 20 68 65 72 65 20 6f 6e 20 22 64 e get here on "d
6b50: 72 6f 70 20 74 68 72 6f 75 67 68 22 20 2d 20 6c rop through" - l
6b60: 6f 6f 70 20 66 6f 72 20 6e 65 78 74 20 74 65 73 oop for next tes
6b70: 74 20 69 6e 20 71 75 65 75 65 0a 20 20 20 20 3b t in queue. ;
6b80: 3b 20 46 49 58 4d 45 21 21 21 21 20 54 48 49 53 ; FIXME!!!! THIS
6b90: 20 53 48 4f 55 4c 44 20 4e 4f 54 20 52 45 51 55 SHOULD NOT REQU
6ba0: 49 52 45 20 41 4e 20 45 58 49 54 21 21 21 21 21 IRE AN EXIT!!!!!
6bb0: 21 21 0a 20 20 20 20 0a 20 20 20 20 28 64 65 62 !!. . (deb
6bc0: 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 31 20 ug:print-info 1
6bd0: 22 41 6c 6c 20 74 65 73 74 73 20 6c 61 75 6e 63 "All tests launc
6be0: 68 65 64 22 29 0a 20 20 20 20 28 74 68 72 65 61 hed"). (threa
6bf0: 64 2d 73 6c 65 65 70 21 20 30 2e 35 29 0a 20 20 d-sleep! 0.5).
6c00: 20 20 3b 3b 20 46 49 58 4d 45 21 20 54 68 69 73 ;; FIXME! This
6c10: 20 68 61 72 73 68 20 65 78 69 74 20 73 68 6f 75 harsh exit shou
6c20: 6c 64 20 6e 6f 74 20 62 65 20 6e 65 63 65 73 73 ld not be necess
6c30: 61 72 79 2e 2e 2e 2e 0a 20 20 20 20 3b 3b 20 28 ary..... ;; (
6c40: 69 66 20 28 6e 6f 74 20 2a 72 75 6e 72 65 6d 6f if (not *runremo
6c50: 74 65 2a 29 28 65 78 69 74 29 29 20 3b 3b 20 0a te*)(exit)) ;; .
6c60: 20 20 20 20 23 66 29 29 20 3b 3b 20 72 65 74 75 #f)) ;; retu
6c70: 72 6e 20 61 20 23 66 20 61 73 20 61 20 68 69 6e rn a #f as a hin
6c80: 74 20 74 68 61 74 20 77 65 20 61 72 65 20 64 6f t that we are do
6c90: 6e 65 0a 20 20 3b 3b 20 48 65 72 65 20 77 65 20 ne. ;; Here we
6ca0: 6e 65 65 64 20 74 6f 20 63 68 65 63 6b 20 74 68 need to check th
6cb0: 61 74 20 61 6c 6c 20 74 68 65 20 74 65 73 74 73 at all the tests
6cc0: 20 72 65 6d 61 69 6e 69 6e 67 20 74 6f 20 62 65 remaining to be
6cd0: 20 72 75 6e 20 61 72 65 20 65 6c 69 67 69 62 6c run are eligibl
6ce0: 65 20 74 6f 20 72 75 6e 0a 20 20 3b 3b 20 61 6e e to run. ;; an
6cf0: 64 20 61 72 65 20 6e 6f 74 20 62 6c 6f 63 6b 65 d are not blocke
6d00: 64 20 62 79 20 66 61 69 6c 65 64 0a 20 20 0a 0a d by failed. ..
6d10: 3b 3b 20 70 61 72 65 6e 74 2d 74 65 73 74 20 69 ;; parent-test i
6d20: 73 20 74 68 65 72 65 20 61 73 20 61 20 70 6c 61 s there as a pla
6d30: 63 65 68 6f 6c 64 65 72 20 66 6f 72 20 77 68 65 ceholder for whe
6d40: 6e 20 70 61 72 65 6e 74 2d 74 65 73 74 73 20 63 n parent-tests c
6d50: 61 6e 20 62 65 20 72 75 6e 20 61 73 20 61 20 73 an be run as a s
6d60: 65 74 75 70 20 73 74 65 70 0a 28 64 65 66 69 6e etup step.(defin
6d70: 65 20 28 72 75 6e 3a 74 65 73 74 20 72 75 6e 2d e (run:test run-
6d80: 69 64 20 72 75 6e 6e 61 6d 65 20 6b 65 79 76 61 id runname keyva
6d90: 6c 6c 73 74 20 74 65 73 74 2d 72 65 63 6f 72 64 llst test-record
6da0: 20 66 6c 61 67 73 20 70 61 72 65 6e 74 2d 74 65 flags parent-te
6db0: 73 74 29 0a 20 20 3b 3b 20 41 6c 6c 20 74 68 65 st). ;; All the
6dc0: 73 65 20 76 61 72 73 20 6d 69 67 68 74 20 62 65 se vars might be
6dd0: 20 72 65 66 65 72 65 6e 63 65 64 20 62 79 20 74 referenced by t
6de0: 68 65 20 74 65 73 74 63 6f 6e 66 69 67 20 66 69 he testconfig fi
6df0: 6c 65 20 72 65 61 64 65 72 0a 20 20 28 6c 65 74 le reader. (let
6e00: 2a 20 28 28 74 65 73 74 2d 6e 61 6d 65 20 20 20 * ((test-name
6e10: 20 28 74 65 73 74 73 3a 74 65 73 74 71 75 65 75 (tests:testqueu
6e20: 65 2d 67 65 74 2d 74 65 73 74 6e 61 6d 65 20 20 e-get-testname
6e30: 20 74 65 73 74 2d 72 65 63 6f 72 64 29 29 0a 09 test-record))..
6e40: 20 28 74 65 73 74 2d 77 61 69 74 6f 6e 73 20 28 (test-waitons (
6e50: 74 65 73 74 73 3a 74 65 73 74 71 75 65 75 65 2d tests:testqueue-
6e60: 67 65 74 2d 77 61 69 74 6f 6e 73 20 20 20 20 74 get-waitons t
6e70: 65 73 74 2d 72 65 63 6f 72 64 29 29 0a 09 20 28 est-record)).. (
6e80: 74 65 73 74 2d 63 6f 6e 66 20 20 20 20 28 74 65 test-conf (te
6e90: 73 74 73 3a 74 65 73 74 71 75 65 75 65 2d 67 65 sts:testqueue-ge
6ea0: 74 2d 74 65 73 74 63 6f 6e 66 69 67 20 74 65 73 t-testconfig tes
6eb0: 74 2d 72 65 63 6f 72 64 29 29 0a 09 20 28 69 74 t-record)).. (it
6ec0: 65 6d 64 61 74 20 20 20 20 20 20 28 74 65 73 74 emdat (test
6ed0: 73 3a 74 65 73 74 71 75 65 75 65 2d 67 65 74 2d s:testqueue-get-
6ee0: 69 74 65 6d 64 61 74 20 20 20 20 74 65 73 74 2d itemdat test-
6ef0: 72 65 63 6f 72 64 29 29 0a 09 20 28 74 65 73 74 record)).. (test
6f00: 2d 70 61 74 68 20 20 20 20 28 63 6f 6e 63 20 2a -path (conc *
6f10: 74 6f 70 70 61 74 68 2a 20 22 2f 74 65 73 74 73 toppath* "/tests
6f20: 2f 22 20 74 65 73 74 2d 6e 61 6d 65 29 29 20 3b /" test-name)) ;
6f30: 3b 20 63 6f 75 6c 64 20 75 73 65 20 74 65 73 74 ; could use test
6f40: 73 3a 67 65 74 2d 74 65 73 74 63 6f 6e 66 69 67 s:get-testconfig
6f50: 20 68 65 72 65 20 2e 2e 2e 0a 09 20 28 66 6f 72 here ..... (for
6f60: 63 65 20 20 20 20 20 20 20 20 28 68 61 73 68 2d ce (hash-
6f70: 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c table-ref/defaul
6f80: 74 20 66 6c 61 67 73 20 22 2d 66 6f 72 63 65 22 t flags "-force"
6f90: 20 23 66 29 29 0a 09 20 28 72 65 72 75 6e 20 20 #f)).. (rerun
6fa0: 20 20 20 20 20 20 28 68 61 73 68 2d 74 61 62 6c (hash-tabl
6fb0: 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 66 6c e-ref/default fl
6fc0: 61 67 73 20 22 2d 72 65 72 75 6e 22 20 23 66 29 ags "-rerun" #f)
6fd0: 29 0a 09 20 28 6b 65 65 70 67 6f 69 6e 67 20 20 ).. (keepgoing
6fe0: 20 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 (hash-table-re
6ff0: 66 2f 64 65 66 61 75 6c 74 20 66 6c 61 67 73 20 f/default flags
7000: 22 2d 6b 65 65 70 67 6f 69 6e 67 22 20 23 66 29 "-keepgoing" #f)
7010: 29 0a 09 20 28 69 74 65 6d 2d 70 61 74 68 20 20 ).. (item-path
7020: 20 20 20 22 22 29 0a 09 20 28 64 62 20 20 20 20 "").. (db
7030: 20 20 20 20 20 20 20 23 66 29 29 0a 20 20 20 20 #f)).
7040: 28 64 65 62 75 67 3a 70 72 69 6e 74 20 34 0a 09 (debug:print 4..
7050: 09 20 22 74 65 73 74 2d 63 6f 6e 66 69 67 3a 20 . "test-config:
7060: 22 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 3e 61 " (hash-table->a
7070: 6c 69 73 74 20 74 65 73 74 2d 63 6f 6e 66 29 0a list test-conf).
7080: 09 09 20 22 5c 6e 20 20 20 69 74 65 6d 64 61 74 .. "\n itemdat
7090: 3a 20 22 20 69 74 65 6d 64 61 74 0a 09 09 20 29 : " itemdat... )
70a0: 0a 20 20 20 20 3b 3b 20 73 65 74 74 69 6e 67 20 . ;; setting
70b0: 69 74 65 6d 64 61 74 20 74 6f 20 61 20 6c 69 73 itemdat to a lis
70c0: 74 20 69 66 20 69 74 20 69 73 20 23 66 0a 20 20 t if it is #f.
70d0: 20 20 28 69 66 20 28 6e 6f 74 20 69 74 65 6d 64 (if (not itemd
70e0: 61 74 29 28 73 65 74 21 20 69 74 65 6d 64 61 74 at)(set! itemdat
70f0: 20 27 28 29 29 29 0a 20 20 20 20 28 73 65 74 21 '())). (set!
7100: 20 69 74 65 6d 2d 70 61 74 68 20 28 69 74 65 6d item-path (item
7110: 2d 6c 69 73 74 2d 3e 70 61 74 68 20 69 74 65 6d -list->path item
7120: 64 61 74 29 29 0a 20 20 20 20 28 64 65 62 75 67 dat)). (debug
7130: 3a 70 72 69 6e 74 20 32 20 22 41 74 74 65 6d 70 :print 2 "Attemp
7140: 74 69 6e 67 20 74 6f 20 6c 61 75 6e 63 68 20 74 ting to launch t
7150: 65 73 74 20 22 20 74 65 73 74 2d 6e 61 6d 65 20 est " test-name
7160: 28 69 66 20 28 65 71 75 61 6c 3f 20 69 74 65 6d (if (equal? item
7170: 2d 70 61 74 68 20 22 2f 22 29 20 22 2f 22 20 69 -path "/") "/" i
7180: 74 65 6d 2d 70 61 74 68 29 29 0a 20 20 20 20 28 tem-path)). (
7190: 73 65 74 65 6e 76 20 22 4d 54 5f 54 45 53 54 5f setenv "MT_TEST_
71a0: 4e 41 4d 45 22 20 74 65 73 74 2d 6e 61 6d 65 29 NAME" test-name)
71b0: 20 3b 3b 20 0a 20 20 20 20 28 73 65 74 65 6e 76 ;; . (setenv
71c0: 20 22 4d 54 5f 52 55 4e 4e 41 4d 45 22 20 20 20 "MT_RUNNAME"
71d0: 72 75 6e 6e 61 6d 65 29 0a 20 20 20 20 28 73 65 runname). (se
71e0: 74 2d 6d 65 67 61 74 65 73 74 2d 65 6e 76 2d 76 t-megatest-env-v
71f0: 61 72 73 20 72 75 6e 2d 69 64 29 20 3b 3b 20 74 ars run-id) ;; t
7200: 68 65 73 65 20 6d 61 79 20 62 65 20 6e 65 65 64 hese may be need
7210: 65 64 20 62 79 20 74 68 65 20 6c 61 75 6e 63 68 ed by the launch
7220: 69 6e 67 20 70 72 6f 63 65 73 73 0a 20 20 20 20 ing process.
7230: 28 63 68 61 6e 67 65 2d 64 69 72 65 63 74 6f 72 (change-director
7240: 79 20 2a 74 6f 70 70 61 74 68 2a 29 0a 0a 20 20 y *toppath*)..
7250: 20 20 3b 3b 20 48 65 72 65 20 69 73 20 77 68 65 ;; Here is whe
7260: 72 65 20 74 68 65 20 74 65 73 74 5f 6d 65 74 61 re the test_meta
7270: 20 74 61 62 6c 65 20 69 73 20 62 65 73 74 20 75 table is best u
7280: 70 64 61 74 65 64 0a 20 20 20 20 3b 3b 20 59 65 pdated. ;; Ye
7290: 73 2c 20 61 6e 6f 74 68 65 72 20 75 73 65 20 6f s, another use o
72a0: 66 20 61 20 67 6c 6f 62 61 6c 20 66 6f 72 20 63 f a global for c
72b0: 61 63 68 69 6e 67 2e 20 4e 65 65 64 20 61 20 62 aching. Need a b
72c0: 65 74 74 65 72 20 77 61 79 3f 0a 20 20 20 20 28 etter way?. (
72d0: 69 66 20 28 6e 6f 74 20 28 68 61 73 68 2d 74 61 if (not (hash-ta
72e0: 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 ble-ref/default
72f0: 2a 74 65 73 74 2d 6d 65 74 61 2d 75 70 64 61 74 *test-meta-updat
7300: 65 64 2a 20 74 65 73 74 2d 6e 61 6d 65 20 23 66 ed* test-name #f
7310: 29 29 0a 20 20 20 20 20 20 20 20 28 62 65 67 69 )). (begi
7320: 6e 0a 09 20 20 20 28 68 61 73 68 2d 74 61 62 6c n.. (hash-tabl
7330: 65 2d 73 65 74 21 20 2a 74 65 73 74 2d 6d 65 74 e-set! *test-met
7340: 61 2d 75 70 64 61 74 65 64 2a 20 74 65 73 74 2d a-updated* test-
7350: 6e 61 6d 65 20 23 74 29 0a 20 20 20 20 20 20 20 name #t).
7360: 20 20 20 20 28 6f 70 65 6e 2d 72 75 6e 2d 63 6c (open-run-cl
7370: 6f 73 65 20 72 75 6e 73 3a 75 70 64 61 74 65 2d ose runs:update-
7380: 74 65 73 74 5f 6d 65 74 61 20 64 62 20 74 65 73 test_meta db tes
7390: 74 2d 6e 61 6d 65 20 74 65 73 74 2d 63 6f 6e 66 t-name test-conf
73a0: 29 29 29 0a 20 20 20 20 0a 20 20 20 20 3b 3b 20 ))). . ;;
73b0: 28 6c 61 6d 62 64 61 20 28 69 74 65 6d 64 61 74 (lambda (itemdat
73c0: 29 20 3b 3b 3b 20 28 28 72 69 70 65 6e 65 73 73 ) ;;; ((ripeness
73d0: 20 22 6f 76 65 72 72 69 70 65 22 29 20 28 74 65 "overripe") (te
73e0: 6d 70 65 72 61 74 75 72 65 20 22 63 6f 6f 6c 22 mperature "cool"
73f0: 29 20 28 73 65 61 73 6f 6e 20 22 73 75 6d 6d 65 ) (season "summe
7400: 72 22 29 29 0a 20 20 20 20 28 6c 65 74 2a 20 28 r")). (let* (
7410: 28 6e 65 77 2d 74 65 73 74 2d 70 61 74 68 20 28 (new-test-path (
7420: 73 74 72 69 6e 67 2d 69 6e 74 65 72 73 70 65 72 string-intersper
7430: 73 65 20 28 63 6f 6e 73 20 74 65 73 74 2d 70 61 se (cons test-pa
7440: 74 68 20 28 6d 61 70 20 63 61 64 72 20 69 74 65 th (map cadr ite
7450: 6d 64 61 74 29 29 20 22 2f 22 29 29 0a 09 20 20 mdat)) "/"))..
7460: 20 28 6e 65 77 2d 74 65 73 74 2d 6e 61 6d 65 20 (new-test-name
7470: 28 69 66 20 28 65 71 75 61 6c 3f 20 69 74 65 6d (if (equal? item
7480: 2d 70 61 74 68 20 22 22 29 20 74 65 73 74 2d 6e -path "") test-n
7490: 61 6d 65 20 28 63 6f 6e 63 20 74 65 73 74 2d 6e ame (conc test-n
74a0: 61 6d 65 20 22 2f 22 20 69 74 65 6d 2d 70 61 74 ame "/" item-pat
74b0: 68 29 29 29 20 3b 3b 20 6a 75 73 74 20 6e 65 65 h))) ;; just nee
74c0: 64 20 69 74 20 74 6f 20 62 65 20 75 6e 69 71 75 d it to be uniqu
74d0: 65 0a 09 20 20 20 28 74 65 73 74 2d 69 64 20 20 e.. (test-id
74e0: 20 20 20 20 20 28 63 64 62 3a 72 65 6d 6f 74 65 (cdb:remote
74f0: 2d 72 75 6e 20 64 62 3a 67 65 74 2d 74 65 73 74 -run db:get-test
7500: 2d 69 64 20 23 66 20 20 72 75 6e 2d 69 64 20 74 -id #f run-id t
7510: 65 73 74 2d 6e 61 6d 65 20 69 74 65 6d 2d 70 61 est-name item-pa
7520: 74 68 29 29 0a 09 20 20 20 28 74 65 73 74 64 61 th)).. (testda
7530: 74 20 20 20 20 20 20 20 28 63 64 62 3a 72 65 6d t (cdb:rem
7540: 6f 74 65 2d 72 75 6e 20 64 62 3a 67 65 74 2d 74 ote-run db:get-t
7550: 65 73 74 2d 69 6e 66 6f 2d 62 79 2d 69 64 20 23 est-info-by-id #
7560: 66 20 74 65 73 74 2d 69 64 29 29 29 0a 20 20 20 f test-id))).
7570: 20 20 20 28 69 66 20 28 6e 6f 74 20 74 65 73 74 (if (not test
7580: 64 61 74 29 0a 09 20 20 28 62 65 67 69 6e 0a 09 dat).. (begin..
7590: 20 20 20 20 3b 3b 20 65 6e 73 75 72 65 20 74 68 ;; ensure th
75a0: 61 74 20 74 68 65 20 70 61 74 68 20 65 78 69 73 at the path exis
75b0: 74 73 20 62 65 66 6f 72 65 20 72 65 67 69 73 74 ts before regist
75c0: 65 72 69 6e 67 20 74 68 65 20 74 65 73 74 0a 09 ering the test..
75d0: 20 20 20 20 3b 3b 20 4e 4f 50 45 3a 20 43 61 6e ;; NOPE: Can
75e0: 6e 6f 74 21 20 44 6f 6e 27 74 20 6b 6e 6f 77 20 not! Don't know
75f0: 79 65 74 20 77 68 69 63 68 20 64 69 73 6b 20 61 yet which disk a
7600: 72 65 61 20 77 69 6c 6c 20 62 65 20 61 73 73 69 rea will be assi
7610: 67 6e 65 64 2e 2e 2e 2e 0a 09 20 20 20 20 3b 3b gned...... ;;
7620: 20 28 73 79 73 74 65 6d 20 28 63 6f 6e 63 20 22 (system (conc "
7630: 6d 6b 64 69 72 20 2d 70 20 22 20 6e 65 77 2d 74 mkdir -p " new-t
7640: 65 73 74 2d 70 61 74 68 29 29 0a 09 20 20 20 20 est-path))..
7650: 3b 3b 0a 09 20 20 20 20 3b 3b 20 28 6f 70 65 6e ;;.. ;; (open
7660: 2d 72 75 6e 2d 63 6c 6f 73 65 20 74 65 73 74 73 -run-close tests
7670: 3a 72 65 67 69 73 74 65 72 2d 74 65 73 74 20 64 :register-test d
7680: 62 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 6e 61 b run-id test-na
7690: 6d 65 20 69 74 65 6d 2d 70 61 74 68 29 0a 09 20 me item-path)..
76a0: 20 20 20 3b 3b 0a 09 20 20 20 20 3b 3b 20 4e 42 ;;.. ;; NB
76b0: 2f 2f 20 66 6f 72 20 74 68 65 20 61 62 6f 76 65 // for the above
76c0: 20 6c 69 6e 65 2e 20 49 20 77 61 6e 74 20 74 68 line. I want th
76d0: 65 20 74 65 73 74 20 74 6f 20 62 65 20 72 65 67 e test to be reg
76e0: 69 73 74 65 72 65 64 20 6c 6f 6e 67 20 62 65 66 istered long bef
76f0: 6f 72 65 20 74 68 69 73 20 72 6f 75 74 69 6e 65 ore this routine
7700: 20 67 65 74 73 20 63 61 6c 6c 65 64 21 0a 09 20 gets called!..
7710: 20 20 20 3b 3b 0a 09 20 20 20 20 28 73 65 74 21 ;;.. (set!
7720: 20 74 65 73 74 2d 69 64 20 28 6f 70 65 6e 2d 72 test-id (open-r
7730: 75 6e 2d 63 6c 6f 73 65 20 64 62 3a 67 65 74 2d un-close db:get-
7740: 74 65 73 74 2d 69 64 20 64 62 20 72 75 6e 2d 69 test-id db run-i
7750: 64 20 74 65 73 74 2d 6e 61 6d 65 20 69 74 65 6d d test-name item
7760: 2d 70 61 74 68 29 29 0a 09 20 20 20 20 28 69 66 -path)).. (if
7770: 20 28 6e 6f 74 20 74 65 73 74 2d 69 64 29 0a 09 (not test-id)..
7780: 09 28 62 65 67 69 6e 0a 09 09 20 20 28 64 65 62 .(begin... (deb
7790: 75 67 3a 70 72 69 6e 74 20 32 20 22 57 41 52 4e ug:print 2 "WARN
77a0: 3a 20 54 65 73 74 20 6e 6f 74 20 70 72 65 2d 63 : Test not pre-c
77b0: 72 65 61 74 65 64 3f 20 74 65 73 74 2d 6e 61 6d reated? test-nam
77c0: 65 3d 22 20 74 65 73 74 2d 6e 61 6d 65 20 22 2c e=" test-name ",
77d0: 20 69 74 65 6d 2d 70 61 74 68 3d 22 20 69 74 65 item-path=" ite
77e0: 6d 2d 70 61 74 68 20 22 2c 20 72 75 6e 2d 69 64 m-path ", run-id
77f0: 3d 22 20 72 75 6e 2d 69 64 29 0a 09 09 20 20 28 =" run-id)... (
7800: 6f 70 65 6e 2d 72 75 6e 2d 63 6c 6f 73 65 20 64 open-run-close d
7810: 62 3a 74 65 73 74 73 2d 72 65 67 69 73 74 65 72 b:tests-register
7820: 2d 74 65 73 74 20 23 66 20 72 75 6e 2d 69 64 20 -test #f run-id
7830: 74 65 73 74 2d 6e 61 6d 65 20 69 74 65 6d 2d 70 test-name item-p
7840: 61 74 68 29 0a 09 09 20 20 28 73 65 74 21 20 74 ath)... (set! t
7850: 65 73 74 2d 69 64 20 28 6f 70 65 6e 2d 72 75 6e est-id (open-run
7860: 2d 63 6c 6f 73 65 20 64 62 3a 67 65 74 2d 74 65 -close db:get-te
7870: 73 74 2d 69 64 20 64 62 20 72 75 6e 2d 69 64 20 st-id db run-id
7880: 74 65 73 74 2d 6e 61 6d 65 20 69 74 65 6d 2d 70 test-name item-p
7890: 61 74 68 29 29 29 29 0a 09 20 20 20 20 28 64 65 ath)))).. (de
78a0: 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 34 bug:print-info 4
78b0: 20 22 74 65 73 74 2d 69 64 3d 22 20 74 65 73 74 "test-id=" test
78c0: 2d 69 64 20 22 2c 20 72 75 6e 2d 69 64 3d 22 20 -id ", run-id="
78d0: 72 75 6e 2d 69 64 20 22 2c 20 74 65 73 74 2d 6e run-id ", test-n
78e0: 61 6d 65 3d 22 20 74 65 73 74 2d 6e 61 6d 65 20 ame=" test-name
78f0: 22 2c 20 69 74 65 6d 2d 70 61 74 68 3d 5c 22 22 ", item-path=\""
7900: 20 69 74 65 6d 2d 70 61 74 68 20 22 5c 22 22 29 item-path "\"")
7910: 0a 09 20 20 20 20 28 73 65 74 21 20 74 65 73 74 .. (set! test
7920: 64 61 74 20 28 6f 70 65 6e 2d 72 75 6e 2d 63 6c dat (open-run-cl
7930: 6f 73 65 20 64 62 3a 67 65 74 2d 74 65 73 74 2d ose db:get-test-
7940: 69 6e 66 6f 2d 62 79 2d 69 64 20 64 62 20 74 65 info-by-id db te
7950: 73 74 2d 69 64 29 29 29 29 0a 20 20 20 20 20 20 st-id)))).
7960: 28 73 65 74 21 20 74 65 73 74 2d 69 64 20 28 64 (set! test-id (d
7970: 62 3a 74 65 73 74 2d 67 65 74 2d 69 64 20 74 65 b:test-get-id te
7980: 73 74 64 61 74 29 29 0a 20 20 20 20 20 20 28 63 stdat)). (c
7990: 68 61 6e 67 65 2d 64 69 72 65 63 74 6f 72 79 20 hange-directory
79a0: 74 65 73 74 2d 70 61 74 68 29 0a 20 20 20 20 20 test-path).
79b0: 20 28 63 61 73 65 20 28 69 66 20 66 6f 72 63 65 (case (if force
79c0: 20 3b 3b 20 28 61 72 67 73 3a 67 65 74 2d 61 72 ;; (args:get-ar
79d0: 67 20 22 2d 66 6f 72 63 65 22 29 0a 09 09 27 4e g "-force")...'N
79e0: 4f 54 5f 53 54 41 52 54 45 44 0a 09 09 28 69 66 OT_STARTED...(if
79f0: 20 74 65 73 74 64 61 74 0a 09 09 20 20 20 20 28 testdat... (
7a00: 73 74 72 69 6e 67 2d 3e 73 79 6d 62 6f 6c 20 28 string->symbol (
7a10: 74 65 73 74 3a 67 65 74 2d 73 74 61 74 65 20 74 test:get-state t
7a20: 65 73 74 64 61 74 29 29 0a 09 09 20 20 20 20 27 estdat))... '
7a30: 66 61 69 6c 65 64 2d 74 6f 2d 69 6e 73 65 72 74 failed-to-insert
7a40: 29 29 0a 09 28 28 66 61 69 6c 65 64 2d 74 6f 2d ))..((failed-to-
7a50: 69 6e 73 65 72 74 29 0a 09 20 28 64 65 62 75 67 insert).. (debug
7a60: 3a 70 72 69 6e 74 20 30 20 22 45 52 52 4f 52 3a :print 0 "ERROR:
7a70: 20 46 61 69 6c 65 64 20 74 6f 20 69 6e 73 65 72 Failed to inser
7a80: 74 20 74 68 65 20 72 65 63 6f 72 64 20 69 6e 74 t the record int
7a90: 6f 20 74 68 65 20 64 62 22 29 29 0a 09 28 28 4e o the db"))..((N
7aa0: 4f 54 5f 53 54 41 52 54 45 44 20 43 4f 4d 50 4c OT_STARTED COMPL
7ab0: 45 54 45 44 20 44 45 4c 45 54 45 44 29 0a 09 20 ETED DELETED)..
7ac0: 28 6c 65 74 20 28 28 72 75 6e 66 6c 61 67 20 23 (let ((runflag #
7ad0: 66 29 29 0a 09 20 20 20 28 63 6f 6e 64 0a 09 20 f)).. (cond..
7ae0: 20 20 20 3b 3b 20 2d 66 6f 72 63 65 2c 20 72 75 ;; -force, ru
7af0: 6e 20 6e 6f 20 6d 61 74 74 65 72 20 77 68 61 74 n no matter what
7b00: 0a 09 20 20 20 20 28 66 6f 72 63 65 20 28 73 65 .. (force (se
7b10: 74 21 20 72 75 6e 66 6c 61 67 20 23 74 29 29 0a t! runflag #t)).
7b20: 09 20 20 20 20 3b 3b 20 4e 4f 54 5f 53 54 41 52 . ;; NOT_STAR
7b30: 54 45 44 2c 20 72 75 6e 20 6e 6f 20 6d 61 74 74 TED, run no matt
7b40: 65 72 20 77 68 61 74 0a 09 20 20 20 20 28 28 6d er what.. ((m
7b50: 65 6d 62 65 72 20 28 74 65 73 74 3a 67 65 74 2d ember (test:get-
7b60: 73 74 61 74 65 20 74 65 73 74 64 61 74 29 20 27 state testdat) '
7b70: 28 22 44 45 4c 45 54 45 44 22 20 22 4e 4f 54 5f ("DELETED" "NOT_
7b80: 53 54 41 52 54 45 44 22 29 29 28 73 65 74 21 20 STARTED"))(set!
7b90: 72 75 6e 66 6c 61 67 20 23 74 29 29 0a 09 20 20 runflag #t))..
7ba0: 20 20 3b 3b 20 6e 6f 74 20 2d 72 65 72 75 6e 20 ;; not -rerun
7bb0: 61 6e 64 20 50 41 53 53 2c 20 57 41 52 4e 20 6f and PASS, WARN o
7bc0: 72 20 43 48 45 43 4b 2c 20 64 6f 20 6e 6f 20 72 r CHECK, do no r
7bd0: 75 6e 0a 09 20 20 20 20 28 28 61 6e 64 20 28 6f un.. ((and (o
7be0: 72 20 28 6e 6f 74 20 72 65 72 75 6e 29 0a 09 09 r (not rerun)...
7bf0: 20 20 20 20 20 20 6b 65 65 70 67 6f 69 6e 67 29 keepgoing)
7c00: 0a 09 09 20 20 3b 3b 20 52 65 71 75 69 72 65 20 ... ;; Require
7c10: 74 6f 20 66 6f 72 63 65 20 72 65 2d 72 75 6e 20 to force re-run
7c20: 66 6f 72 20 43 4f 4d 50 4c 45 54 45 44 20 6f 72 for COMPLETED or
7c30: 20 2a 61 6e 79 74 68 69 6e 67 2a 20 2b 20 50 41 *anything* + PA
7c40: 53 53 2c 57 41 52 4e 20 6f 72 20 43 48 45 43 4b SS,WARN or CHECK
7c50: 0a 09 09 20 20 28 6f 72 20 28 6d 65 6d 62 65 72 ... (or (member
7c60: 20 28 74 65 73 74 3a 67 65 74 2d 73 74 61 74 75 (test:get-statu
7c70: 73 20 74 65 73 74 64 61 74 29 20 27 28 22 50 41 s testdat) '("PA
7c80: 53 53 22 20 22 57 41 52 4e 22 20 22 43 48 45 43 SS" "WARN" "CHEC
7c90: 4b 22 29 29 0a 09 09 20 20 20 20 20 20 28 6d 65 K"))... (me
7ca0: 6d 62 65 72 20 28 74 65 73 74 3a 67 65 74 2d 73 mber (test:get-s
7cb0: 74 61 74 65 20 20 74 65 73 74 64 61 74 29 20 27 tate testdat) '
7cc0: 28 22 43 4f 4d 50 4c 45 54 45 44 22 29 29 29 29 ("COMPLETED"))))
7cd0: 20 0a 09 20 20 20 20 20 28 64 65 62 75 67 3a 70 .. (debug:p
7ce0: 72 69 6e 74 2d 69 6e 66 6f 20 32 20 22 72 75 6e rint-info 2 "run
7cf0: 6e 69 6e 67 20 74 65 73 74 20 22 20 74 65 73 74 ning test " test
7d00: 2d 6e 61 6d 65 20 22 2f 22 20 69 74 65 6d 2d 70 -name "/" item-p
7d10: 61 74 68 20 22 20 73 75 70 70 72 65 73 73 65 64 ath " suppressed
7d20: 20 61 73 20 69 74 20 69 73 20 22 20 28 74 65 73 as it is " (tes
7d30: 74 3a 67 65 74 2d 73 74 61 74 65 20 74 65 73 74 t:get-state test
7d40: 64 61 74 29 20 22 20 61 6e 64 20 22 20 28 74 65 dat) " and " (te
7d50: 73 74 3a 67 65 74 2d 73 74 61 74 75 73 20 74 65 st:get-status te
7d60: 73 74 64 61 74 29 29 0a 09 20 20 20 20 20 28 73 stdat)).. (s
7d70: 65 74 21 20 72 75 6e 66 6c 61 67 20 23 66 29 29 et! runflag #f))
7d80: 0a 09 20 20 20 20 3b 3b 20 2d 72 65 72 75 6e 20 .. ;; -rerun
7d90: 61 6e 64 20 73 74 61 74 75 73 20 69 73 20 6f 6e and status is on
7da0: 65 20 6f 66 20 74 68 65 20 73 70 65 63 69 66 65 e of the specife
7db0: 64 2c 20 72 75 6e 20 69 74 0a 09 20 20 20 20 28 d, run it.. (
7dc0: 28 61 6e 64 20 72 65 72 75 6e 0a 09 09 20 20 28 (and rerun... (
7dd0: 6c 65 74 2a 20 28 28 72 65 72 75 6e 6c 73 74 20 let* ((rerunlst
7de0: 20 20 28 73 74 72 69 6e 67 2d 73 70 6c 69 74 20 (string-split
7df0: 72 65 72 75 6e 20 22 2c 22 29 29 0a 09 09 09 20 rerun ","))....
7e00: 28 6d 75 73 74 2d 72 65 72 75 6e 20 28 6d 65 6d (must-rerun (mem
7e10: 62 65 72 20 28 74 65 73 74 3a 67 65 74 2d 73 74 ber (test:get-st
7e20: 61 74 75 73 20 74 65 73 74 64 61 74 29 20 72 65 atus testdat) re
7e30: 72 75 6e 6c 73 74 29 29 29 0a 09 09 20 20 20 20 runlst)))...
7e40: 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 (debug:print-inf
7e50: 6f 20 33 20 22 2d 72 65 72 75 6e 20 6c 69 73 74 o 3 "-rerun list
7e60: 3a 20 22 20 72 65 72 75 6e 20 22 2c 20 74 65 73 : " rerun ", tes
7e70: 74 2d 73 74 61 74 75 73 3a 20 22 20 28 74 65 73 t-status: " (tes
7e80: 74 3a 67 65 74 2d 73 74 61 74 75 73 20 74 65 73 t:get-status tes
7e90: 74 64 61 74 29 22 2c 20 6d 75 73 74 2d 72 65 72 tdat)", must-rer
7ea0: 75 6e 3a 20 22 20 6d 75 73 74 2d 72 65 72 75 6e un: " must-rerun
7eb0: 29 0a 09 09 20 20 20 20 6d 75 73 74 2d 72 65 72 )... must-rer
7ec0: 75 6e 29 29 0a 09 20 20 20 20 20 28 64 65 62 75 un)).. (debu
7ed0: 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 32 20 22 g:print-info 2 "
7ee0: 52 65 72 75 6e 20 66 6f 72 63 65 64 20 66 6f 72 Rerun forced for
7ef0: 20 74 65 73 74 20 22 20 74 65 73 74 2d 6e 61 6d test " test-nam
7f00: 65 20 22 2f 22 20 69 74 65 6d 2d 70 61 74 68 29 e "/" item-path)
7f10: 0a 09 20 20 20 20 20 28 73 65 74 21 20 72 75 6e .. (set! run
7f20: 66 6c 61 67 20 23 74 29 29 0a 09 20 20 20 20 3b flag #t)).. ;
7f30: 3b 20 2d 6b 65 65 70 67 6f 69 6e 67 2c 20 64 6f ; -keepgoing, do
7f40: 20 6e 6f 74 20 72 65 72 75 6e 20 46 41 49 4c 0a not rerun FAIL.
7f50: 09 20 20 20 20 28 28 61 6e 64 20 6b 65 65 70 67 . ((and keepg
7f60: 6f 69 6e 67 0a 09 09 20 20 28 6d 65 6d 62 65 72 oing... (member
7f70: 20 28 74 65 73 74 3a 67 65 74 2d 73 74 61 74 75 (test:get-statu
7f80: 73 20 74 65 73 74 64 61 74 29 20 27 28 22 46 41 s testdat) '("FA
7f90: 49 4c 22 29 29 29 0a 09 20 20 20 20 20 28 73 65 IL"))).. (se
7fa0: 74 21 20 72 75 6e 66 6c 61 67 20 23 66 29 29 0a t! runflag #f)).
7fb0: 09 20 20 20 20 28 28 61 6e 64 20 28 6e 6f 74 20 . ((and (not
7fc0: 72 65 72 75 6e 29 0a 09 09 20 20 28 6d 65 6d 62 rerun)... (memb
7fd0: 65 72 20 28 74 65 73 74 3a 67 65 74 2d 73 74 61 er (test:get-sta
7fe0: 74 75 73 20 74 65 73 74 64 61 74 29 20 27 28 22 tus testdat) '("
7ff0: 46 41 49 4c 22 20 22 6e 2f 61 22 29 29 29 0a 09 FAIL" "n/a")))..
8000: 20 20 20 20 20 28 73 65 74 21 20 72 75 6e 66 6c (set! runfl
8010: 61 67 20 23 74 29 29 0a 09 20 20 20 20 28 65 6c ag #t)).. (el
8020: 73 65 20 28 73 65 74 21 20 72 75 6e 66 6c 61 67 se (set! runflag
8030: 20 23 66 29 29 29 0a 09 20 20 20 28 64 65 62 75 #f))).. (debu
8040: 67 3a 70 72 69 6e 74 20 36 20 22 52 55 4e 4e 49 g:print 6 "RUNNI
8050: 4e 47 20 3d 3e 20 72 75 6e 66 6c 61 67 3a 20 22 NG => runflag: "
8060: 20 72 75 6e 66 6c 61 67 20 22 20 53 54 41 54 45 runflag " STATE
8070: 3a 20 22 20 28 74 65 73 74 3a 67 65 74 2d 73 74 : " (test:get-st
8080: 61 74 65 20 74 65 73 74 64 61 74 29 20 22 20 53 ate testdat) " S
8090: 54 41 54 55 53 3a 20 22 20 28 74 65 73 74 3a 67 TATUS: " (test:g
80a0: 65 74 2d 73 74 61 74 75 73 20 74 65 73 74 64 61 et-status testda
80b0: 74 29 29 0a 09 20 20 20 28 69 66 20 28 6e 6f 74 t)).. (if (not
80c0: 20 72 75 6e 66 6c 61 67 29 0a 09 20 20 20 20 20 runflag)..
80d0: 20 20 28 69 66 20 28 6e 6f 74 20 70 61 72 65 6e (if (not paren
80e0: 74 2d 74 65 73 74 29 0a 09 09 20 20 20 28 64 65 t-test)... (de
80f0: 62 75 67 3a 70 72 69 6e 74 20 31 20 22 4e 4f 54 bug:print 1 "NOT
8100: 45 3a 20 4e 6f 74 20 73 74 61 72 74 69 6e 67 20 E: Not starting
8110: 74 65 73 74 20 22 20 6e 65 77 2d 74 65 73 74 2d test " new-test-
8120: 6e 61 6d 65 20 22 20 61 73 20 69 74 20 69 73 20 name " as it is
8130: 73 74 61 74 65 20 5c 22 22 20 28 74 65 73 74 3a state \"" (test:
8140: 67 65 74 2d 73 74 61 74 65 20 74 65 73 74 64 61 get-state testda
8150: 74 29 20 0a 09 09 09 09 22 5c 22 20 61 6e 64 20 t) ....."\" and
8160: 73 74 61 74 75 73 20 5c 22 22 20 28 74 65 73 74 status \"" (test
8170: 3a 67 65 74 2d 73 74 61 74 75 73 20 74 65 73 74 :get-status test
8180: 64 61 74 29 20 22 5c 22 2c 20 75 73 65 20 2d 72 dat) "\", use -r
8190: 65 72 75 6e 20 5c 22 22 20 28 74 65 73 74 3a 67 erun \"" (test:g
81a0: 65 74 2d 73 74 61 74 75 73 20 74 65 73 74 64 61 et-status testda
81b0: 74 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 t).
81c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
81d0: 20 20 20 22 5c 22 20 6f 72 20 2d 66 6f 72 63 65 "\" or -force
81e0: 20 74 6f 20 6f 76 65 72 72 69 64 65 22 29 29 0a to override")).
81f0: 09 20 20 20 20 20 20 20 3b 3b 20 4e 4f 54 45 3a . ;; NOTE:
8200: 20 4e 6f 20 6c 6f 6e 67 65 72 20 62 65 20 63 68 No longer be ch
8210: 65 63 6b 69 6e 67 20 70 72 65 72 65 71 75 69 73 ecking prerequis
8220: 69 74 65 73 20 68 65 72 65 21 20 57 69 6c 6c 20 ites here! Will
8230: 6e 65 76 65 72 20 67 65 74 20 68 65 72 65 20 75 never get here u
8240: 6e 6c 65 73 73 20 70 72 65 72 65 71 73 20 61 72 nless prereqs ar
8250: 65 0a 09 20 20 20 20 20 20 20 3b 3b 20 20 20 20 e.. ;;
8260: 20 20 20 61 6c 72 65 61 64 79 20 6d 65 74 2e 0a already met..
8270: 09 20 20 20 20 20 20 20 28 69 66 20 28 6e 6f 74 . (if (not
8280: 20 28 6c 61 75 6e 63 68 2d 74 65 73 74 20 23 66 (launch-test #f
8290: 20 72 75 6e 2d 69 64 20 72 75 6e 6e 61 6d 65 20 run-id runname
82a0: 74 65 73 74 2d 63 6f 6e 66 20 6b 65 79 76 61 6c test-conf keyval
82b0: 6c 73 74 20 74 65 73 74 2d 6e 61 6d 65 20 74 65 lst test-name te
82c0: 73 74 2d 70 61 74 68 20 69 74 65 6d 64 61 74 20 st-path itemdat
82d0: 66 6c 61 67 73 29 29 0a 09 09 20 20 20 28 62 65 flags))... (be
82e0: 67 69 6e 0a 09 09 20 20 20 20 20 28 70 72 69 6e gin... (prin
82f0: 74 20 22 45 52 52 4f 52 3a 20 46 61 69 6c 65 64 t "ERROR: Failed
8300: 20 74 6f 20 6c 61 75 6e 63 68 20 74 68 65 20 74 to launch the t
8310: 65 73 74 2e 20 45 78 69 74 69 6e 67 20 61 73 20 est. Exiting as
8320: 73 6f 6f 6e 20 61 73 20 70 6f 73 73 69 62 6c 65 soon as possible
8330: 22 29 0a 09 09 20 20 20 20 20 28 73 65 74 21 20 ")... (set!
8340: 2a 67 6c 6f 62 61 6c 65 78 69 74 73 74 61 74 75 *globalexitstatu
8350: 73 2a 20 31 29 20 3b 3b 20 0a 09 09 20 20 20 20 s* 1) ;; ...
8360: 20 28 70 72 6f 63 65 73 73 2d 73 69 67 6e 61 6c (process-signal
8370: 20 28 63 75 72 72 65 6e 74 2d 70 72 6f 63 65 73 (current-proces
8380: 73 2d 69 64 29 20 73 69 67 6e 61 6c 2f 6b 69 6c s-id) signal/kil
8390: 6c 29 29 29 29 29 29 0a 09 28 28 4b 49 4c 4c 45 l))))))..((KILLE
83a0: 44 29 20 0a 09 20 28 64 65 62 75 67 3a 70 72 69 D) .. (debug:pri
83b0: 6e 74 20 31 20 22 4e 4f 54 45 3a 20 22 20 6e 65 nt 1 "NOTE: " ne
83c0: 77 2d 74 65 73 74 2d 6e 61 6d 65 20 22 20 69 73 w-test-name " is
83d0: 20 61 6c 72 65 61 64 79 20 72 75 6e 6e 69 6e 67 already running
83e0: 20 6f 72 20 77 61 73 20 65 78 70 6c 69 63 74 6c or was explictl
83f0: 79 20 6b 69 6c 6c 65 64 2c 20 75 73 65 20 2d 66 y killed, use -f
8400: 6f 72 63 65 20 74 6f 20 6c 61 75 6e 63 68 20 69 orce to launch i
8410: 74 2e 22 29 29 0a 09 28 28 4c 41 55 4e 43 48 45 t."))..((LAUNCHE
8420: 44 20 52 45 4d 4f 54 45 48 4f 53 54 53 54 41 52 D REMOTEHOSTSTAR
8430: 54 20 52 55 4e 4e 49 4e 47 29 20 20 0a 09 20 28 T RUNNING) .. (
8440: 69 66 20 28 3e 20 28 2d 20 28 63 75 72 72 65 6e if (> (- (curren
8450: 74 2d 73 65 63 6f 6e 64 73 29 28 2b 20 28 64 62 t-seconds)(+ (db
8460: 3a 74 65 73 74 2d 67 65 74 2d 65 76 65 6e 74 5f :test-get-event_
8470: 74 69 6d 65 20 74 65 73 74 64 61 74 29 0a 09 09 time testdat)...
8480: 09 09 20 20 20 20 20 20 20 28 64 62 3a 74 65 73 .. (db:tes
8490: 74 2d 67 65 74 2d 72 75 6e 5f 64 75 72 61 74 69 t-get-run_durati
84a0: 6f 6e 20 74 65 73 74 64 61 74 29 29 29 0a 09 09 on testdat)))...
84b0: 36 30 30 29 20 3b 3b 20 69 2e 65 2e 20 6e 6f 20 600) ;; i.e. no
84c0: 75 70 64 61 74 65 20 66 6f 72 20 6d 6f 72 65 20 update for more
84d0: 74 68 61 6e 20 36 30 30 20 73 65 63 6f 6e 64 73 than 600 seconds
84e0: 0a 09 20 20 20 20 20 28 62 65 67 69 6e 0a 09 20 .. (begin..
84f0: 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 (debug:pri
8500: 6e 74 20 30 20 22 57 41 52 4e 49 4e 47 3a 20 54 nt 0 "WARNING: T
8510: 65 73 74 20 22 20 74 65 73 74 2d 6e 61 6d 65 20 est " test-name
8520: 22 20 61 70 70 65 61 72 73 20 74 6f 20 62 65 20 " appears to be
8530: 64 65 61 64 2e 20 46 6f 72 63 69 6e 67 20 69 74 dead. Forcing it
8540: 20 74 6f 20 73 74 61 74 65 20 49 4e 43 4f 4d 50 to state INCOMP
8550: 4c 45 54 45 20 61 6e 64 20 73 74 61 74 75 73 20 LETE and status
8560: 53 54 55 43 4b 2f 44 45 41 44 22 29 0a 09 20 20 STUCK/DEAD")..
8570: 20 20 20 20 20 28 74 65 73 74 73 3a 74 65 73 74 (tests:test
8580: 2d 73 65 74 2d 73 74 61 74 75 73 21 20 74 65 73 -set-status! tes
8590: 74 2d 69 64 20 22 49 4e 43 4f 4d 50 4c 45 54 45 t-id "INCOMPLETE
85a0: 22 20 22 53 54 55 43 4b 2f 44 45 41 44 22 20 22 " "STUCK/DEAD" "
85b0: 54 65 73 74 20 69 73 20 73 74 75 63 6b 20 6f 72 Test is stuck or
85c0: 20 64 65 61 64 22 20 23 66 29 29 0a 09 20 20 20 dead" #f))..
85d0: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 32 (debug:print 2
85e0: 20 22 4e 4f 54 45 3a 20 22 20 74 65 73 74 2d 6e "NOTE: " test-n
85f0: 61 6d 65 20 22 20 69 73 20 61 6c 72 65 61 64 79 ame " is already
8600: 20 72 75 6e 6e 69 6e 67 22 29 29 29 0a 09 28 65 running")))..(e
8610: 6c 73 65 20 20 20 20 20 20 20 28 64 65 62 75 67 lse (debug
8620: 3a 70 72 69 6e 74 20 30 20 22 45 52 52 4f 52 3a :print 0 "ERROR:
8630: 20 46 61 69 6c 65 64 20 74 6f 20 6c 61 75 6e 63 Failed to launc
8640: 68 20 74 65 73 74 20 22 20 6e 65 77 2d 74 65 73 h test " new-tes
8650: 74 2d 6e 61 6d 65 20 22 2e 20 55 6e 72 65 63 6f t-name ". Unreco
8660: 67 6e 69 73 65 64 20 73 74 61 74 65 20 22 20 28 gnised state " (
8670: 74 65 73 74 3a 67 65 74 2d 73 74 61 74 65 20 74 test:get-state t
8680: 65 73 74 64 61 74 29 29 29 29 29 29 29 0a 0a 3b estdat)))))))..;
8690: 3b 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 3d 3d 3d 3d 3d ================
86c0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
86d0: 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 45 4e 44 20 4f =======.;; END O
86e0: 46 20 4e 45 57 20 53 54 55 46 46 0a 3b 3b 3d 3d F NEW STUFF.;;==
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 3d 3d 3d 3d 3d 3d 3d 3d ================
8720: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8730: 3d 3d 3d 3d 0a 0a 28 64 65 66 69 6e 65 20 28 67 ====..(define (g
8740: 65 74 2d 64 69 72 2d 75 70 2d 6e 20 64 69 72 20 et-dir-up-n dir
8750: 2e 20 70 61 72 61 6d 73 29 20 0a 20 20 28 6c 65 . params) . (le
8760: 74 20 28 28 64 70 61 72 74 73 20 20 28 73 74 72 t ((dparts (str
8770: 69 6e 67 2d 73 70 6c 69 74 20 64 69 72 20 22 2f ing-split dir "/
8780: 22 29 29 0a 09 28 63 6f 75 6e 74 20 20 20 28 69 "))..(count (i
8790: 66 20 28 6e 75 6c 6c 3f 20 70 61 72 61 6d 73 29 f (null? params)
87a0: 20 31 20 28 63 61 72 20 70 61 72 61 6d 73 29 29 1 (car params))
87b0: 29 29 0a 20 20 20 20 28 63 6f 6e 63 20 22 2f 22 )). (conc "/"
87c0: 20 28 73 74 72 69 6e 67 2d 69 6e 74 65 72 73 70 (string-intersp
87d0: 65 72 73 65 20 0a 09 20 20 20 20 20 20 20 28 74 erse .. (t
87e0: 61 6b 65 20 64 70 61 72 74 73 20 28 2d 20 28 6c ake dparts (- (l
87f0: 65 6e 67 74 68 20 64 70 61 72 74 73 29 20 63 6f ength dparts) co
8800: 75 6e 74 29 29 0a 09 20 20 20 20 20 20 20 22 2f unt)).. "/
8810: 22 29 29 29 29 0a 3b 3b 20 52 65 6d 6f 76 65 20 ")))).;; Remove
8820: 72 75 6e 73 0a 3b 3b 20 66 69 65 6c 64 73 20 61 runs.;; fields a
8830: 72 65 20 70 61 73 73 69 6e 67 20 69 6e 20 74 68 re passing in th
8840: 72 6f 75 67 68 20 0a 3b 3b 20 61 63 74 69 6f 6e rough .;; action
8850: 3a 0a 3b 3b 20 20 20 20 27 72 65 6d 6f 76 65 2d :.;; 'remove-
8860: 72 75 6e 73 0a 3b 3b 20 20 20 20 27 73 65 74 2d runs.;; 'set-
8870: 73 74 61 74 65 2d 73 74 61 74 75 73 0a 3b 3b 0a state-status.;;.
8880: 3b 3b 20 4e 42 2f 2f 20 73 68 6f 75 6c 64 20 70 ;; NB// should p
8890: 61 73 73 20 69 6e 20 6b 65 79 73 3f 0a 3b 3b 0a ass in keys?.;;.
88a0: 28 64 65 66 69 6e 65 20 28 72 75 6e 73 3a 6f 70 (define (runs:op
88b0: 65 72 61 74 65 2d 6f 6e 20 61 63 74 69 6f 6e 20 erate-on action
88c0: 72 75 6e 6e 61 6d 65 70 61 74 74 20 74 65 73 74 runnamepatt test
88d0: 70 61 74 74 20 23 21 6b 65 79 20 28 73 74 61 74 patt #!key (stat
88e0: 65 20 23 66 29 28 73 74 61 74 75 73 20 23 66 29 e #f)(status #f)
88f0: 28 6e 65 77 2d 73 74 61 74 65 2d 73 74 61 74 75 (new-state-statu
8900: 73 20 23 66 29 29 0a 20 20 28 6c 65 74 2a 20 28 s #f)). (let* (
8910: 28 64 62 20 20 20 20 20 20 20 20 20 20 20 23 66 (db #f
8920: 29 0a 09 20 28 6b 65 79 73 20 20 20 20 20 20 20 ).. (keys
8930: 20 20 28 6f 70 65 6e 2d 72 75 6e 2d 63 6c 6f 73 (open-run-clos
8940: 65 20 64 62 3a 67 65 74 2d 6b 65 79 73 20 64 62 e db:get-keys db
8950: 29 29 0a 09 20 28 72 75 6e 64 61 74 20 20 20 20 )).. (rundat
8960: 20 20 20 28 6f 70 65 6e 2d 72 75 6e 2d 63 6c 6f (open-run-clo
8970: 73 65 20 72 75 6e 73 3a 67 65 74 2d 72 75 6e 73 se runs:get-runs
8980: 2d 62 79 2d 70 61 74 74 20 64 62 20 6b 65 79 73 -by-patt db keys
8990: 20 72 75 6e 6e 61 6d 65 70 61 74 74 29 29 0a 09 runnamepatt))..
89a0: 20 28 68 65 61 64 65 72 20 20 20 20 20 20 20 28 (header (
89b0: 76 65 63 74 6f 72 2d 72 65 66 20 72 75 6e 64 61 vector-ref runda
89c0: 74 20 30 29 29 0a 09 20 28 72 75 6e 73 20 20 20 t 0)).. (runs
89d0: 20 20 20 20 20 20 28 76 65 63 74 6f 72 2d 72 65 (vector-re
89e0: 66 20 72 75 6e 64 61 74 20 31 29 29 0a 09 20 28 f rundat 1)).. (
89f0: 73 74 61 74 65 73 20 20 20 20 20 20 20 28 69 66 states (if
8a00: 20 73 74 61 74 65 20 20 28 73 74 72 69 6e 67 2d state (string-
8a10: 73 70 6c 69 74 20 73 74 61 74 65 20 20 22 2c 22 split state ","
8a20: 29 20 27 28 29 29 29 0a 09 20 28 73 74 61 74 75 ) '())).. (statu
8a30: 73 65 73 20 20 20 20 20 28 69 66 20 73 74 61 74 ses (if stat
8a40: 75 73 20 28 73 74 72 69 6e 67 2d 73 70 6c 69 74 us (string-split
8a50: 20 73 74 61 74 75 73 20 22 2c 22 29 20 27 28 29 status ",") '()
8a60: 29 29 0a 09 20 28 73 74 61 74 65 2d 73 74 61 74 )).. (state-stat
8a70: 75 73 20 28 69 66 20 28 73 74 72 69 6e 67 3f 20 us (if (string?
8a80: 6e 65 77 2d 73 74 61 74 65 2d 73 74 61 74 75 73 new-state-status
8a90: 29 20 28 73 74 72 69 6e 67 2d 73 70 6c 69 74 20 ) (string-split
8aa0: 6e 65 77 2d 73 74 61 74 65 2d 73 74 61 74 75 73 new-state-status
8ab0: 20 22 2c 22 29 20 27 28 23 66 20 23 66 29 29 29 ",") '(#f #f)))
8ac0: 29 0a 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 ). (debug:pri
8ad0: 6e 74 2d 69 6e 66 6f 20 34 20 22 72 75 6e 73 3a nt-info 4 "runs:
8ae0: 6f 70 65 72 61 74 65 2d 6f 6e 20 3d 3e 20 48 65 operate-on => He
8af0: 61 64 65 72 3a 20 22 20 68 65 61 64 65 72 20 22 ader: " header "
8b00: 20 61 63 74 69 6f 6e 3a 20 22 20 61 63 74 69 6f action: " actio
8b10: 6e 20 22 20 6e 65 77 2d 73 74 61 74 65 2d 73 74 n " new-state-st
8b20: 61 74 75 73 3a 20 22 20 6e 65 77 2d 73 74 61 74 atus: " new-stat
8b30: 65 2d 73 74 61 74 75 73 29 0a 20 20 20 20 28 69 e-status). (i
8b40: 66 20 28 3e 20 32 20 28 6c 65 6e 67 74 68 20 73 f (> 2 (length s
8b50: 74 61 74 65 2d 73 74 61 74 75 73 29 29 0a 09 28 tate-status))..(
8b60: 62 65 67 69 6e 0a 09 20 20 28 64 65 62 75 67 3a begin.. (debug:
8b70: 70 72 69 6e 74 20 30 20 22 45 52 52 4f 52 3a 20 print 0 "ERROR:
8b80: 74 68 65 20 70 61 72 61 6d 65 74 65 72 20 74 6f the parameter to
8b90: 20 2d 73 65 74 2d 73 74 61 74 65 2d 73 74 61 74 -set-state-stat
8ba0: 75 73 20 69 73 20 61 20 63 6f 6d 6d 61 20 64 65 us is a comma de
8bb0: 6c 69 6d 69 74 65 64 20 73 74 72 69 6e 67 2e 20 limited string.
8bc0: 45 2e 67 2e 20 43 4f 4d 50 4c 45 54 45 44 2c 46 E.g. COMPLETED,F
8bd0: 41 49 4c 22 29 0a 09 20 20 28 65 78 69 74 29 29 AIL").. (exit))
8be0: 29 0a 20 20 20 20 28 66 6f 72 2d 65 61 63 68 0a ). (for-each.
8bf0: 20 20 20 20 20 28 6c 61 6d 62 64 61 20 28 72 75 (lambda (ru
8c00: 6e 29 0a 20 20 20 20 20 20 20 28 6c 65 74 20 28 n). (let (
8c10: 28 72 75 6e 6b 65 79 20 28 73 74 72 69 6e 67 2d (runkey (string-
8c20: 69 6e 74 65 72 73 70 65 72 73 65 20 28 6d 61 70 intersperse (map
8c30: 20 28 6c 61 6d 62 64 61 20 28 6b 29 0a 09 09 09 (lambda (k)....
8c40: 09 09 09 28 64 62 3a 67 65 74 2d 76 61 6c 75 65 ...(db:get-value
8c50: 2d 62 79 2d 68 65 61 64 65 72 20 72 75 6e 20 68 -by-header run h
8c60: 65 61 64 65 72 20 28 76 65 63 74 6f 72 2d 72 65 eader (vector-re
8c70: 66 20 6b 20 30 29 29 29 20 6b 65 79 73 29 20 22 f k 0))) keys) "
8c80: 2f 22 29 29 0a 09 20 20 20 20 20 28 64 69 72 73 /")).. (dirs
8c90: 2d 74 6f 2d 72 65 6d 6f 76 65 20 28 6d 61 6b 65 -to-remove (make
8ca0: 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 29 0a 09 -hash-table)))..
8cb0: 20 28 6c 65 74 2a 20 28 28 72 75 6e 2d 69 64 20 (let* ((run-id
8cc0: 20 20 20 28 64 62 3a 67 65 74 2d 76 61 6c 75 65 (db:get-value
8cd0: 2d 62 79 2d 68 65 61 64 65 72 20 72 75 6e 20 68 -by-header run h
8ce0: 65 61 64 65 72 20 22 69 64 22 29 29 0a 09 09 28 eader "id"))...(
8cf0: 72 75 6e 2d 73 74 61 74 65 20 28 64 62 3a 67 65 run-state (db:ge
8d00: 74 2d 76 61 6c 75 65 2d 62 79 2d 68 65 61 64 65 t-value-by-heade
8d10: 72 20 72 75 6e 20 68 65 61 64 65 72 20 22 73 74 r run header "st
8d20: 61 74 65 22 29 29 0a 09 09 28 74 65 73 74 73 20 ate"))...(tests
8d30: 20 20 20 20 28 69 66 20 28 6e 6f 74 20 28 65 71 (if (not (eq
8d40: 75 61 6c 3f 20 72 75 6e 2d 73 74 61 74 65 20 22 ual? run-state "
8d50: 6c 6f 63 6b 65 64 22 29 29 0a 09 09 09 20 20 20 locked"))....
8d60: 20 20 20 20 28 6f 70 65 6e 2d 72 75 6e 2d 63 6c (open-run-cl
8d70: 6f 73 65 20 64 62 3a 67 65 74 2d 74 65 73 74 73 ose db:get-tests
8d80: 2d 66 6f 72 2d 72 75 6e 20 64 62 20 72 75 6e 2d -for-run db run-
8d90: 69 64 0a 09 09 09 09 09 09 20 20 20 20 20 20 74 id....... t
8da0: 65 73 74 70 61 74 74 20 73 74 61 74 65 73 20 73 estpatt states s
8db0: 74 61 74 75 73 65 73 0a 09 09 09 09 09 09 20 20 tatuses.......
8dc0: 20 20 20 20 6e 6f 74 2d 69 6e 3a 20 20 23 66 0a not-in: #f.
8dd0: 09 09 09 09 09 09 20 20 20 20 20 20 73 6f 72 74 ...... sort
8de0: 2d 62 79 3a 20 28 63 61 73 65 20 61 63 74 69 6f -by: (case actio
8df0: 6e 0a 09 09 09 09 09 09 09 09 20 28 28 72 65 6d n......... ((rem
8e00: 6f 76 65 2d 72 75 6e 73 29 20 27 72 75 6e 64 69 ove-runs) 'rundi
8e10: 72 29 0a 09 09 09 09 09 09 09 09 20 28 65 6c 73 r)......... (els
8e20: 65 20 20 20 20 20 20 20 20 20 20 27 65 76 65 6e e 'even
8e30: 74 5f 74 69 6d 65 29 29 29 0a 09 09 09 20 20 20 t_time)))....
8e40: 20 20 20 20 27 28 29 29 29 0a 09 09 28 6c 61 73 '()))...(las
8e50: 74 74 70 61 74 68 20 22 2f 64 6f 65 73 2f 6e 6f ttpath "/does/no
8e60: 74 2f 65 78 69 73 74 2f 49 2f 68 6f 70 65 22 29 t/exist/I/hope")
8e70: 29 0a 09 20 20 20 28 64 65 62 75 67 3a 70 72 69 ).. (debug:pri
8e80: 6e 74 2d 69 6e 66 6f 20 34 20 22 72 75 6e 73 3a nt-info 4 "runs:
8e90: 6f 70 65 72 61 74 65 2d 6f 6e 20 72 75 6e 3d 22 operate-on run="
8ea0: 20 72 75 6e 20 22 2c 20 68 65 61 64 65 72 3d 22 run ", header="
8eb0: 20 68 65 61 64 65 72 29 0a 09 20 20 20 28 69 66 header).. (if
8ec0: 20 28 6e 6f 74 20 28 6e 75 6c 6c 3f 20 74 65 73 (not (null? tes
8ed0: 74 73 29 29 0a 09 20 20 20 20 20 20 20 28 62 65 ts)).. (be
8ee0: 67 69 6e 0a 09 09 20 28 63 61 73 65 20 61 63 74 gin... (case act
8ef0: 69 6f 6e 0a 09 09 20 20 20 28 28 72 65 6d 6f 76 ion... ((remov
8f00: 65 2d 72 75 6e 73 29 0a 09 09 20 20 20 20 28 64 e-runs)... (d
8f10: 65 62 75 67 3a 70 72 69 6e 74 20 31 20 22 52 65 ebug:print 1 "Re
8f20: 6d 6f 76 69 6e 67 20 74 65 73 74 73 20 66 6f 72 moving tests for
8f30: 20 72 75 6e 3a 20 22 20 72 75 6e 6b 65 79 20 22 run: " runkey "
8f40: 20 22 20 28 64 62 3a 67 65 74 2d 76 61 6c 75 65 " (db:get-value
8f50: 2d 62 79 2d 68 65 61 64 65 72 20 72 75 6e 20 68 -by-header run h
8f60: 65 61 64 65 72 20 22 72 75 6e 6e 61 6d 65 22 29 eader "runname")
8f70: 29 29 0a 09 09 20 20 20 28 28 73 65 74 2d 73 74 ))... ((set-st
8f80: 61 74 65 2d 73 74 61 74 75 73 29 0a 09 09 20 20 ate-status)...
8f90: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 31 (debug:print 1
8fa0: 20 22 4d 6f 64 69 66 79 69 6e 67 20 73 74 61 74 "Modifying stat
8fb0: 65 20 61 6e 64 20 73 74 61 75 73 20 66 6f 72 20 e and staus for
8fc0: 74 65 73 74 73 20 66 6f 72 20 72 75 6e 3a 20 22 tests for run: "
8fd0: 20 72 75 6e 6b 65 79 20 22 20 22 20 28 64 62 3a runkey " " (db:
8fe0: 67 65 74 2d 76 61 6c 75 65 2d 62 79 2d 68 65 61 get-value-by-hea
8ff0: 64 65 72 20 72 75 6e 20 68 65 61 64 65 72 20 22 der run header "
9000: 72 75 6e 6e 61 6d 65 22 29 29 29 0a 09 09 20 20 runname")))...
9010: 20 28 28 70 72 69 6e 74 2d 72 75 6e 29 0a 09 09 ((print-run)...
9020: 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 (debug:print
9030: 20 31 20 22 50 72 69 6e 74 69 6e 67 20 69 6e 66 1 "Printing inf
9040: 6f 20 66 6f 72 20 72 75 6e 20 22 20 72 75 6e 6b o for run " runk
9050: 65 79 20 22 2c 20 72 75 6e 3d 22 20 72 75 6e 20 ey ", run=" run
9060: 22 2c 20 74 65 73 74 73 3d 22 20 74 65 73 74 73 ", tests=" tests
9070: 20 22 2c 20 68 65 61 64 65 72 3d 22 20 68 65 61 ", header=" hea
9080: 64 65 72 29 0a 09 09 20 20 20 20 61 63 74 69 6f der)... actio
9090: 6e 29 0a 09 09 20 20 20 28 65 6c 73 65 0a 09 09 n)... (else...
90a0: 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 (debug:print
90b0: 2d 69 6e 66 6f 20 30 20 22 61 63 74 69 6f 6e 20 -info 0 "action
90c0: 6e 6f 74 20 72 65 63 6f 67 6e 69 73 65 64 20 22 not recognised "
90d0: 20 61 63 74 69 6f 6e 29 29 29 0a 09 09 20 28 66 action)))... (f
90e0: 6f 72 2d 65 61 63 68 0a 09 09 20 20 28 6c 61 6d or-each... (lam
90f0: 62 64 61 20 28 74 65 73 74 29 0a 09 09 20 20 20 bda (test)...
9100: 20 28 6c 65 74 2a 20 28 28 69 74 65 6d 2d 70 61 (let* ((item-pa
9110: 74 68 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d th (db:test-get-
9120: 69 74 65 6d 2d 70 61 74 68 20 74 65 73 74 29 29 item-path test))
9130: 0a 09 09 09 20 20 20 28 74 65 73 74 2d 6e 61 6d .... (test-nam
9140: 65 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 74 e (db:test-get-t
9150: 65 73 74 6e 61 6d 65 20 74 65 73 74 29 29 0a 09 estname test))..
9160: 09 09 20 20 20 28 72 75 6e 2d 64 69 72 20 20 20 .. (run-dir
9170: 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 72 75 6e (db:test-get-run
9180: 64 69 72 20 74 65 73 74 29 29 20 20 20 20 3b 3b dir test)) ;;
9190: 20 72 75 6e 20 64 69 72 20 69 73 20 66 72 6f 6d run dir is from
91a0: 20 74 68 65 20 6c 69 6e 6b 20 74 72 65 65 0a 09 the link tree..
91b0: 09 09 20 20 20 28 72 65 61 6c 2d 64 69 72 20 20 .. (real-dir
91c0: 28 69 66 20 28 66 69 6c 65 2d 65 78 69 73 74 73 (if (file-exists
91d0: 3f 20 72 75 6e 2d 64 69 72 29 0a 09 09 09 09 09 ? run-dir)......
91e0: 20 20 28 72 65 73 6f 6c 76 65 2d 70 61 74 68 6e (resolve-pathn
91f0: 61 6d 65 20 72 75 6e 2d 64 69 72 29 0a 09 09 09 ame run-dir)....
9200: 09 09 20 20 23 66 29 29 0a 09 09 09 20 20 20 28 .. #f)).... (
9210: 74 65 73 74 2d 69 64 20 20 20 28 64 62 3a 74 65 test-id (db:te
9220: 73 74 2d 67 65 74 2d 69 64 20 74 65 73 74 29 29 st-get-id test))
9230: 29 0a 09 09 20 20 20 20 20 20 3b 3b 20 20 20 28 )... ;; (
9240: 74 64 62 20 20 20 20 20 20 20 28 64 62 3a 6f 70 tdb (db:op
9250: 65 6e 2d 74 65 73 74 2d 64 62 20 72 75 6e 2d 64 en-test-db run-d
9260: 69 72 29 29 29 0a 09 09 20 20 20 20 20 20 28 64 ir)))... (d
9270: 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 ebug:print-info
9280: 34 20 22 74 65 73 74 3d 22 20 74 65 73 74 29 20 4 "test=" test)
9290: 3b 3b 20 20 20 22 20 28 64 62 3a 74 65 73 74 2d ;; " (db:test-
92a0: 67 65 74 2d 74 65 73 74 6e 61 6d 65 20 74 65 73 get-testname tes
92b0: 74 29 20 22 20 69 64 3a 20 22 20 28 64 62 3a 74 t) " id: " (db:t
92c0: 65 73 74 2d 67 65 74 2d 69 64 20 74 65 73 74 29 est-get-id test)
92d0: 20 22 20 22 20 69 74 65 6d 2d 70 61 74 68 20 22 " " item-path "
92e0: 20 61 63 74 69 6f 6e 3a 20 22 20 61 63 74 69 6f action: " actio
92f0: 6e 29 0a 09 09 20 20 20 20 20 20 28 63 61 73 65 n)... (case
9300: 20 61 63 74 69 6f 6e 0a 09 09 09 28 28 72 65 6d action....((rem
9310: 6f 76 65 2d 72 75 6e 73 29 20 3b 3b 20 74 68 65 ove-runs) ;; the
9320: 20 74 64 62 20 69 73 20 66 6f 72 20 66 75 74 75 tdb is for futu
9330: 72 65 20 70 6f 73 73 69 62 6c 65 2e 20 0a 09 09 re possible. ...
9340: 09 20 28 6f 70 65 6e 2d 72 75 6e 2d 63 6c 6f 73 . (open-run-clos
9350: 65 20 64 62 3a 64 65 6c 65 74 65 2d 74 65 73 74 e db:delete-test
9360: 2d 72 65 63 6f 72 64 73 20 64 62 20 23 66 20 28 -records db #f (
9370: 64 62 3a 74 65 73 74 2d 67 65 74 2d 69 64 20 74 db:test-get-id t
9380: 65 73 74 29 29 0a 09 09 09 20 28 64 65 62 75 67 est)).... (debug
9390: 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 31 20 22 41 :print-info 1 "A
93a0: 74 74 65 6d 70 74 69 6e 67 20 74 6f 20 72 65 6d ttempting to rem
93b0: 6f 76 65 20 22 20 28 69 66 20 72 65 61 6c 2d 64 ove " (if real-d
93c0: 69 72 20 28 63 6f 6e 63 20 22 20 64 69 72 20 22 ir (conc " dir "
93d0: 20 72 65 61 6c 2d 64 69 72 20 22 20 61 6e 64 20 real-dir " and
93e0: 22 29 20 22 22 29 20 22 20 6c 69 6e 6b 20 22 20 ") "") " link "
93f0: 72 75 6e 2d 64 69 72 29 0a 09 09 09 20 28 69 66 run-dir).... (if
9400: 20 28 61 6e 64 20 72 65 61 6c 2d 64 69 72 20 0a (and real-dir .
9410: 09 09 09 09 20 20 28 3e 20 28 73 74 72 69 6e 67 .... (> (string
9420: 2d 6c 65 6e 67 74 68 20 72 65 61 6c 2d 64 69 72 -length real-dir
9430: 29 20 35 29 0a 09 09 09 09 20 20 28 66 69 6c 65 ) 5)..... (file
9440: 2d 65 78 69 73 74 73 3f 20 72 65 61 6c 2d 64 69 -exists? real-di
9450: 72 29 29 20 3b 3b 20 62 61 64 20 68 65 75 72 69 r)) ;; bad heuri
9460: 73 74 69 63 20 62 75 74 20 73 68 6f 75 6c 64 20 stic but should
9470: 70 72 65 76 65 6e 74 20 2f 74 6d 70 20 2f 68 6f prevent /tmp /ho
9480: 6d 65 20 65 74 63 2e 0a 09 09 09 20 20 20 20 20 me etc.....
9490: 28 62 65 67 69 6e 20 3b 3b 20 6c 65 74 2a 20 28 (begin ;; let* (
94a0: 28 72 65 61 6c 70 61 74 68 20 28 72 65 73 6f 6c (realpath (resol
94b0: 76 65 2d 70 61 74 68 6e 61 6d 65 20 72 75 6e 2d ve-pathname run-
94c0: 64 69 72 29 29 29 0a 09 09 09 20 20 20 20 20 20 dir)))....
94d0: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e (debug:print-in
94e0: 66 6f 20 31 20 22 52 65 63 75 72 73 69 76 65 6c fo 1 "Recursivel
94f0: 79 20 72 65 6d 6f 76 69 6e 67 20 22 20 72 65 61 y removing " rea
9500: 6c 2d 64 69 72 29 0a 09 09 09 20 20 20 20 20 20 l-dir)....
9510: 20 28 69 66 20 28 66 69 6c 65 2d 65 78 69 73 74 (if (file-exist
9520: 73 3f 20 72 65 61 6c 2d 64 69 72 29 0a 09 09 09 s? real-dir)....
9530: 09 20 20 20 28 69 66 20 28 3e 20 28 73 79 73 74 . (if (> (syst
9540: 65 6d 20 28 63 6f 6e 63 20 22 72 6d 20 2d 72 66 em (conc "rm -rf
9550: 20 22 20 72 65 61 6c 2d 64 69 72 29 29 20 30 29 " real-dir)) 0)
9560: 0a 09 09 09 09 20 20 20 20 20 20 20 28 64 65 62 ..... (deb
9570: 75 67 3a 70 72 69 6e 74 20 30 20 22 45 52 52 4f ug:print 0 "ERRO
9580: 52 3a 20 54 68 65 72 65 20 77 61 73 20 61 20 70 R: There was a p
9590: 72 6f 62 6c 65 6d 20 72 65 6d 6f 76 69 6e 67 20 roblem removing
95a0: 22 20 72 65 61 6c 2d 64 69 72 20 22 20 77 69 74 " real-dir " wit
95b0: 68 20 72 6d 20 2d 66 22 29 29 0a 09 09 09 09 20 h rm -f")).....
95c0: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 (debug:print 0
95d0: 20 22 57 41 52 4e 49 4e 47 3a 20 74 65 73 74 20 "WARNING: test
95e0: 64 69 72 20 22 20 72 65 61 6c 2d 64 69 72 20 22 dir " real-dir "
95f0: 20 61 70 70 65 61 72 73 20 74 6f 20 6e 6f 74 20 appears to not
9600: 65 78 69 73 74 20 6f 72 20 69 73 20 6e 6f 74 20 exist or is not
9610: 72 65 61 64 61 62 6c 65 22 29 29 29 0a 09 09 09 readable")))....
9620: 20 20 20 20 20 28 69 66 20 72 65 61 6c 2d 64 69 (if real-di
9630: 72 20 0a 09 09 09 09 20 28 64 65 62 75 67 3a 70 r ..... (debug:p
9640: 72 69 6e 74 20 30 20 22 57 41 52 4e 49 4e 47 3a rint 0 "WARNING:
9650: 20 64 69 72 65 63 74 6f 72 79 20 22 20 72 65 61 directory " rea
9660: 6c 2d 64 69 72 20 22 20 64 6f 65 73 20 6e 6f 74 l-dir " does not
9670: 20 65 78 69 73 74 22 29 0a 09 09 09 09 20 28 64 exist")..... (d
9680: 65 62 75 67 3a 70 72 69 6e 74 20 30 20 22 57 41 ebug:print 0 "WA
9690: 52 4e 49 4e 47 3a 20 6e 6f 20 72 65 61 6c 20 64 RNING: no real d
96a0: 69 72 65 63 74 6f 72 79 20 63 6f 72 72 6f 73 70 irectory corrosp
96b0: 6f 6e 64 69 6e 67 20 74 6f 20 6c 69 6e 6b 20 22 onding to link "
96c0: 20 72 75 6e 2d 64 69 72 20 22 2c 20 6e 6f 74 68 run-dir ", noth
96d0: 69 6e 67 20 64 6f 6e 65 22 29 29 29 0a 09 09 09 ing done")))....
96e0: 20 28 69 66 20 28 73 79 6d 62 6f 6c 69 63 2d 6c (if (symbolic-l
96f0: 69 6e 6b 3f 20 72 75 6e 2d 64 69 72 29 0a 09 09 ink? run-dir)...
9700: 09 20 20 20 20 20 28 62 65 67 69 6e 0a 09 09 09 . (begin....
9710: 20 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 (debug:pr
9720: 69 6e 74 2d 69 6e 66 6f 20 31 20 22 52 65 6d 6f int-info 1 "Remo
9730: 76 69 6e 67 20 73 79 6d 6c 69 6e 6b 20 22 20 72 ving symlink " r
9740: 75 6e 2d 64 69 72 29 0a 09 09 09 20 20 20 20 20 un-dir)....
9750: 20 20 28 64 65 6c 65 74 65 2d 66 69 6c 65 20 72 (delete-file r
9760: 75 6e 2d 64 69 72 29 29 0a 09 09 09 20 20 20 20 un-dir))....
9770: 20 28 69 66 20 28 64 69 72 65 63 74 6f 72 79 3f (if (directory?
9780: 20 72 75 6e 2d 64 69 72 29 0a 09 09 09 09 20 28 run-dir)..... (
9790: 69 66 20 28 3e 20 28 64 69 72 65 63 74 6f 72 79 if (> (directory
97a0: 2d 66 6f 6c 64 20 28 6c 61 6d 62 64 61 20 28 66 -fold (lambda (f
97b0: 20 78 29 28 2b 20 31 20 78 29 29 20 30 20 72 75 x)(+ 1 x)) 0 ru
97c0: 6e 2d 64 69 72 29 20 30 29 0a 09 09 09 09 20 20 n-dir) 0).....
97d0: 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 (debug:print
97e0: 30 20 22 57 41 52 4e 49 4e 47 3a 20 72 65 66 75 0 "WARNING: refu
97f0: 73 69 6e 67 20 74 6f 20 72 65 6d 6f 76 65 20 22 sing to remove "
9800: 20 72 75 6e 2d 64 69 72 20 22 20 61 73 20 69 74 run-dir " as it
9810: 20 69 73 20 6e 6f 74 20 65 6d 70 74 79 22 29 0a is not empty").
9820: 09 09 09 09 20 20 20 20 20 28 64 65 6c 65 74 65 .... (delete
9830: 2d 64 69 72 65 63 74 6f 72 79 20 72 75 6e 2d 64 -directory run-d
9840: 69 72 29 29 20 3b 3b 20 69 74 20 73 68 6f 75 6c ir)) ;; it shoul
9850: 64 20 62 65 20 65 6d 70 74 79 20 62 79 20 68 65 d be empty by he
9860: 72 65 20 42 55 47 20 42 55 47 2c 20 61 64 64 20 re BUG BUG, add
9870: 65 72 72 6f 72 20 63 61 74 63 68 0a 09 09 09 09 error catch.....
9880: 20 28 69 66 20 72 75 6e 2d 64 69 72 0a 09 09 09 (if run-dir....
9890: 09 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 . (debug:pri
98a0: 6e 74 20 30 20 22 57 41 52 4e 49 4e 47 3a 20 6e nt 0 "WARNING: n
98b0: 6f 74 20 72 65 6d 6f 76 69 6e 67 20 22 20 72 75 ot removing " ru
98c0: 6e 2d 64 69 72 20 22 20 61 73 20 69 74 20 65 69 n-dir " as it ei
98d0: 74 68 65 72 20 64 6f 65 73 6e 27 74 20 65 78 69 ther doesn't exi
98e0: 73 74 20 6f 72 20 69 73 20 6e 6f 74 20 61 20 73 st or is not a s
98f0: 79 6d 6c 69 6e 6b 22 29 0a 09 09 09 09 20 20 20 ymlink").....
9900: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 (debug:print 0
9910: 20 22 4e 4f 54 45 3a 20 74 68 65 20 72 75 6e 20 "NOTE: the run
9920: 64 69 72 20 66 6f 72 20 74 68 69 73 20 74 65 73 dir for this tes
9930: 74 20 69 73 20 75 6e 64 65 66 69 6e 65 64 2e 20 t is undefined.
9940: 54 65 73 74 20 6d 61 79 20 68 61 76 65 20 61 6c Test may have al
9950: 72 65 61 64 79 20 62 65 65 6e 20 64 65 6c 65 74 ready been delet
9960: 65 64 2e 22 29 29 0a 09 09 09 09 20 29 29 29 0a ed."))..... ))).
9970: 09 09 09 28 28 73 65 74 2d 73 74 61 74 65 2d 73 ...((set-state-s
9980: 74 61 74 75 73 29 0a 09 09 09 20 28 64 65 62 75 tatus).... (debu
9990: 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 32 20 22 g:print-info 2 "
99a0: 6e 65 77 20 73 74 61 74 65 20 22 20 28 63 61 72 new state " (car
99b0: 20 73 74 61 74 65 2d 73 74 61 74 75 73 29 20 22 state-status) "
99c0: 2c 20 6e 65 77 20 73 74 61 74 75 73 20 22 20 28 , new status " (
99d0: 63 61 64 72 20 73 74 61 74 65 2d 73 74 61 74 75 cadr state-statu
99e0: 73 29 29 0a 09 09 09 20 28 6f 70 65 6e 2d 72 75 s)).... (open-ru
99f0: 6e 2d 63 6c 6f 73 65 20 64 62 3a 74 65 73 74 2d n-close db:test-
9a00: 73 65 74 2d 73 74 61 74 65 2d 73 74 61 74 75 73 set-state-status
9a10: 2d 62 79 2d 69 64 20 64 62 20 28 64 62 3a 74 65 -by-id db (db:te
9a20: 73 74 2d 67 65 74 2d 69 64 20 74 65 73 74 29 20 st-get-id test)
9a30: 28 63 61 72 20 73 74 61 74 65 2d 73 74 61 74 75 (car state-statu
9a40: 73 29 28 63 61 64 72 20 73 74 61 74 65 2d 73 74 s)(cadr state-st
9a50: 61 74 75 73 29 20 23 66 29 29 29 29 29 0a 09 09 atus) #f)))))...
9a60: 20 20 28 73 6f 72 74 20 74 65 73 74 73 20 28 6c (sort tests (l
9a70: 61 6d 62 64 61 20 28 61 20 62 29 28 6c 65 74 20 ambda (a b)(let
9a80: 28 28 64 69 72 61 20 28 64 62 3a 74 65 73 74 2d ((dira (db:test-
9a90: 67 65 74 2d 72 75 6e 64 69 72 20 61 29 29 0a 09 get-rundir a))..
9aa0: 09 09 09 09 09 20 28 64 69 72 62 20 28 64 62 3a ..... (dirb (db:
9ab0: 74 65 73 74 2d 67 65 74 2d 72 75 6e 64 69 72 20 test-get-rundir
9ac0: 62 29 29 29 0a 09 09 09 09 09 20 20 20 20 20 28 b)))...... (
9ad0: 69 66 20 28 61 6e 64 20 28 73 74 72 69 6e 67 3f if (and (string?
9ae0: 20 64 69 72 61 29 28 73 74 72 69 6e 67 3f 20 64 dira)(string? d
9af0: 69 72 62 29 29 0a 09 09 09 09 09 09 20 28 3e 20 irb))....... (>
9b00: 28 73 74 72 69 6e 67 2d 6c 65 6e 67 74 68 20 64 (string-length d
9b10: 69 72 61 29 28 73 74 72 69 6e 67 2d 6c 65 6e 67 ira)(string-leng
9b20: 74 68 20 64 69 72 62 29 29 0a 09 09 09 09 09 09 th dirb)).......
9b30: 20 23 66 29 29 29 29 29 29 29 0a 09 20 20 20 3b #f))))))).. ;
9b40: 3b 20 72 65 6d 6f 76 65 20 74 68 65 20 72 75 6e ; remove the run
9b50: 20 69 66 20 7a 65 72 6f 20 74 65 73 74 73 20 72 if zero tests r
9b60: 65 6d 61 69 6e 0a 09 20 20 20 28 69 66 20 28 65 emain.. (if (e
9b70: 71 3f 20 61 63 74 69 6f 6e 20 27 72 65 6d 6f 76 q? action 'remov
9b80: 65 2d 72 75 6e 73 29 0a 09 20 20 20 20 20 20 20 e-runs)..
9b90: 28 6c 65 74 20 28 28 72 65 6d 74 65 73 74 73 20 (let ((remtests
9ba0: 28 6f 70 65 6e 2d 72 75 6e 2d 63 6c 6f 73 65 20 (open-run-close
9bb0: 64 62 3a 67 65 74 2d 74 65 73 74 73 2d 66 6f 72 db:get-tests-for
9bc0: 2d 72 75 6e 20 64 62 20 28 64 62 3a 67 65 74 2d -run db (db:get-
9bd0: 76 61 6c 75 65 2d 62 79 2d 68 65 61 64 65 72 20 value-by-header
9be0: 72 75 6e 20 68 65 61 64 65 72 20 22 69 64 22 29 run header "id")
9bf0: 20 23 66 20 27 28 22 44 45 4c 45 54 45 44 22 29 #f '("DELETED")
9c00: 20 27 28 22 6e 2f 61 22 29 20 6e 6f 74 2d 69 6e '("n/a") not-in
9c10: 3a 20 23 74 29 29 29 0a 09 09 20 28 69 66 20 28 : #t)))... (if (
9c20: 6e 75 6c 6c 3f 20 72 65 6d 74 65 73 74 73 29 20 null? remtests)
9c30: 3b 3b 20 6e 6f 20 6d 6f 72 65 20 74 65 73 74 73 ;; no more tests
9c40: 20 72 65 6d 61 69 6e 69 6e 67 0a 09 09 20 20 20 remaining...
9c50: 20 20 28 6c 65 74 2a 20 28 28 64 70 61 72 74 73 (let* ((dparts
9c60: 20 20 28 73 74 72 69 6e 67 2d 73 70 6c 69 74 20 (string-split
9c70: 6c 61 73 74 74 70 61 74 68 20 22 2f 22 29 29 0a lasttpath "/")).
9c80: 09 09 09 20 20 20 20 28 72 75 6e 70 61 74 68 20 ... (runpath
9c90: 28 63 6f 6e 63 20 22 2f 22 20 28 73 74 72 69 6e (conc "/" (strin
9ca0: 67 2d 69 6e 74 65 72 73 70 65 72 73 65 20 0a 09 g-intersperse ..
9cb0: 09 09 09 09 09 28 74 61 6b 65 20 64 70 61 72 74 .....(take dpart
9cc0: 73 20 28 2d 20 28 6c 65 6e 67 74 68 20 64 70 61 s (- (length dpa
9cd0: 72 74 73 29 20 31 29 29 0a 09 09 09 09 09 09 22 rts) 1))......."
9ce0: 2f 22 29 29 29 29 0a 09 09 20 20 20 20 20 20 20 /"))))...
9cf0: 28 64 65 62 75 67 3a 70 72 69 6e 74 20 31 20 22 (debug:print 1 "
9d00: 52 65 6d 6f 76 69 6e 67 20 72 75 6e 3a 20 22 20 Removing run: "
9d10: 72 75 6e 6b 65 79 20 22 20 22 20 28 64 62 3a 67 runkey " " (db:g
9d20: 65 74 2d 76 61 6c 75 65 2d 62 79 2d 68 65 61 64 et-value-by-head
9d30: 65 72 20 72 75 6e 20 68 65 61 64 65 72 20 22 72 er run header "r
9d40: 75 6e 6e 61 6d 65 22 29 20 22 20 61 6e 64 20 72 unname") " and r
9d50: 65 6c 61 74 65 64 20 72 65 63 6f 72 64 22 29 0a elated record").
9d60: 09 09 20 20 20 20 20 20 20 28 6f 70 65 6e 2d 72 .. (open-r
9d70: 75 6e 2d 63 6c 6f 73 65 20 64 62 3a 64 65 6c 65 un-close db:dele
9d80: 74 65 2d 72 75 6e 20 64 62 20 72 75 6e 2d 69 64 te-run db run-id
9d90: 29 0a 09 09 20 20 20 20 20 20 20 3b 3b 20 54 68 )... ;; Th
9da0: 69 73 20 69 73 20 61 20 70 72 65 74 74 79 20 67 is is a pretty g
9db0: 6f 6f 64 20 70 6c 61 63 65 20 74 6f 20 70 75 72 ood place to pur
9dc0: 67 65 20 6f 6c 64 20 44 45 4c 45 54 45 44 20 74 ge old DELETED t
9dd0: 65 73 74 73 0a 09 09 20 20 20 20 20 20 20 28 6f ests... (o
9de0: 70 65 6e 2d 72 75 6e 2d 63 6c 6f 73 65 20 64 62 pen-run-close db
9df0: 3a 64 65 6c 65 74 65 2d 74 65 73 74 73 2d 66 6f :delete-tests-fo
9e00: 72 2d 72 75 6e 20 64 62 20 72 75 6e 2d 69 64 29 r-run db run-id)
9e10: 0a 09 09 20 20 20 20 20 20 20 28 6f 70 65 6e 2d ... (open-
9e20: 72 75 6e 2d 63 6c 6f 73 65 20 64 62 3a 64 65 6c run-close db:del
9e30: 65 74 65 2d 6f 6c 64 2d 64 65 6c 65 74 65 64 2d ete-old-deleted-
9e40: 74 65 73 74 2d 72 65 63 6f 72 64 73 20 64 62 29 test-records db)
9e50: 0a 09 09 20 20 20 20 20 20 20 28 6f 70 65 6e 2d ... (open-
9e60: 72 75 6e 2d 63 6c 6f 73 65 20 64 62 3a 73 65 74 run-close db:set
9e70: 2d 76 61 72 20 64 62 20 22 44 45 4c 45 54 45 44 -var db "DELETED
9e80: 5f 54 45 53 54 53 22 20 28 63 75 72 72 65 6e 74 _TESTS" (current
9e90: 2d 73 65 63 6f 6e 64 73 29 29 0a 09 09 20 20 20 -seconds))...
9ea0: 20 20 20 20 3b 3b 20 6e 65 65 64 20 74 6f 20 66 ;; need to f
9eb0: 69 67 75 72 65 20 6f 75 74 20 74 68 65 20 70 61 igure out the pa
9ec0: 74 68 20 74 6f 20 74 68 65 20 72 75 6e 20 64 69 th to the run di
9ed0: 72 20 61 6e 64 20 72 65 6d 6f 76 65 20 69 74 20 r and remove it
9ee0: 69 66 20 65 6d 70 74 79 0a 09 09 20 20 20 20 20 if empty...
9ef0: 20 20 3b 3b 20 20 20 20 28 69 66 20 28 6e 75 6c ;; (if (nul
9f00: 6c 3f 20 28 67 6c 6f 62 20 28 63 6f 6e 63 20 72 l? (glob (conc r
9f10: 75 6e 70 61 74 68 20 22 2f 2a 22 29 29 29 0a 09 unpath "/*")))..
9f20: 09 20 20 20 20 20 20 20 3b 3b 20 20 20 20 20 20 . ;;
9f30: 20 20 28 62 65 67 69 6e 0a 09 09 20 20 20 20 20 (begin...
9f40: 20 20 3b 3b 20 09 20 28 64 65 62 75 67 3a 70 72 ;; . (debug:pr
9f50: 69 6e 74 20 31 20 22 52 65 6d 6f 76 69 6e 67 20 int 1 "Removing
9f60: 72 75 6e 20 64 69 72 20 22 20 72 75 6e 70 61 74 run dir " runpat
9f70: 68 29 0a 09 09 20 20 20 20 20 20 20 3b 3b 20 09 h)... ;; .
9f80: 20 28 73 79 73 74 65 6d 20 28 63 6f 6e 63 20 22 (system (conc "
9f90: 72 6d 64 69 72 20 2d 70 20 22 20 72 75 6e 70 61 rmdir -p " runpa
9fa0: 74 68 29 29 29 29 0a 09 09 20 20 20 20 20 20 20 th))))...
9fb0: 29 29 29 29 29 0a 09 20 29 29 0a 20 20 20 20 20 ))))).. )).
9fc0: 72 75 6e 73 29 29 0a 20 20 23 74 29 0a 0a 3b 3b runs)). #t)..;;
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 3d 3d 3d 3d 3d 3d ================
a000: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
a010: 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 52 6f 75 74 69 6e ======.;; Routin
a020: 65 73 20 66 6f 72 20 6d 61 6e 69 70 75 6c 61 74 es for manipulat
a030: 69 6e 67 20 72 75 6e 73 0a 3b 3b 3d 3d 3d 3d 3d ing runs.;;=====
a040: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
a050: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
a060: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
a070: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
a080: 3d 0a 0a 3b 3b 20 53 69 6e 63 65 20 6d 61 6e 79 =..;; Since many
a090: 20 63 61 6c 6c 73 20 74 6f 20 61 20 72 75 6e 20 calls to a run
a0a0: 72 65 71 75 69 72 65 20 70 72 65 74 74 79 20 6d require pretty m
a0b0: 75 63 68 20 74 68 65 20 73 61 6d 65 20 73 65 74 uch the same set
a0c0: 75 70 20 0a 3b 3b 20 74 68 69 73 20 77 72 61 70 up .;; this wrap
a0d0: 70 65 72 20 69 73 20 75 73 65 64 20 74 6f 20 72 per is used to r
a0e0: 65 64 75 63 65 20 74 68 65 20 72 65 70 6c 69 63 educe the replic
a0f0: 61 74 69 6f 6e 20 6f 66 20 63 6f 64 65 0a 28 64 ation of code.(d
a100: 65 66 69 6e 65 20 28 67 65 6e 65 72 61 6c 2d 72 efine (general-r
a110: 75 6e 2d 63 61 6c 6c 20 73 77 69 74 63 68 6e 61 un-call switchna
a120: 6d 65 20 61 63 74 69 6f 6e 2d 64 65 73 63 20 70 me action-desc p
a130: 72 6f 63 29 0a 20 20 28 6c 65 74 20 28 28 72 75 roc). (let ((ru
a140: 6e 6e 61 6d 65 20 28 61 72 67 73 3a 67 65 74 2d nname (args:get-
a150: 61 72 67 20 22 3a 72 75 6e 6e 61 6d 65 22 29 29 arg ":runname"))
a160: 0a 09 28 74 61 72 67 65 74 20 20 28 69 66 20 28 ..(target (if (
a170: 61 72 67 73 3a 67 65 74 2d 61 72 67 20 22 2d 74 args:get-arg "-t
a180: 61 72 67 65 74 22 29 0a 09 09 20 20 20 20 20 28 arget")... (
a190: 61 72 67 73 3a 67 65 74 2d 61 72 67 20 22 2d 74 args:get-arg "-t
a1a0: 61 72 67 65 74 22 29 0a 09 09 20 20 20 20 20 28 arget")... (
a1b0: 61 72 67 73 3a 67 65 74 2d 61 72 67 20 22 2d 72 args:get-arg "-r
a1c0: 65 71 74 61 72 67 22 29 29 29 0a 09 28 74 68 31 eqtarg")))..(th1
a1d0: 20 20 20 20 20 23 66 29 29 0a 20 20 20 20 28 63 #f)). (c
a1e0: 6f 6e 64 0a 20 20 20 20 20 28 28 6e 6f 74 20 74 ond. ((not t
a1f0: 61 72 67 65 74 29 0a 20 20 20 20 20 20 28 64 65 arget). (de
a200: 62 75 67 3a 70 72 69 6e 74 20 30 20 22 45 52 52 bug:print 0 "ERR
a210: 4f 52 3a 20 4d 69 73 73 69 6e 67 20 72 65 71 75 OR: Missing requ
a220: 69 72 65 64 20 70 61 72 61 6d 65 74 65 72 20 66 ired parameter f
a230: 6f 72 20 22 20 73 77 69 74 63 68 6e 61 6d 65 20 or " switchname
a240: 22 2c 20 79 6f 75 20 6d 75 73 74 20 73 70 65 63 ", you must spec
a250: 69 66 79 20 74 68 65 20 74 61 72 67 65 74 20 77 ify the target w
a260: 69 74 68 20 2d 74 61 72 67 65 74 22 29 0a 20 20 ith -target").
a270: 20 20 20 20 28 65 78 69 74 20 33 29 29 0a 20 20 (exit 3)).
a280: 20 20 20 28 28 6e 6f 74 20 72 75 6e 6e 61 6d 65 ((not runname
a290: 29 0a 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 ). (debug:p
a2a0: 72 69 6e 74 20 30 20 22 45 52 52 4f 52 3a 20 4d rint 0 "ERROR: M
a2b0: 69 73 73 69 6e 67 20 72 65 71 75 69 72 65 64 20 issing required
a2c0: 70 61 72 61 6d 65 74 65 72 20 66 6f 72 20 22 20 parameter for "
a2d0: 73 77 69 74 63 68 6e 61 6d 65 20 22 2c 20 79 6f switchname ", yo
a2e0: 75 20 6d 75 73 74 20 73 70 65 63 69 66 79 20 74 u must specify t
a2f0: 68 65 20 72 75 6e 20 6e 61 6d 65 20 77 69 74 68 he run name with
a300: 20 3a 72 75 6e 6e 61 6d 65 20 72 75 6e 6e 61 6d :runname runnam
a310: 65 22 29 0a 20 20 20 20 20 20 28 65 78 69 74 20 e"). (exit
a320: 33 29 29 0a 20 20 20 20 20 28 65 6c 73 65 0a 20 3)). (else.
a330: 20 20 20 20 20 28 6c 65 74 20 28 28 64 62 20 20 (let ((db
a340: 20 23 66 29 0a 09 20 20 20 20 28 6b 65 79 73 20 #f).. (keys
a350: 23 66 29 29 0a 09 28 69 66 20 28 6e 6f 74 20 28 #f))..(if (not (
a360: 73 65 74 75 70 2d 66 6f 72 2d 72 75 6e 29 29 0a setup-for-run)).
a370: 09 20 20 20 20 28 62 65 67 69 6e 20 0a 09 20 20 . (begin ..
a380: 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 (debug:print
a390: 20 30 20 22 46 61 69 6c 65 64 20 74 6f 20 73 65 0 "Failed to se
a3a0: 74 75 70 2c 20 65 78 69 74 69 6e 67 22 29 0a 09 tup, exiting")..
a3b0: 20 20 20 20 20 20 28 65 78 69 74 20 31 29 29 29 (exit 1)))
a3c0: 0a 09 28 69 66 20 28 61 72 67 73 3a 67 65 74 2d ..(if (args:get-
a3d0: 61 72 67 20 22 2d 73 65 72 76 65 72 22 29 0a 09 arg "-server")..
a3e0: 20 20 20 20 28 6f 70 65 6e 2d 72 75 6e 2d 63 6c (open-run-cl
a3f0: 6f 73 65 20 73 65 72 76 65 72 3a 73 74 61 72 74 ose server:start
a400: 20 64 62 20 28 61 72 67 73 3a 67 65 74 2d 61 72 db (args:get-ar
a410: 67 20 22 2d 73 65 72 76 65 72 22 29 29 0a 20 09 g "-server")). .
a420: 20 20 20 20 28 69 66 20 28 6e 6f 74 20 28 6f 72 (if (not (or
a430: 20 28 61 72 67 73 3a 67 65 74 2d 61 72 67 20 22 (args:get-arg "
a440: 2d 72 75 6e 61 6c 6c 22 29 20 20 20 20 20 3b 3b -runall") ;;
a450: 20 72 75 6e 61 6c 6c 20 61 6e 64 20 72 75 6e 74 runall and runt
a460: 65 73 74 73 20 61 72 65 20 61 6c 6c 6f 77 65 64 ests are allowed
a470: 20 74 6f 20 62 65 20 73 65 72 76 65 72 73 0a 20 to be servers.
a480: 09 09 09 20 28 61 72 67 73 3a 67 65 74 2d 61 72 ... (args:get-ar
a490: 67 20 22 2d 72 75 6e 74 65 73 74 73 22 29 29 29 g "-runtests")))
a4a0: 0a 09 09 28 73 65 72 76 65 72 3a 63 6c 69 65 6e ...(server:clien
a4b0: 74 2d 73 65 74 75 70 29 29 29 0a 09 28 73 65 74 t-setup)))..(set
a4c0: 21 20 6b 65 79 73 20 28 6f 70 65 6e 2d 72 75 6e ! keys (open-run
a4d0: 2d 63 6c 6f 73 65 20 64 62 3a 67 65 74 2d 6b 65 -close db:get-ke
a4e0: 79 73 20 64 62 29 29 0a 09 3b 3b 20 68 61 76 65 ys db))..;; have
a4f0: 20 65 6e 6f 75 67 68 20 74 6f 20 70 72 6f 63 65 enough to proce
a500: 73 73 20 2d 74 61 72 67 65 74 20 6f 72 20 2d 72 ss -target or -r
a510: 65 71 74 61 72 67 20 68 65 72 65 0a 09 28 69 66 eqtarg here..(if
a520: 20 28 61 72 67 73 3a 67 65 74 2d 61 72 67 20 22 (args:get-arg "
a530: 2d 72 65 71 74 61 72 67 22 29 0a 09 20 20 20 20 -reqtarg")..
a540: 28 6c 65 74 2a 20 28 28 72 75 6e 63 6f 6e 66 69 (let* ((runconfi
a550: 67 66 20 28 63 6f 6e 63 20 20 2a 74 6f 70 70 61 gf (conc *toppa
a560: 74 68 2a 20 22 2f 72 75 6e 63 6f 6e 66 69 67 73 th* "/runconfigs
a570: 2e 63 6f 6e 66 69 67 22 29 29 20 3b 3b 20 44 4f .config")) ;; DO
a580: 20 4e 4f 54 20 45 56 41 4c 55 41 54 45 20 41 4c NOT EVALUATE AL
a590: 4c 20 0a 09 09 20 20 20 28 72 75 6e 63 6f 6e 66 L ... (runconf
a5a0: 69 67 20 20 28 72 65 61 64 2d 63 6f 6e 66 69 67 ig (read-config
a5b0: 20 72 75 6e 63 6f 6e 66 69 67 66 20 23 66 20 23 runconfigf #f #
a5c0: 66 20 65 6e 76 69 72 6f 6e 2d 70 61 74 74 3a 20 f environ-patt:
a5d0: 23 66 29 29 29 20 0a 09 20 20 20 20 20 20 28 69 #f))) .. (i
a5e0: 66 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 f (hash-table-re
a5f0: 66 2f 64 65 66 61 75 6c 74 20 72 75 6e 63 6f 6e f/default runcon
a600: 66 69 67 20 28 61 72 67 73 3a 67 65 74 2d 61 72 fig (args:get-ar
a610: 67 20 22 2d 72 65 71 74 61 72 67 22 29 20 23 66 g "-reqtarg") #f
a620: 29 0a 09 09 20 20 28 6b 65 79 73 3a 74 61 72 67 )... (keys:targ
a630: 65 74 2d 73 65 74 2d 61 72 67 73 20 6b 65 79 73 et-set-args keys
a640: 20 28 61 72 67 73 3a 67 65 74 2d 61 72 67 20 22 (args:get-arg "
a650: 2d 72 65 71 74 61 72 67 22 29 20 61 72 67 73 3a -reqtarg") args:
a660: 61 72 67 2d 68 61 73 68 29 0a 09 09 20 20 28 62 arg-hash)... (b
a670: 65 67 69 6e 0a 09 09 20 20 20 20 28 64 65 62 75 egin... (debu
a680: 67 3a 70 72 69 6e 74 20 30 20 22 45 52 52 4f 52 g:print 0 "ERROR
a690: 3a 20 5b 22 20 28 61 72 67 73 3a 67 65 74 2d 61 : [" (args:get-a
a6a0: 72 67 20 22 2d 72 65 71 74 61 72 67 22 29 20 22 rg "-reqtarg") "
a6b0: 5d 20 6e 6f 74 20 66 6f 75 6e 64 20 69 6e 20 22 ] not found in "
a6c0: 20 72 75 6e 63 6f 6e 66 69 67 66 29 0a 09 09 20 runconfigf)...
a6d0: 20 20 20 28 69 66 20 64 62 20 28 73 71 6c 69 74 (if db (sqlit
a6e0: 65 33 3a 66 69 6e 61 6c 69 7a 65 21 20 64 62 29 e3:finalize! db)
a6f0: 29 0a 09 09 20 20 20 20 28 65 78 69 74 20 31 29 )... (exit 1)
a700: 29 29 29 0a 09 20 20 20 20 28 69 66 20 28 61 72 ))).. (if (ar
a710: 67 73 3a 67 65 74 2d 61 72 67 20 22 2d 74 61 72 gs:get-arg "-tar
a720: 67 65 74 22 29 0a 09 09 28 6b 65 79 73 3a 74 61 get")...(keys:ta
a730: 72 67 65 74 2d 73 65 74 2d 61 72 67 73 20 6b 65 rget-set-args ke
a740: 79 73 20 28 61 72 67 73 3a 67 65 74 2d 61 72 67 ys (args:get-arg
a750: 20 22 2d 74 61 72 67 65 74 22 20 61 72 67 73 3a "-target" args:
a760: 61 72 67 2d 68 61 73 68 29 20 61 72 67 73 3a 61 arg-hash) args:a
a770: 72 67 2d 68 61 73 68 29 29 29 0a 09 28 69 66 20 rg-hash)))..(if
a780: 28 6e 6f 74 20 28 63 61 72 20 2a 63 6f 6e 66 69 (not (car *confi
a790: 67 69 6e 66 6f 2a 29 29 0a 09 20 20 20 20 28 62 ginfo*)).. (b
a7a0: 65 67 69 6e 0a 09 20 20 20 20 20 20 28 64 65 62 egin.. (deb
a7b0: 75 67 3a 70 72 69 6e 74 20 30 20 22 45 52 52 4f ug:print 0 "ERRO
a7c0: 52 3a 20 41 74 74 65 6d 70 74 65 64 20 74 6f 20 R: Attempted to
a7d0: 22 20 61 63 74 69 6f 6e 2d 64 65 73 63 20 22 20 " action-desc "
a7e0: 62 75 74 20 72 75 6e 20 61 72 65 61 20 63 6f 6e but run area con
a7f0: 66 69 67 20 66 69 6c 65 20 6e 6f 74 20 66 6f 75 fig file not fou
a800: 6e 64 22 29 0a 09 20 20 20 20 20 20 28 65 78 69 nd").. (exi
a810: 74 20 31 29 29 0a 09 20 20 20 20 3b 3b 20 45 78 t 1)).. ;; Ex
a820: 74 72 61 63 74 20 6f 75 74 20 73 74 75 66 66 20 tract out stuff
a830: 6e 65 65 64 65 64 20 69 6e 20 6d 6f 73 74 20 6f needed in most o
a840: 72 20 6d 61 6e 79 20 63 61 6c 6c 73 0a 09 20 20 r many calls..
a850: 20 20 3b 3b 20 68 65 72 65 20 74 68 65 6e 20 63 ;; here then c
a860: 61 6c 6c 20 70 72 6f 63 0a 09 20 20 20 20 28 6c all proc.. (l
a870: 65 74 2a 20 28 28 6b 65 79 6e 61 6d 65 73 20 20 et* ((keynames
a880: 20 28 6d 61 70 20 6b 65 79 3a 67 65 74 2d 66 69 (map key:get-fi
a890: 65 6c 64 6e 61 6d 65 20 6b 65 79 73 29 29 0a 09 eldname keys))..
a8a0: 09 20 20 20 28 6b 65 79 76 61 6c 6c 73 74 20 20 . (keyvallst
a8b0: 28 6b 65 79 73 2d 3e 76 61 6c 6c 69 73 74 20 6b (keys->vallist k
a8c0: 65 79 73 20 23 74 29 29 29 0a 09 20 20 20 20 20 eys #t)))..
a8d0: 20 28 70 72 6f 63 20 74 61 72 67 65 74 20 72 75 (proc target ru
a8e0: 6e 6e 61 6d 65 20 6b 65 79 73 20 6b 65 79 6e 61 nname keys keyna
a8f0: 6d 65 73 20 6b 65 79 76 61 6c 6c 73 74 29 29 29 mes keyvallst)))
a900: 0a 09 28 69 66 20 74 68 31 20 28 74 68 72 65 61 ..(if th1 (threa
a910: 64 2d 6a 6f 69 6e 21 20 74 68 31 29 29 0a 09 28 d-join! th1))..(
a920: 69 66 20 64 62 20 28 73 71 6c 69 74 65 33 3a 66 if db (sqlite3:f
a930: 69 6e 61 6c 69 7a 65 21 20 64 62 29 29 0a 09 28 inalize! db))..(
a940: 73 65 74 21 20 2a 64 69 64 73 6f 6d 65 74 68 69 set! *didsomethi
a950: 6e 67 2a 20 23 74 29 29 29 29 29 29 0a 0a 3b 3b ng* #t))))))..;;
a960: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
a970: 3d 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 0a 3b 3b 20 4c 6f 63 6b 2f 75 ======.;; Lock/u
a9b0: 6e 6c 6f 63 6b 20 72 75 6e 73 0a 3b 3b 3d 3d 3d nlock runs.;;===
a9c0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
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 0a 0a 28 64 65 66 69 6e 65 20 28 72 75 ===..(define (ru
aa10: 6e 73 3a 68 61 6e 64 6c 65 2d 6c 6f 63 6b 69 6e ns:handle-lockin
aa20: 67 20 74 61 72 67 65 74 20 6b 65 79 73 20 72 75 g target keys ru
aa30: 6e 6e 61 6d 65 20 6c 6f 63 6b 20 75 6e 6c 6f 63 nname lock unloc
aa40: 6b 20 75 73 65 72 29 0a 20 20 28 6c 65 74 2a 20 k user). (let*
aa50: 28 28 64 62 20 20 20 20 20 20 20 23 66 29 0a 09 ((db #f)..
aa60: 20 28 72 75 6e 64 61 74 20 20 20 28 6f 70 65 6e (rundat (open
aa70: 2d 72 75 6e 2d 63 6c 6f 73 65 20 72 75 6e 73 3a -run-close runs:
aa80: 67 65 74 2d 72 75 6e 73 2d 62 79 2d 70 61 74 74 get-runs-by-patt
aa90: 20 64 62 20 6b 65 79 73 20 72 75 6e 6e 61 6d 65 db keys runname
aaa0: 29 29 0a 09 20 28 68 65 61 64 65 72 20 20 20 28 )).. (header (
aab0: 76 65 63 74 6f 72 2d 72 65 66 20 72 75 6e 64 61 vector-ref runda
aac0: 74 20 30 29 29 0a 09 20 28 72 75 6e 73 20 20 20 t 0)).. (runs
aad0: 20 20 28 76 65 63 74 6f 72 2d 72 65 66 20 72 75 (vector-ref ru
aae0: 6e 64 61 74 20 31 29 29 29 0a 20 20 20 20 28 66 ndat 1))). (f
aaf0: 6f 72 2d 65 61 63 68 20 28 6c 61 6d 62 64 61 20 or-each (lambda
ab00: 28 72 75 6e 29 0a 09 09 28 6c 65 74 20 28 28 72 (run)...(let ((r
ab10: 75 6e 2d 69 64 20 28 64 62 3a 67 65 74 2d 76 61 un-id (db:get-va
ab20: 6c 75 65 2d 62 79 2d 68 65 61 64 65 72 20 72 75 lue-by-header ru
ab30: 6e 20 68 65 61 64 65 72 20 22 69 64 22 29 29 29 n header "id")))
ab40: 0a 09 09 20 20 28 69 66 20 28 6f 72 20 6c 6f 63 ... (if (or loc
ab50: 6b 0a 09 09 09 20 20 28 61 6e 64 20 75 6e 6c 6f k.... (and unlo
ab60: 63 6b 0a 09 09 09 20 20 20 20 20 20 20 28 62 65 ck.... (be
ab70: 67 69 6e 0a 09 09 09 09 20 28 70 72 69 6e 74 20 gin..... (print
ab80: 22 44 6f 20 79 6f 75 20 72 65 61 6c 6c 79 20 77 "Do you really w
ab90: 69 73 68 20 74 6f 20 75 6e 6c 6f 63 6b 20 72 75 ish to unlock ru
aba0: 6e 20 22 20 72 75 6e 2d 69 64 20 22 3f 5c 6e 20 n " run-id "?\n
abb0: 20 20 79 2f 6e 3a 20 22 29 0a 09 09 09 09 20 28 y/n: ")..... (
abc0: 65 71 75 61 6c 3f 20 22 79 22 20 28 72 65 61 64 equal? "y" (read
abd0: 2d 6c 69 6e 65 29 29 29 29 29 0a 09 09 20 20 20 -line)))))...
abe0: 20 20 20 28 6f 70 65 6e 2d 72 75 6e 2d 63 6c 6f (open-run-clo
abf0: 73 65 20 64 62 3a 6c 6f 63 6b 2f 75 6e 6c 6f 63 se db:lock/unloc
ac00: 6b 2d 72 75 6e 20 64 62 20 72 75 6e 2d 69 64 20 k-run db run-id
ac10: 6c 6f 63 6b 20 75 6e 6c 6f 63 6b 20 75 73 65 72 lock unlock user
ac20: 29 0a 09 09 20 20 20 20 20 20 28 64 65 62 75 67 )... (debug
ac30: 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 30 20 22 53 :print-info 0 "S
ac40: 6b 69 70 70 69 6e 67 20 6c 6f 63 6b 2f 75 6e 6c kipping lock/unl
ac50: 6f 63 6b 20 6f 6e 20 22 20 72 75 6e 2d 69 64 29 ock on " run-id)
ac60: 29 29 29 0a 09 20 20 20 20 20 20 72 75 6e 73 29 ))).. runs)
ac70: 29 29 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d )).;;===========
ac80: 3d 3d 3d 3d 3d 3d 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 0a 3b 3b 20 52 ===========.;; R
acc0: 6f 6c 6c 75 70 20 72 75 6e 73 0a 3b 3b 3d 3d 3d ollup runs.;;===
acd0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
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 0a 0a 3b 3b 20 55 70 64 61 74 65 20 74 ===..;; Update t
ad20: 68 65 20 74 65 73 74 5f 6d 65 74 61 20 74 61 62 he test_meta tab
ad30: 6c 65 20 66 6f 72 20 74 68 69 73 20 74 65 73 74 le for this test
ad40: 0a 28 64 65 66 69 6e 65 20 28 72 75 6e 73 3a 75 .(define (runs:u
ad50: 70 64 61 74 65 2d 74 65 73 74 5f 6d 65 74 61 20 pdate-test_meta
ad60: 64 62 20 74 65 73 74 2d 6e 61 6d 65 20 74 65 73 db test-name tes
ad70: 74 2d 63 6f 6e 66 29 0a 20 20 28 6c 65 74 20 28 t-conf). (let (
ad80: 28 63 75 72 72 72 65 63 6f 72 64 20 28 6f 70 65 (currrecord (ope
ad90: 6e 2d 72 75 6e 2d 63 6c 6f 73 65 20 64 62 3a 74 n-run-close db:t
ada0: 65 73 74 6d 65 74 61 2d 67 65 74 2d 72 65 63 6f estmeta-get-reco
adb0: 72 64 20 64 62 20 74 65 73 74 2d 6e 61 6d 65 29 rd db test-name)
adc0: 29 29 0a 20 20 20 20 28 69 66 20 28 6e 6f 74 20 )). (if (not
add0: 63 75 72 72 72 65 63 6f 72 64 29 0a 09 28 62 65 currrecord)..(be
ade0: 67 69 6e 0a 09 20 20 28 73 65 74 21 20 63 75 72 gin.. (set! cur
adf0: 72 72 65 63 6f 72 64 20 28 6d 61 6b 65 2d 76 65 rrecord (make-ve
ae00: 63 74 6f 72 20 31 30 20 23 66 29 29 0a 09 20 20 ctor 10 #f))..
ae10: 28 6f 70 65 6e 2d 72 75 6e 2d 63 6c 6f 73 65 20 (open-run-close
ae20: 64 62 3a 74 65 73 74 6d 65 74 61 2d 61 64 64 2d db:testmeta-add-
ae30: 72 65 63 6f 72 64 20 64 62 20 74 65 73 74 2d 6e record db test-n
ae40: 61 6d 65 29 29 29 0a 20 20 20 20 28 66 6f 72 2d ame))). (for-
ae50: 65 61 63 68 20 0a 20 20 20 20 20 28 6c 61 6d 62 each . (lamb
ae60: 64 61 20 28 6b 65 79 29 0a 20 20 20 20 20 20 20 da (key).
ae70: 28 6c 65 74 2a 20 28 28 69 64 78 20 28 63 61 64 (let* ((idx (cad
ae80: 72 20 6b 65 79 29 29 0a 09 20 20 20 20 20 20 28 r key)).. (
ae90: 66 6c 64 20 28 63 61 72 20 20 6b 65 79 29 29 0a fld (car key)).
aea0: 09 20 20 20 20 20 20 28 76 61 6c 20 28 63 6f 6e . (val (con
aeb0: 66 69 67 2d 6c 6f 6f 6b 75 70 20 74 65 73 74 2d fig-lookup test-
aec0: 63 6f 6e 66 20 22 74 65 73 74 5f 6d 65 74 61 22 conf "test_meta"
aed0: 20 66 6c 64 29 29 29 0a 09 20 3b 3b 20 28 64 65 fld))).. ;; (de
aee0: 62 75 67 3a 70 72 69 6e 74 20 35 20 22 69 64 78 bug:print 5 "idx
aef0: 3a 20 22 20 69 64 78 20 22 20 66 6c 64 3a 20 22 : " idx " fld: "
af00: 20 66 6c 64 20 22 20 76 61 6c 3a 20 22 20 76 61 fld " val: " va
af10: 6c 29 0a 09 20 28 69 66 20 28 61 6e 64 20 76 61 l).. (if (and va
af20: 6c 20 28 6e 6f 74 20 28 65 71 75 61 6c 3f 20 28 l (not (equal? (
af30: 76 65 63 74 6f 72 2d 72 65 66 20 63 75 72 72 72 vector-ref currr
af40: 65 63 6f 72 64 20 69 64 78 29 20 76 61 6c 29 29 ecord idx) val))
af50: 29 0a 09 20 20 20 20 20 28 62 65 67 69 6e 0a 09 ).. (begin..
af60: 20 20 20 20 20 20 20 28 70 72 69 6e 74 20 22 55 (print "U
af70: 70 64 61 74 69 6e 67 20 22 20 74 65 73 74 2d 6e pdating " test-n
af80: 61 6d 65 20 22 20 22 20 66 6c 64 20 22 20 74 6f ame " " fld " to
af90: 20 22 20 76 61 6c 29 0a 09 20 20 20 20 20 20 20 " val)..
afa0: 28 6f 70 65 6e 2d 72 75 6e 2d 63 6c 6f 73 65 20 (open-run-close
afb0: 64 62 3a 74 65 73 74 6d 65 74 61 2d 75 70 64 61 db:testmeta-upda
afc0: 74 65 2d 66 69 65 6c 64 20 64 62 20 74 65 73 74 te-field db test
afd0: 2d 6e 61 6d 65 20 66 6c 64 20 76 61 6c 29 29 29 -name fld val)))
afe0: 29 29 0a 20 20 20 20 20 27 28 28 22 61 75 74 68 )). '(("auth
aff0: 6f 72 22 20 32 29 28 22 6f 77 6e 65 72 22 20 33 or" 2)("owner" 3
b000: 29 28 22 64 65 73 63 72 69 70 74 69 6f 6e 22 20 )("description"
b010: 34 29 28 22 72 65 76 69 65 77 65 64 22 20 35 29 4)("reviewed" 5)
b020: 28 22 74 61 67 73 22 20 39 29 29 29 29 29 0a 0a ("tags" 9)))))..
b030: 3b 3b 20 55 70 64 61 74 65 20 74 65 73 74 5f 6d ;; Update test_m
b040: 65 74 61 20 66 6f 72 20 61 6c 6c 20 74 65 73 74 eta for all test
b050: 73 0a 28 64 65 66 69 6e 65 20 28 72 75 6e 73 3a s.(define (runs:
b060: 75 70 64 61 74 65 2d 61 6c 6c 2d 74 65 73 74 5f update-all-test_
b070: 6d 65 74 61 20 64 62 29 0a 20 20 28 6c 65 74 20 meta db). (let
b080: 28 28 74 65 73 74 2d 6e 61 6d 65 73 20 28 67 65 ((test-names (ge
b090: 74 2d 61 6c 6c 2d 6c 65 67 61 6c 2d 74 65 73 74 t-all-legal-test
b0a0: 73 29 29 29 0a 20 20 20 20 28 66 6f 72 2d 65 61 s))). (for-ea
b0b0: 63 68 20 0a 20 20 20 20 20 28 6c 61 6d 62 64 61 ch . (lambda
b0c0: 20 28 74 65 73 74 2d 6e 61 6d 65 29 0a 20 20 20 (test-name).
b0d0: 20 20 20 20 28 6c 65 74 2a 20 28 28 74 65 73 74 (let* ((test
b0e0: 2d 70 61 74 68 20 20 20 20 28 63 6f 6e 63 20 2a -path (conc *
b0f0: 74 6f 70 70 61 74 68 2a 20 22 2f 74 65 73 74 73 toppath* "/tests
b100: 2f 22 20 74 65 73 74 2d 6e 61 6d 65 29 29 0a 09 /" test-name))..
b110: 20 20 20 20 20 20 28 74 65 73 74 2d 63 6f 6e 66 (test-conf
b120: 69 67 66 20 28 63 6f 6e 63 20 74 65 73 74 2d 70 igf (conc test-p
b130: 61 74 68 20 22 2f 74 65 73 74 63 6f 6e 66 69 67 ath "/testconfig
b140: 22 29 29 0a 09 20 20 20 20 20 20 28 74 65 73 74 ")).. (test
b150: 65 78 69 73 74 73 20 20 20 28 61 6e 64 20 28 66 exists (and (f
b160: 69 6c 65 2d 65 78 69 73 74 73 3f 20 74 65 73 74 ile-exists? test
b170: 2d 63 6f 6e 66 69 67 66 29 28 66 69 6c 65 2d 72 -configf)(file-r
b180: 65 61 64 2d 61 63 63 65 73 73 3f 20 74 65 73 74 ead-access? test
b190: 2d 63 6f 6e 66 69 67 66 29 29 29 0a 09 20 20 20 -configf)))..
b1a0: 20 20 20 3b 3b 20 72 65 61 64 20 63 6f 6e 66 69 ;; read confi
b1b0: 67 73 20 77 69 74 68 20 74 72 69 63 6b 73 20 74 gs with tricks t
b1c0: 75 72 6e 65 64 20 6f 66 66 20 28 69 2e 65 2e 20 urned off (i.e.
b1d0: 6e 6f 20 73 79 73 74 65 6d 29 0a 09 20 20 20 20 no system)..
b1e0: 20 20 28 74 65 73 74 2d 63 6f 6e 66 20 20 20 20 (test-conf
b1f0: 28 69 66 20 74 65 73 74 65 78 69 73 74 73 20 28 (if testexists (
b200: 72 65 61 64 2d 63 6f 6e 66 69 67 20 74 65 73 74 read-config test
b210: 2d 63 6f 6e 66 69 67 66 20 23 66 20 23 66 29 28 -configf #f #f)(
b220: 6d 61 6b 65 2d 68 61 73 68 2d 74 61 62 6c 65 29 make-hash-table)
b230: 29 29 29 0a 09 20 3b 3b 20 75 73 65 20 74 68 65 ))).. ;; use the
b240: 20 6f 70 65 6e 2d 72 75 6e 2d 63 6c 6f 73 65 20 open-run-close
b250: 69 6e 73 74 65 61 64 20 6f 66 20 70 61 73 73 69 instead of passi
b260: 6e 67 20 69 6e 20 64 62 0a 09 20 28 72 75 6e 73 ng in db.. (runs
b270: 3a 75 70 64 61 74 65 2d 74 65 73 74 5f 6d 65 74 :update-test_met
b280: 61 20 23 66 20 74 65 73 74 2d 6e 61 6d 65 20 74 a #f test-name t
b290: 65 73 74 2d 63 6f 6e 66 29 29 29 0a 20 20 20 20 est-conf))).
b2a0: 20 74 65 73 74 2d 6e 61 6d 65 73 29 29 29 0a 0a test-names)))..
b2b0: 3b 3b 20 54 68 69 73 20 63 6f 75 6c 64 20 70 72 ;; This could pr
b2c0: 6f 62 61 62 6c 79 20 62 65 20 72 65 66 61 63 74 obably be refact
b2d0: 6f 72 65 64 20 69 6e 74 6f 20 6f 6e 65 20 63 6f ored into one co
b2e0: 6d 70 6c 65 78 20 71 75 65 72 79 20 2e 2e 2e 0a mplex query ....
b2f0: 28 64 65 66 69 6e 65 20 28 72 75 6e 73 3a 72 6f (define (runs:ro
b300: 6c 6c 75 70 2d 72 75 6e 20 6b 65 79 73 20 6b 65 llup-run keys ke
b310: 79 76 61 6c 6c 73 74 20 72 75 6e 6e 61 6d 65 20 yvallst runname
b320: 75 73 65 72 29 20 3b 3b 20 77 61 73 20 74 61 72 user) ;; was tar
b330: 67 65 74 2c 20 6e 6f 77 20 6b 65 79 76 61 6c 6c get, now keyvall
b340: 73 74 0a 20 20 28 64 65 62 75 67 3a 70 72 69 6e st. (debug:prin
b350: 74 20 34 20 22 72 75 6e 73 3a 72 6f 6c 6c 75 70 t 4 "runs:rollup
b360: 2d 72 75 6e 2c 20 6b 65 79 73 3a 20 22 20 6b 65 -run, keys: " ke
b370: 79 73 20 22 20 6b 65 79 76 61 6c 6c 73 74 3a 20 ys " keyvallst:
b380: 22 20 6b 65 79 76 61 6c 6c 73 74 20 22 20 3a 72 " keyvallst " :r
b390: 75 6e 6e 61 6d 65 20 22 20 72 75 6e 6e 61 6d 65 unname " runname
b3a0: 20 22 20 75 73 65 72 3a 20 22 20 75 73 65 72 29 " user: " user)
b3b0: 0a 20 20 28 6c 65 74 2a 20 28 28 64 62 20 20 20 . (let* ((db
b3c0: 20 20 20 20 20 20 20 20 20 20 20 23 66 29 20 3b #f) ;
b3d0: 3b 20 28 6b 65 79 76 61 6c 6c 6c 73 74 20 20 20 ; (keyvalllst
b3e0: 20 20 20 28 6b 65 79 73 3a 74 61 72 67 65 74 2d (keys:target-
b3f0: 3e 6b 65 79 76 61 6c 20 6b 65 79 73 20 74 61 72 >keyval keys tar
b400: 67 65 74 29 29 0a 09 20 28 6e 65 77 2d 72 75 6e get)).. (new-run
b410: 2d 69 64 20 20 20 20 20 20 28 6f 70 65 6e 2d 72 -id (open-r
b420: 75 6e 2d 63 6c 6f 73 65 20 72 75 6e 73 3a 72 65 un-close runs:re
b430: 67 69 73 74 65 72 2d 72 75 6e 20 64 62 20 6b 65 gister-run db ke
b440: 79 73 20 6b 65 79 76 61 6c 6c 73 74 20 72 75 6e ys keyvallst run
b450: 6e 61 6d 65 20 22 6e 65 77 22 20 22 6e 2f 61 22 name "new" "n/a"
b460: 20 75 73 65 72 29 29 0a 09 20 28 70 72 65 76 2d user)).. (prev-
b470: 74 65 73 74 73 20 20 20 20 20 20 28 6f 70 65 6e tests (open
b480: 2d 72 75 6e 2d 63 6c 6f 73 65 20 74 65 73 74 3a -run-close test:
b490: 67 65 74 2d 6d 61 74 63 68 69 6e 67 2d 70 72 65 get-matching-pre
b4a0: 76 69 6f 75 73 2d 74 65 73 74 2d 72 75 6e 2d 72 vious-test-run-r
b4b0: 65 63 6f 72 64 73 20 64 62 20 6e 65 77 2d 72 75 ecords db new-ru
b4c0: 6e 2d 69 64 20 22 25 22 20 22 25 22 29 29 0a 09 n-id "%" "%"))..
b4d0: 20 28 63 75 72 72 2d 74 65 73 74 73 20 20 20 20 (curr-tests
b4e0: 20 20 28 6f 70 65 6e 2d 72 75 6e 2d 63 6c 6f 73 (open-run-clos
b4f0: 65 20 64 62 3a 67 65 74 2d 74 65 73 74 73 2d 66 e db:get-tests-f
b500: 6f 72 2d 72 75 6e 20 64 62 20 6e 65 77 2d 72 75 or-run db new-ru
b510: 6e 2d 69 64 20 22 25 2f 25 22 20 27 28 29 20 27 n-id "%/%" '() '
b520: 28 29 29 29 0a 09 20 28 63 75 72 72 2d 74 65 73 ())).. (curr-tes
b530: 74 73 2d 68 61 73 68 20 28 6d 61 6b 65 2d 68 61 ts-hash (make-ha
b540: 73 68 2d 74 61 62 6c 65 29 29 29 0a 20 20 20 20 sh-table))).
b550: 28 6f 70 65 6e 2d 72 75 6e 2d 63 6c 6f 73 65 20 (open-run-close
b560: 64 62 3a 75 70 64 61 74 65 2d 72 75 6e 2d 65 76 db:update-run-ev
b570: 65 6e 74 5f 74 69 6d 65 20 64 62 20 6e 65 77 2d ent_time db new-
b580: 72 75 6e 2d 69 64 29 0a 20 20 20 20 3b 3b 20 69 run-id). ;; i
b590: 6e 64 65 78 20 74 68 65 20 61 6c 72 65 61 64 79 ndex the already
b5a0: 20 73 61 76 65 64 20 74 65 73 74 73 20 62 79 20 saved tests by
b5b0: 74 65 73 74 6e 61 6d 65 20 61 6e 64 20 69 74 65 testname and ite
b5c0: 6d 64 61 74 20 69 6e 20 63 75 72 72 2d 74 65 73 mdat in curr-tes
b5d0: 74 73 2d 68 61 73 68 0a 20 20 20 20 28 66 6f 72 ts-hash. (for
b5e0: 2d 65 61 63 68 0a 20 20 20 20 20 28 6c 61 6d 62 -each. (lamb
b5f0: 64 61 20 28 74 65 73 74 64 61 74 29 0a 20 20 20 da (testdat).
b600: 20 20 20 20 28 6c 65 74 2a 20 28 28 74 65 73 74 (let* ((test
b610: 6e 61 6d 65 20 20 28 64 62 3a 74 65 73 74 2d 67 name (db:test-g
b620: 65 74 2d 74 65 73 74 6e 61 6d 65 20 74 65 73 74 et-testname test
b630: 64 61 74 29 29 0a 09 20 20 20 20 20 20 28 69 74 dat)).. (it
b640: 65 6d 2d 70 61 74 68 20 28 64 62 3a 74 65 73 74 em-path (db:test
b650: 2d 67 65 74 2d 69 74 65 6d 2d 70 61 74 68 20 74 -get-item-path t
b660: 65 73 74 64 61 74 29 29 0a 09 20 20 20 20 20 20 estdat))..
b670: 28 66 75 6c 6c 2d 6e 61 6d 65 20 28 63 6f 6e 63 (full-name (conc
b680: 20 74 65 73 74 6e 61 6d 65 20 22 2f 22 20 69 74 testname "/" it
b690: 65 6d 2d 70 61 74 68 29 29 29 0a 09 20 28 68 61 em-path))).. (ha
b6a0: 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 63 75 sh-table-set! cu
b6b0: 72 72 2d 74 65 73 74 73 2d 68 61 73 68 20 66 75 rr-tests-hash fu
b6c0: 6c 6c 2d 6e 61 6d 65 20 74 65 73 74 64 61 74 29 ll-name testdat)
b6d0: 29 29 0a 20 20 20 20 20 63 75 72 72 2d 74 65 73 )). curr-tes
b6e0: 74 73 29 0a 20 20 20 20 3b 3b 20 4e 4f 50 45 3a ts). ;; NOPE:
b6f0: 20 4e 6f 6e 2d 6f 70 74 69 6d 61 6c 20 61 70 70 Non-optimal app
b700: 72 6f 61 63 68 2e 20 54 72 79 20 74 68 69 73 20 roach. Try this
b710: 69 6e 73 74 65 61 64 2e 0a 20 20 20 20 3b 3b 20 instead.. ;;
b720: 20 20 31 2e 20 74 65 73 74 73 20 61 72 65 20 72 1. tests are r
b730: 65 63 65 69 76 65 64 20 69 6e 20 61 20 6c 69 73 eceived in a lis
b740: 74 2c 20 6d 6f 73 74 20 72 65 63 65 6e 74 20 66 t, most recent f
b750: 69 72 73 74 0a 20 20 20 20 3b 3b 20 20 20 32 2e irst. ;; 2.
b760: 20 72 65 70 6c 61 63 65 20 74 68 65 20 72 6f 6c replace the rol
b770: 6c 75 70 20 74 65 73 74 20 77 69 74 68 20 74 68 lup test with th
b780: 65 20 6e 65 77 20 2a 61 6c 77 61 79 73 2a 0a 20 e new *always*.
b790: 20 20 20 28 66 6f 72 2d 65 61 63 68 20 0a 20 20 (for-each .
b7a0: 20 20 20 28 6c 61 6d 62 64 61 20 28 74 65 73 74 (lambda (test
b7b0: 64 61 74 29 0a 20 20 20 20 20 20 20 28 6c 65 74 dat). (let
b7c0: 2a 20 28 28 74 65 73 74 6e 61 6d 65 20 20 28 64 * ((testname (d
b7d0: 62 3a 74 65 73 74 2d 67 65 74 2d 74 65 73 74 6e b:test-get-testn
b7e0: 61 6d 65 20 74 65 73 74 64 61 74 29 29 0a 09 20 ame testdat))..
b7f0: 20 20 20 20 20 28 69 74 65 6d 2d 70 61 74 68 20 (item-path
b800: 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 69 74 65 (db:test-get-ite
b810: 6d 2d 70 61 74 68 20 74 65 73 74 64 61 74 29 29 m-path testdat))
b820: 0a 09 20 20 20 20 20 20 28 66 75 6c 6c 2d 6e 61 .. (full-na
b830: 6d 65 20 28 63 6f 6e 63 20 74 65 73 74 6e 61 6d me (conc testnam
b840: 65 20 22 2f 22 20 69 74 65 6d 2d 70 61 74 68 29 e "/" item-path)
b850: 29 0a 09 20 20 20 20 20 20 28 70 72 65 76 2d 74 ).. (prev-t
b860: 65 73 74 2d 64 61 74 20 28 68 61 73 68 2d 74 61 est-dat (hash-ta
b870: 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 ble-ref/default
b880: 63 75 72 72 2d 74 65 73 74 73 2d 68 61 73 68 20 curr-tests-hash
b890: 66 75 6c 6c 2d 6e 61 6d 65 20 23 66 29 29 0a 09 full-name #f))..
b8a0: 20 20 20 20 20 20 28 74 65 73 74 2d 73 74 65 70 (test-step
b8b0: 73 20 20 20 20 20 20 28 6f 70 65 6e 2d 72 75 6e s (open-run
b8c0: 2d 63 6c 6f 73 65 20 64 62 3a 67 65 74 2d 73 74 -close db:get-st
b8d0: 65 70 73 2d 66 6f 72 2d 74 65 73 74 20 64 62 20 eps-for-test db
b8e0: 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 69 64 20 (db:test-get-id
b8f0: 74 65 73 74 64 61 74 29 29 29 0a 09 20 20 20 20 testdat)))..
b900: 20 20 28 6e 65 77 2d 74 65 73 74 2d 72 65 63 6f (new-test-reco
b910: 72 64 20 23 66 29 29 0a 09 20 3b 3b 20 72 65 70 rd #f)).. ;; rep
b920: 6c 61 63 65 20 74 68 65 73 65 20 77 69 74 68 20 lace these with
b930: 69 6e 73 65 72 74 20 2e 2e 2e 20 73 65 6c 65 63 insert ... selec
b940: 74 0a 09 20 28 61 70 70 6c 79 20 73 71 6c 69 74 t.. (apply sqlit
b950: 65 33 3a 65 78 65 63 75 74 65 20 0a 09 09 64 62 e3:execute ...db
b960: 20 0a 09 09 28 63 6f 6e 63 20 22 49 4e 53 45 52 ...(conc "INSER
b970: 54 20 4f 52 20 52 45 50 4c 41 43 45 20 49 4e 54 T OR REPLACE INT
b980: 4f 20 74 65 73 74 73 20 28 72 75 6e 5f 69 64 2c O tests (run_id,
b990: 74 65 73 74 6e 61 6d 65 2c 73 74 61 74 65 2c 73 testname,state,s
b9a0: 74 61 74 75 73 2c 65 76 65 6e 74 5f 74 69 6d 65 tatus,event_time
b9b0: 2c 68 6f 73 74 2c 63 70 75 6c 6f 61 64 2c 64 69 ,host,cpuload,di
b9c0: 73 6b 66 72 65 65 2c 75 6e 61 6d 65 2c 72 75 6e skfree,uname,run
b9d0: 64 69 72 2c 69 74 65 6d 5f 70 61 74 68 2c 72 75 dir,item_path,ru
b9e0: 6e 5f 64 75 72 61 74 69 6f 6e 2c 66 69 6e 61 6c n_duration,final
b9f0: 5f 6c 6f 67 66 2c 63 6f 6d 6d 65 6e 74 29 20 22 _logf,comment) "
ba00: 0a 09 09 20 20 20 20 20 20 22 56 41 4c 55 45 53 ... "VALUES
ba10: 20 28 3f 2c 3f 2c 3f 2c 3f 2c 3f 2c 3f 2c 3f 2c (?,?,?,?,?,?,?,
ba20: 3f 2c 3f 2c 3f 2c 3f 2c 3f 2c 3f 2c 3f 29 3b 22 ?,?,?,?,?,?,?);"
ba30: 29 0a 09 09 6e 65 77 2d 72 75 6e 2d 69 64 20 28 )...new-run-id (
ba40: 63 64 64 72 20 28 76 65 63 74 6f 72 2d 3e 6c 69 cddr (vector->li
ba50: 73 74 20 74 65 73 74 64 61 74 29 29 29 0a 09 20 st testdat)))..
ba60: 28 73 65 74 21 20 6e 65 77 2d 74 65 73 74 64 61 (set! new-testda
ba70: 74 20 28 63 61 72 20 28 6f 70 65 6e 2d 72 75 6e t (car (open-run
ba80: 2d 63 6c 6f 73 65 20 64 62 3a 67 65 74 2d 74 65 -close db:get-te
ba90: 73 74 73 2d 66 6f 72 2d 72 75 6e 20 64 62 20 6e sts-for-run db n
baa0: 65 77 2d 72 75 6e 2d 69 64 20 28 63 6f 6e 63 20 ew-run-id (conc
bab0: 74 65 73 74 6e 61 6d 65 20 22 2f 22 20 69 74 65 testname "/" ite
bac0: 6d 2d 70 61 74 68 29 20 27 28 29 20 27 28 29 29 m-path) '() '())
bad0: 29 29 0a 09 20 28 68 61 73 68 2d 74 61 62 6c 65 )).. (hash-table
bae0: 2d 73 65 74 21 20 63 75 72 72 2d 74 65 73 74 73 -set! curr-tests
baf0: 2d 68 61 73 68 20 66 75 6c 6c 2d 6e 61 6d 65 20 -hash full-name
bb00: 6e 65 77 2d 74 65 73 74 64 61 74 29 20 3b 3b 20 new-testdat) ;;
bb10: 74 68 69 73 20 63 6f 75 6c 64 20 62 65 20 63 6f this could be co
bb20: 6e 66 75 73 69 6e 67 2c 20 77 68 69 63 68 20 72 nfusing, which r
bb30: 65 63 6f 72 64 20 73 68 6f 75 6c 64 20 67 6f 20 ecord should go
bb40: 69 6e 74 6f 20 74 68 65 20 6c 6f 6f 6b 75 70 20 into the lookup
bb50: 74 61 62 6c 65 3f 0a 09 20 3b 3b 20 4e 6f 77 20 table?.. ;; Now
bb60: 64 75 70 6c 69 63 61 74 65 20 74 68 65 20 74 65 duplicate the te
bb70: 73 74 20 73 74 65 70 73 0a 09 20 28 64 65 62 75 st steps.. (debu
bb80: 67 3a 70 72 69 6e 74 20 34 20 22 43 6f 70 79 69 g:print 4 "Copyi
bb90: 6e 67 20 72 65 63 6f 72 64 73 20 69 6e 20 74 65 ng records in te
bba0: 73 74 5f 73 74 65 70 73 20 66 72 6f 6d 20 74 65 st_steps from te
bbb0: 73 74 5f 69 64 3d 22 20 28 64 62 3a 74 65 73 74 st_id=" (db:test
bbc0: 2d 67 65 74 2d 69 64 20 74 65 73 74 64 61 74 29 -get-id testdat)
bbd0: 20 22 20 74 6f 20 22 20 28 64 62 3a 74 65 73 74 " to " (db:test
bbe0: 2d 67 65 74 2d 69 64 20 6e 65 77 2d 74 65 73 74 -get-id new-test
bbf0: 64 61 74 29 29 0a 09 20 28 6f 70 65 6e 2d 72 75 dat)).. (open-ru
bc00: 6e 2d 63 6c 6f 73 65 20 0a 09 20 20 28 6c 61 6d n-close .. (lam
bc10: 62 64 61 20 28 29 0a 09 20 20 20 20 28 73 71 6c bda ().. (sql
bc20: 69 74 65 33 3a 65 78 65 63 75 74 65 20 0a 09 20 ite3:execute ..
bc30: 20 20 20 20 64 62 20 0a 09 20 20 20 20 20 28 63 db .. (c
bc40: 6f 6e 63 20 22 49 4e 53 45 52 54 20 4f 52 20 52 onc "INSERT OR R
bc50: 45 50 4c 41 43 45 20 49 4e 54 4f 20 74 65 73 74 EPLACE INTO test
bc60: 5f 73 74 65 70 73 20 28 74 65 73 74 5f 69 64 2c _steps (test_id,
bc70: 73 74 65 70 6e 61 6d 65 2c 73 74 61 74 65 2c 73 stepname,state,s
bc80: 74 61 74 75 73 2c 65 76 65 6e 74 5f 74 69 6d 65 tatus,event_time
bc90: 2c 63 6f 6d 6d 65 6e 74 29 20 22 0a 09 09 20 20 ,comment) "...
bca0: 20 22 53 45 4c 45 43 54 20 22 20 28 64 62 3a 74 "SELECT " (db:t
bcb0: 65 73 74 2d 67 65 74 2d 69 64 20 6e 65 77 2d 74 est-get-id new-t
bcc0: 65 73 74 64 61 74 29 20 22 2c 73 74 65 70 6e 61 estdat) ",stepna
bcd0: 6d 65 2c 73 74 61 74 65 2c 73 74 61 74 75 73 2c me,state,status,
bce0: 65 76 65 6e 74 5f 74 69 6d 65 2c 63 6f 6d 6d 65 event_time,comme
bcf0: 6e 74 20 46 52 4f 4d 20 74 65 73 74 5f 73 74 65 nt FROM test_ste
bd00: 70 73 20 57 48 45 52 45 20 74 65 73 74 5f 69 64 ps WHERE test_id
bd10: 3d 3f 3b 22 29 0a 09 20 20 20 20 20 28 64 62 3a =?;").. (db:
bd20: 74 65 73 74 2d 67 65 74 2d 69 64 20 74 65 73 74 test-get-id test
bd30: 64 61 74 29 29 0a 09 20 20 20 20 3b 3b 20 4e 6f dat)).. ;; No
bd40: 77 20 64 75 70 6c 69 63 61 74 65 20 74 68 65 20 w duplicate the
bd50: 74 65 73 74 20 64 61 74 61 0a 09 20 20 20 20 28 test data.. (
bd60: 64 65 62 75 67 3a 70 72 69 6e 74 20 34 20 22 43 debug:print 4 "C
bd70: 6f 70 79 69 6e 67 20 72 65 63 6f 72 64 73 20 69 opying records i
bd80: 6e 20 74 65 73 74 5f 64 61 74 61 20 66 72 6f 6d n test_data from
bd90: 20 74 65 73 74 5f 69 64 3d 22 20 28 64 62 3a 74 test_id=" (db:t
bda0: 65 73 74 2d 67 65 74 2d 69 64 20 74 65 73 74 64 est-get-id testd
bdb0: 61 74 29 20 22 20 74 6f 20 22 20 28 64 62 3a 74 at) " to " (db:t
bdc0: 65 73 74 2d 67 65 74 2d 69 64 20 6e 65 77 2d 74 est-get-id new-t
bdd0: 65 73 74 64 61 74 29 29 0a 09 20 20 20 20 28 73 estdat)).. (s
bde0: 71 6c 69 74 65 33 3a 65 78 65 63 75 74 65 20 0a qlite3:execute .
bdf0: 09 20 20 20 20 20 64 62 20 0a 09 20 20 20 20 20 . db ..
be00: 28 63 6f 6e 63 20 22 49 4e 53 45 52 54 20 4f 52 (conc "INSERT OR
be10: 20 52 45 50 4c 41 43 45 20 49 4e 54 4f 20 74 65 REPLACE INTO te
be20: 73 74 5f 64 61 74 61 20 28 74 65 73 74 5f 69 64 st_data (test_id
be30: 2c 63 61 74 65 67 6f 72 79 2c 76 61 72 69 61 62 ,category,variab
be40: 6c 65 2c 76 61 6c 75 65 2c 65 78 70 65 63 74 65 le,value,expecte
be50: 64 2c 74 6f 6c 2c 75 6e 69 74 73 2c 63 6f 6d 6d d,tol,units,comm
be60: 65 6e 74 29 20 22 0a 09 09 20 20 20 22 53 45 4c ent) "... "SEL
be70: 45 43 54 20 22 20 28 64 62 3a 74 65 73 74 2d 67 ECT " (db:test-g
be80: 65 74 2d 69 64 20 6e 65 77 2d 74 65 73 74 64 61 et-id new-testda
be90: 74 29 20 22 2c 63 61 74 65 67 6f 72 79 2c 76 61 t) ",category,va
bea0: 72 69 61 62 6c 65 2c 76 61 6c 75 65 2c 65 78 70 riable,value,exp
beb0: 65 63 74 65 64 2c 74 6f 6c 2c 75 6e 69 74 73 2c ected,tol,units,
bec0: 63 6f 6d 6d 65 6e 74 20 46 52 4f 4d 20 74 65 73 comment FROM tes
bed0: 74 5f 64 61 74 61 20 57 48 45 52 45 20 74 65 73 t_data WHERE tes
bee0: 74 5f 69 64 3d 3f 3b 22 29 0a 09 20 20 20 20 20 t_id=?;")..
bef0: 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 69 64 20 (db:test-get-id
bf00: 74 65 73 74 64 61 74 29 29 29 29 0a 09 20 29 29 testdat)))).. ))
bf10: 0a 20 20 20 20 20 70 72 65 76 2d 74 65 73 74 73 . prev-tests
bf20: 29 29 29 0a 09 20 0a 20 20 20 20 20 0a ))).. . .