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 31 29 29 29 0a 09 20 28 6a 6f 62 2d 67 ...1))).. (job-g
1250: 72 6f 75 70 2d 6c 69 6d 69 74 20 20 20 20 20 20 roup-limit
1260: 20 20 20 28 63 6f 6e 66 69 67 2d 6c 6f 6f 6b 75 (config-looku
1270: 70 20 2a 63 6f 6e 66 69 67 64 61 74 2a 20 22 6a p *configdat* "j
1280: 6f 62 67 72 6f 75 70 73 22 20 6a 6f 62 67 72 6f obgroups" jobgro
1290: 75 70 29 29 29 0a 20 20 20 20 28 69 66 20 28 6e up))). (if (n
12a0: 6f 74 20 28 65 71 3f 20 2a 6c 61 73 74 2d 6e 75 ot (eq? *last-nu
12b0: 6d 2d 72 75 6e 6e 69 6e 67 2d 74 65 73 74 73 2a m-running-tests*
12c0: 20 6e 75 6d 2d 72 75 6e 6e 69 6e 67 29 29 0a 09 num-running))..
12d0: 28 62 65 67 69 6e 0a 09 20 20 28 64 65 62 75 67 (begin.. (debug
12e0: 3a 70 72 69 6e 74 20 32 20 22 6d 61 78 2d 63 6f :print 2 "max-co
12f0: 6e 63 75 72 72 65 6e 74 2d 6a 6f 62 73 3a 20 22 ncurrent-jobs: "
1300: 20 6d 61 78 2d 63 6f 6e 63 75 72 72 65 6e 74 2d max-concurrent-
1310: 6a 6f 62 73 20 22 2c 20 6e 75 6d 2d 72 75 6e 6e jobs ", num-runn
1320: 69 6e 67 3a 20 22 20 6e 75 6d 2d 72 75 6e 6e 69 ing: " num-runni
1330: 6e 67 29 0a 09 20 20 28 73 65 74 21 20 2a 6c 61 ng).. (set! *la
1340: 73 74 2d 6e 75 6d 2d 72 75 6e 6e 69 6e 67 2d 74 st-num-running-t
1350: 65 73 74 73 2a 20 6e 75 6d 2d 72 75 6e 6e 69 6e ests* num-runnin
1360: 67 29 29 29 0a 20 20 20 20 28 69 66 20 28 6e 6f g))). (if (no
1370: 74 20 28 65 71 3f 20 30 20 2a 67 6c 6f 62 61 6c t (eq? 0 *global
1380: 65 78 69 74 73 74 61 74 75 73 2a 29 29 0a 09 28 exitstatus*))..(
1390: 6c 69 73 74 20 23 66 20 6e 75 6d 2d 72 75 6e 6e list #f num-runn
13a0: 69 6e 67 20 6e 75 6d 2d 72 75 6e 6e 69 6e 67 2d ing num-running-
13b0: 69 6e 2d 6a 6f 62 67 72 6f 75 70 20 6d 61 78 2d in-jobgroup max-
13c0: 63 6f 6e 63 75 72 72 65 6e 74 2d 6a 6f 62 73 20 concurrent-jobs
13d0: 6a 6f 62 2d 67 72 6f 75 70 2d 6c 69 6d 69 74 29 job-group-limit)
13e0: 0a 09 28 6c 65 74 20 28 28 63 61 6e 2d 6e 6f 74 ..(let ((can-not
13f0: 2d 72 75 6e 2d 6d 6f 72 65 20 28 63 6f 6e 64 0a -run-more (cond.
1400: 09 09 09 09 20 3b 3b 20 69 66 20 6d 61 78 2d 63 .... ;; if max-c
1410: 6f 6e 63 75 72 72 65 6e 74 2d 6a 6f 62 73 20 69 oncurrent-jobs i
1420: 73 20 73 65 74 20 61 6e 64 20 74 68 65 20 6e 75 s set and the nu
1430: 6d 62 65 72 20 72 75 6e 6e 69 6e 67 20 69 73 20 mber running is
1440: 67 72 65 61 74 65 72 20 0a 09 09 09 09 20 3b 3b greater ..... ;;
1450: 20 74 68 61 6e 20 69 74 20 74 68 61 6e 20 63 61 than it than ca
1460: 6e 6e 6f 74 20 72 75 6e 20 6d 6f 72 65 20 6a 6f nnot run more jo
1470: 62 73 0a 09 09 09 09 20 28 28 61 6e 64 20 6d 61 bs..... ((and ma
1480: 78 2d 63 6f 6e 63 75 72 72 65 6e 74 2d 6a 6f 62 x-concurrent-job
1490: 73 20 28 3e 3d 20 6e 75 6d 2d 72 75 6e 6e 69 6e s (>= num-runnin
14a0: 67 20 6d 61 78 2d 63 6f 6e 63 75 72 72 65 6e 74 g max-concurrent
14b0: 2d 6a 6f 62 73 29 29 0a 09 09 09 09 20 20 28 64 -jobs))..... (d
14c0: 65 62 75 67 3a 70 72 69 6e 74 20 30 20 22 57 41 ebug:print 0 "WA
14d0: 52 4e 49 4e 47 3a 20 4d 61 78 20 72 75 6e 6e 69 RNING: Max runni
14e0: 6e 67 20 6a 6f 62 73 20 65 78 63 65 65 64 65 64 ng jobs exceeded
14f0: 2c 20 63 75 72 72 65 6e 74 20 6e 75 6d 62 65 72 , current number
1500: 20 72 75 6e 6e 69 6e 67 3a 20 22 20 6e 75 6d 2d running: " num-
1510: 72 75 6e 6e 69 6e 67 20 0a 09 09 09 09 09 20 20 running ......
1520: 20 20 20 20 20 22 2c 20 6d 61 78 5f 63 6f 6e 63 ", max_conc
1530: 75 72 72 65 6e 74 5f 6a 6f 62 73 3a 20 22 20 6d urrent_jobs: " m
1540: 61 78 2d 63 6f 6e 63 75 72 72 65 6e 74 2d 6a 6f ax-concurrent-jo
1550: 62 73 29 0a 09 09 09 09 20 20 23 74 29 0a 09 09 bs)..... #t)...
1560: 09 09 20 3b 3b 20 69 66 20 6a 6f 62 2d 67 72 6f .. ;; if job-gro
1570: 75 70 2d 6c 69 6d 69 74 20 69 73 20 73 65 74 20 up-limit is set
1580: 61 6e 64 20 6e 75 6d 62 65 72 20 6f 66 20 6a 6f and number of jo
1590: 62 73 20 69 6e 20 74 68 65 20 67 72 6f 75 70 20 bs in the group
15a0: 69 73 20 67 72 65 61 74 65 72 0a 09 09 09 09 20 is greater.....
15b0: 3b 3b 20 74 68 61 6e 20 74 68 65 20 6c 69 6d 69 ;; than the limi
15c0: 74 20 74 68 65 6e 20 63 61 6e 6e 6f 74 20 72 75 t then cannot ru
15d0: 6e 20 6d 6f 72 65 20 6a 6f 62 73 20 6f 66 20 74 n more jobs of t
15e0: 68 69 73 20 6b 69 6e 64 0a 09 09 09 09 20 28 28 his kind..... ((
15f0: 61 6e 64 20 6a 6f 62 2d 67 72 6f 75 70 2d 6c 69 and job-group-li
1600: 6d 69 74 0a 09 09 09 09 20 20 20 20 20 20 20 28 mit..... (
1610: 3e 3d 20 6e 75 6d 2d 72 75 6e 6e 69 6e 67 2d 69 >= num-running-i
1620: 6e 2d 6a 6f 62 67 72 6f 75 70 20 6a 6f 62 2d 67 n-jobgroup job-g
1630: 72 6f 75 70 2d 6c 69 6d 69 74 29 29 0a 09 09 09 roup-limit))....
1640: 09 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 . (debug:print
1650: 31 20 22 57 41 52 4e 49 4e 47 3a 20 6e 75 6d 62 1 "WARNING: numb
1660: 65 72 20 6f 66 20 6a 6f 62 73 20 22 20 6e 75 6d er of jobs " num
1670: 2d 72 75 6e 6e 69 6e 67 2d 69 6e 2d 6a 6f 62 67 -running-in-jobg
1680: 72 6f 75 70 20 0a 09 09 09 09 09 20 20 20 20 20 roup ......
1690: 20 20 22 20 69 6e 20 22 20 6a 6f 62 67 72 6f 75 " in " jobgrou
16a0: 70 20 22 20 65 78 63 65 65 64 65 64 2c 20 77 69 p " exceeded, wi
16b0: 6c 6c 20 6e 6f 74 20 72 75 6e 20 22 20 28 74 65 ll not run " (te
16c0: 73 74 73 3a 74 65 73 74 71 75 65 75 65 2d 67 65 sts:testqueue-ge
16d0: 74 2d 74 65 73 74 6e 61 6d 65 20 74 65 73 74 2d t-testname test-
16e0: 72 65 63 6f 72 64 29 29 0a 09 09 09 09 20 20 23 record))..... #
16f0: 74 29 0a 09 09 09 09 20 28 65 6c 73 65 20 23 66 t)..... (else #f
1700: 29 29 29 29 0a 09 20 20 28 6c 69 73 74 20 28 6e )))).. (list (n
1710: 6f 74 20 63 61 6e 2d 6e 6f 74 2d 72 75 6e 2d 6d ot can-not-run-m
1720: 6f 72 65 29 20 6e 75 6d 2d 72 75 6e 6e 69 6e 67 ore) num-running
1730: 20 6e 75 6d 2d 72 75 6e 6e 69 6e 67 2d 69 6e 2d num-running-in-
1740: 6a 6f 62 67 72 6f 75 70 20 6d 61 78 2d 63 6f 6e jobgroup max-con
1750: 63 75 72 72 65 6e 74 2d 6a 6f 62 73 20 6a 6f 62 current-jobs job
1760: 2d 67 72 6f 75 70 2d 6c 69 6d 69 74 29 29 29 29 -group-limit))))
1770: 29 0a 0a 3b 3b 3d 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 0a 3b 3b 20 4e ===========.;; N
17c0: 65 77 20 6d 65 74 68 6f 64 6f 6c 6f 67 79 2e 20 ew methodology.
17d0: 54 68 65 73 65 20 72 6f 75 74 69 6e 65 73 20 77 These routines w
17e0: 69 6c 6c 20 72 65 70 6c 61 63 65 20 74 68 65 20 ill replace the
17f0: 61 62 6f 76 65 20 69 6e 20 74 69 6d 65 2e 20 46 above in time. F
1800: 6f 72 0a 3b 3b 20 6e 6f 77 20 74 68 65 20 63 6f or.;; now the co
1810: 64 65 20 69 73 20 64 75 70 6c 69 63 61 74 65 64 de is duplicated
1820: 2e 20 54 68 69 73 20 73 74 75 66 66 20 69 73 20 . This stuff is
1830: 69 6e 69 74 69 61 6c 6c 79 20 75 73 65 64 20 69 initially used i
1840: 6e 20 74 68 65 20 6d 6f 6e 69 74 6f 72 0a 3b 3b n the monitor.;;
1850: 20 62 61 73 65 64 20 63 6f 64 65 2e 0a 3b 3b 3d 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 0a 0a 3b 3b 20 72 65 67 69 73 74 =====..;; regist
18b0: 65 72 20 61 20 74 65 73 74 20 72 75 6e 20 77 69 er a test run wi
18c0: 74 68 20 74 68 65 20 64 62 0a 28 64 65 66 69 6e th the db.(defin
18d0: 65 20 28 72 75 6e 73 3a 72 65 67 69 73 74 65 72 e (runs:register
18e0: 2d 72 75 6e 20 64 62 20 6b 65 79 73 20 6b 65 79 -run db keys key
18f0: 76 61 6c 6c 73 74 20 72 75 6e 6e 61 6d 65 20 73 vallst runname s
1900: 74 61 74 65 20 73 74 61 74 75 73 20 75 73 65 72 tate status user
1910: 29 0a 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 ). (debug:print
1920: 20 33 20 22 72 75 6e 73 3a 72 65 67 69 73 74 65 3 "runs:registe
1930: 72 2d 72 75 6e 2c 20 6b 65 79 73 3a 20 22 20 6b r-run, keys: " k
1940: 65 79 73 20 22 20 6b 65 79 76 61 6c 6c 73 74 3a eys " keyvallst:
1950: 20 22 20 6b 65 79 76 61 6c 6c 73 74 20 22 20 72 " keyvallst " r
1960: 75 6e 6e 61 6d 65 3a 20 22 20 72 75 6e 6e 61 6d unname: " runnam
1970: 65 20 22 20 73 74 61 74 65 3a 20 22 20 73 74 61 e " state: " sta
1980: 74 65 20 22 20 73 74 61 74 75 73 3a 20 22 20 73 te " status: " s
1990: 74 61 74 75 73 20 22 20 75 73 65 72 3a 20 22 20 tatus " user: "
19a0: 75 73 65 72 29 0a 20 20 28 6c 65 74 2a 20 28 28 user). (let* ((
19b0: 6b 65 79 73 74 72 20 20 20 20 28 6b 65 79 73 2d keystr (keys-
19c0: 3e 6b 65 79 73 74 72 20 6b 65 79 73 29 29 0a 09 >keystr keys))..
19d0: 20 28 63 6f 6d 6d 61 20 20 20 20 20 28 69 66 20 (comma (if
19e0: 28 3e 20 28 6c 65 6e 67 74 68 20 6b 65 79 73 29 (> (length keys)
19f0: 20 30 29 20 22 2c 22 20 22 22 29 29 0a 09 20 28 0) "," "")).. (
1a00: 61 6e 64 73 74 72 20 20 20 20 28 69 66 20 28 3e andstr (if (>
1a10: 20 28 6c 65 6e 67 74 68 20 6b 65 79 73 29 20 30 (length keys) 0
1a20: 29 20 22 20 41 4e 44 20 22 20 22 22 29 29 0a 09 ) " AND " ""))..
1a30: 20 28 76 61 6c 73 6c 6f 74 73 20 20 28 6b 65 79 (valslots (key
1a40: 73 2d 3e 76 61 6c 73 6c 6f 74 73 20 6b 65 79 73 s->valslots keys
1a50: 29 29 20 3b 3b 20 3f 2c 3f 2c 3f 20 2e 2e 2e 0a )) ;; ?,?,? ....
1a60: 09 20 28 6b 65 79 76 61 6c 73 20 20 20 28 6d 61 . (keyvals (ma
1a70: 70 20 63 61 64 72 20 6b 65 79 76 61 6c 6c 73 74 p cadr keyvallst
1a80: 29 29 0a 09 20 28 61 6c 6c 76 61 6c 73 20 20 20 )).. (allvals
1a90: 28 61 70 70 65 6e 64 20 28 6c 69 73 74 20 72 75 (append (list ru
1aa0: 6e 6e 61 6d 65 20 73 74 61 74 65 20 73 74 61 74 nname state stat
1ab0: 75 73 20 75 73 65 72 29 20 6b 65 79 76 61 6c 73 us user) keyvals
1ac0: 29 29 0a 09 20 28 71 72 79 76 61 6c 73 20 20 20 )).. (qryvals
1ad0: 28 61 70 70 65 6e 64 20 28 6c 69 73 74 20 72 75 (append (list ru
1ae0: 6e 6e 61 6d 65 29 20 6b 65 79 76 61 6c 73 29 29 nname) keyvals))
1af0: 0a 09 20 28 6b 65 79 3d 3f 73 74 72 20 20 28 73 .. (key=?str (s
1b00: 74 72 69 6e 67 2d 69 6e 74 65 72 73 70 65 72 73 tring-interspers
1b10: 65 20 28 6d 61 70 20 28 6c 61 6d 62 64 61 20 28 e (map (lambda (
1b20: 6b 29 28 63 6f 6e 63 20 28 6b 65 79 3a 67 65 74 k)(conc (key:get
1b30: 2d 66 69 65 6c 64 6e 61 6d 65 20 6b 29 20 22 3d -fieldname k) "=
1b40: 3f 22 29 29 20 6b 65 79 73 29 20 22 20 41 4e 44 ?")) keys) " AND
1b50: 20 22 29 29 29 0a 20 20 20 20 28 64 65 62 75 67 "))). (debug
1b60: 3a 70 72 69 6e 74 20 33 20 22 6b 65 79 73 3a 20 :print 3 "keys:
1b70: 22 20 6b 65 79 73 20 22 20 61 6c 6c 76 61 6c 73 " keys " allvals
1b80: 3a 20 22 20 61 6c 6c 76 61 6c 73 20 22 20 6b 65 : " allvals " ke
1b90: 79 76 61 6c 73 3a 20 22 20 6b 65 79 76 61 6c 73 yvals: " keyvals
1ba0: 29 0a 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 ). (debug:pri
1bb0: 6e 74 20 32 20 22 4e 4f 54 45 3a 20 75 73 69 6e nt 2 "NOTE: usin
1bc0: 67 20 74 61 72 67 65 74 20 22 20 28 73 74 72 69 g target " (stri
1bd0: 6e 67 2d 69 6e 74 65 72 73 70 65 72 73 65 20 6b ng-intersperse k
1be0: 65 79 76 61 6c 73 20 22 2f 22 29 20 22 20 66 6f eyvals "/") " fo
1bf0: 72 20 74 68 69 73 20 72 75 6e 22 29 0a 20 20 20 r this run").
1c00: 20 28 69 66 20 28 61 6e 64 20 72 75 6e 6e 61 6d (if (and runnam
1c10: 65 20 28 6e 75 6c 6c 3f 20 28 66 69 6c 74 65 72 e (null? (filter
1c20: 20 28 6c 61 6d 62 64 61 20 28 78 29 28 6e 6f 74 (lambda (x)(not
1c30: 20 78 29 29 20 6b 65 79 76 61 6c 73 29 29 29 20 x)) keyvals)))
1c40: 3b 3b 20 74 68 65 72 65 20 6d 75 73 74 20 62 65 ;; there must be
1c50: 20 61 20 62 65 74 74 65 72 20 77 61 79 20 74 6f a better way to
1c60: 20 22 61 70 70 6c 79 20 61 6e 64 22 0a 09 28 6c "apply and"..(l
1c70: 65 74 20 28 28 72 65 73 20 23 66 29 29 0a 09 20 et ((res #f))..
1c80: 20 28 61 70 70 6c 79 20 73 71 6c 69 74 65 33 3a (apply sqlite3:
1c90: 65 78 65 63 75 74 65 20 64 62 20 28 63 6f 6e 63 execute db (conc
1ca0: 20 22 49 4e 53 45 52 54 20 4f 52 20 49 47 4e 4f "INSERT OR IGNO
1cb0: 52 45 20 49 4e 54 4f 20 72 75 6e 73 20 28 72 75 RE INTO runs (ru
1cc0: 6e 6e 61 6d 65 2c 73 74 61 74 65 2c 73 74 61 74 nname,state,stat
1cd0: 75 73 2c 6f 77 6e 65 72 2c 65 76 65 6e 74 5f 74 us,owner,event_t
1ce0: 69 6d 65 22 20 63 6f 6d 6d 61 20 6b 65 79 73 74 ime" comma keyst
1cf0: 72 20 22 29 20 56 41 4c 55 45 53 20 28 3f 2c 3f r ") VALUES (?,?
1d00: 2c 3f 2c 3f 2c 73 74 72 66 74 69 6d 65 28 27 25 ,?,?,strftime('%
1d10: 73 27 2c 27 6e 6f 77 27 29 22 20 63 6f 6d 6d 61 s','now')" comma
1d20: 20 76 61 6c 73 6c 6f 74 73 20 22 29 3b 22 29 0a valslots ");").
1d30: 09 09 20 61 6c 6c 76 61 6c 73 29 0a 09 20 20 28 .. allvals).. (
1d40: 61 70 70 6c 79 20 73 71 6c 69 74 65 33 3a 66 6f apply sqlite3:fo
1d50: 72 2d 65 61 63 68 2d 72 6f 77 20 0a 09 20 20 20 r-each-row ..
1d60: 28 6c 61 6d 62 64 61 20 28 69 64 29 0a 09 20 20 (lambda (id)..
1d70: 20 20 20 28 73 65 74 21 20 72 65 73 20 69 64 29 (set! res id)
1d80: 29 0a 09 20 20 20 64 62 0a 09 20 20 20 28 6c 65 ).. db.. (le
1d90: 74 20 28 28 71 72 79 20 28 63 6f 6e 63 20 22 53 t ((qry (conc "S
1da0: 45 4c 45 43 54 20 69 64 20 46 52 4f 4d 20 72 75 ELECT id FROM ru
1db0: 6e 73 20 57 48 45 52 45 20 28 72 75 6e 6e 61 6d ns WHERE (runnam
1dc0: 65 3d 3f 20 22 20 61 6e 64 73 74 72 20 6b 65 79 e=? " andstr key
1dd0: 3d 3f 73 74 72 20 22 29 3b 22 29 29 29 0a 09 20 =?str ");")))..
1de0: 20 20 20 20 3b 28 64 65 62 75 67 3a 70 72 69 6e ;(debug:prin
1df0: 74 20 34 20 22 71 72 79 3a 20 22 20 71 72 79 29 t 4 "qry: " qry)
1e00: 20 0a 09 20 20 20 20 20 71 72 79 29 0a 09 20 20 .. qry)..
1e10: 20 71 72 79 76 61 6c 73 29 0a 09 20 20 28 73 71 qryvals).. (sq
1e20: 6c 69 74 65 33 3a 65 78 65 63 75 74 65 20 64 62 lite3:execute db
1e30: 20 22 55 50 44 41 54 45 20 72 75 6e 73 20 53 45 "UPDATE runs SE
1e40: 54 20 73 74 61 74 65 3d 3f 2c 73 74 61 74 75 73 T state=?,status
1e50: 3d 3f 20 57 48 45 52 45 20 69 64 3d 3f 3b 22 20 =? WHERE id=?;"
1e60: 73 74 61 74 65 20 73 74 61 74 75 73 20 72 65 73 state status res
1e70: 29 0a 09 20 20 72 65 73 29 20 0a 09 28 62 65 67 ).. res) ..(beg
1e80: 69 6e 0a 09 20 20 28 64 65 62 75 67 3a 70 72 69 in.. (debug:pri
1e90: 6e 74 20 30 20 22 45 52 52 4f 52 3a 20 43 61 6c nt 0 "ERROR: Cal
1ea0: 6c 65 64 20 77 69 74 68 6f 75 74 20 61 6c 6c 20 led without all
1eb0: 6e 65 63 65 73 73 61 72 79 20 6b 65 79 73 22 29 necessary keys")
1ec0: 0a 09 20 20 23 66 29 29 29 29 0a 0a 3b 3b 20 54 .. #f))))..;; T
1ed0: 68 69 73 20 69 73 20 61 20 64 75 70 6c 69 63 61 his is a duplica
1ee0: 74 65 20 6f 66 20 72 75 6e 2d 74 65 73 74 73 20 te of run-tests
1ef0: 28 77 68 69 63 68 20 68 61 73 20 62 65 65 6e 20 (which has been
1f00: 64 65 70 72 65 63 61 74 65 64 29 2e 20 55 73 65 deprecated). Use
1f10: 20 74 68 69 73 20 6f 6e 65 20 69 6e 73 74 65 61 this one instea
1f20: 64 20 6f 66 20 72 75 6e 20 74 65 73 74 73 2e 0a d of run tests..
1f30: 3b 3b 20 6b 65 79 76 61 6c 73 2e 0a 3b 3b 0a 3b ;; keyvals..;;.;
1f40: 3b 20 20 74 65 73 74 2d 6e 61 6d 65 73 3a 20 43 ; test-names: C
1f50: 6f 6d 6d 61 20 73 65 70 61 72 61 74 65 64 20 70 omma separated p
1f60: 61 74 74 65 72 6e 73 20 73 61 6d 65 20 61 73 20 atterns same as
1f70: 74 65 73 74 2d 70 61 74 74 73 20 62 75 74 20 75 test-patts but u
1f80: 73 65 64 20 69 6e 20 73 65 6c 65 63 74 69 6f 6e sed in selection
1f90: 20 0a 3b 3b 20 20 20 20 20 20 20 20 20 20 20 20 .;;
1fa0: 20 20 6f 66 20 74 65 73 74 73 20 74 6f 20 72 75 of tests to ru
1fb0: 6e 2e 20 54 68 65 20 69 74 65 6d 20 70 6f 72 74 n. The item port
1fc0: 69 6f 6e 73 20 61 72 65 20 6e 6f 74 20 72 65 73 ions are not res
1fd0: 70 65 63 74 65 64 2e 0a 3b 3b 20 20 20 20 20 20 pected..;;
1fe0: 20 20 20 20 20 20 20 20 46 49 58 4d 45 3a 20 65 FIXME: e
1ff0: 72 72 6f 72 20 6f 75 74 20 69 66 20 2f 70 61 74 rror out if /pat
2000: 74 20 73 70 65 63 69 66 69 65 64 0a 3b 3b 20 20 t specified.;;
2010: 20 20 20 20 20 20 20 20 20 20 0a 28 64 65 66 69 .(defi
2020: 6e 65 20 28 72 75 6e 73 3a 72 75 6e 2d 74 65 73 ne (runs:run-tes
2030: 74 73 20 74 61 72 67 65 74 20 72 75 6e 6e 61 6d ts target runnam
2040: 65 20 74 65 73 74 2d 6e 61 6d 65 73 20 74 65 73 e test-names tes
2050: 74 2d 70 61 74 74 73 20 75 73 65 72 20 66 6c 61 t-patts user fla
2060: 67 73 29 0a 20 20 28 6c 65 74 2a 20 28 28 64 62 gs). (let* ((db
2070: 20 20 20 20 20 20 20 20 20 20 23 66 29 0a 09 20 #f)..
2080: 28 6b 65 79 73 20 20 20 20 20 20 20 20 28 63 64 (keys (cd
2090: 62 3a 72 65 6d 6f 74 65 2d 72 75 6e 20 64 62 3a b:remote-run db:
20a0: 67 65 74 2d 6b 65 79 73 20 23 66 29 29 0a 09 20 get-keys #f))..
20b0: 28 6b 65 79 76 61 6c 6c 73 74 20 20 20 28 6b 65 (keyvallst (ke
20c0: 79 73 3a 74 61 72 67 65 74 2d 3e 6b 65 79 76 61 ys:target->keyva
20d0: 6c 20 6b 65 79 73 20 74 61 72 67 65 74 29 29 0a l keys target)).
20e0: 09 20 28 72 75 6e 2d 69 64 20 20 20 20 20 20 28 . (run-id (
20f0: 63 64 62 3a 72 65 6d 6f 74 65 2d 72 75 6e 20 72 cdb:remote-run r
2100: 75 6e 73 3a 72 65 67 69 73 74 65 72 2d 72 75 6e uns:register-run
2110: 20 23 66 20 6b 65 79 73 20 6b 65 79 76 61 6c 6c #f keys keyvall
2120: 73 74 20 72 75 6e 6e 61 6d 65 20 22 6e 65 77 22 st runname "new"
2130: 20 22 6e 2f 61 22 20 75 73 65 72 29 29 20 20 3b "n/a" user)) ;
2140: 3b 20 20 74 65 73 74 2d 6e 61 6d 65 29 29 29 0a ; test-name))).
2150: 09 20 28 64 65 66 65 72 72 65 64 20 20 20 20 27 . (deferred '
2160: 28 29 29 20 3b 3b 20 64 65 6c 61 79 20 72 75 6e ()) ;; delay run
2170: 6e 69 6e 67 20 74 68 65 73 65 20 73 69 6e 63 65 ning these since
2180: 20 74 68 65 79 20 68 61 76 65 20 61 20 77 61 69 they have a wai
2190: 74 6f 6e 20 63 6c 61 75 73 65 0a 09 20 3b 3b 20 ton clause.. ;;
21a0: 6b 65 65 70 67 6f 69 6e 67 20 69 73 20 74 68 65 keepgoing is the
21b0: 20 64 65 66 61 63 74 6f 20 6d 6f 64 61 6c 69 74 defacto modalit
21c0: 79 20 6e 6f 77 2c 20 77 69 6c 6c 20 61 64 64 20 y now, will add
21d0: 68 69 74 2d 6e 2d 72 75 6e 20 61 20 62 69 74 20 hit-n-run a bit
21e0: 6c 61 74 65 72 0a 09 20 3b 3b 20 28 6b 65 65 70 later.. ;; (keep
21f0: 67 6f 69 6e 67 20 20 20 28 68 61 73 68 2d 74 61 going (hash-ta
2200: 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 ble-ref/default
2210: 66 6c 61 67 73 20 22 2d 6b 65 65 70 67 6f 69 6e flags "-keepgoin
2220: 67 22 20 23 66 29 29 0a 09 20 28 72 75 6e 63 6f g" #f)).. (runco
2230: 6e 66 69 67 66 20 20 20 28 63 6f 6e 63 20 20 2a nfigf (conc *
2240: 74 6f 70 70 61 74 68 2a 20 22 2f 72 75 6e 63 6f toppath* "/runco
2250: 6e 66 69 67 73 2e 63 6f 6e 66 69 67 22 29 29 0a nfigs.config")).
2260: 09 20 28 72 65 71 75 69 72 65 64 2d 74 65 73 74 . (required-test
2270: 73 20 27 28 29 29 0a 09 20 28 74 65 73 74 2d 72 s '()).. (test-r
2280: 65 63 6f 72 64 73 20 28 6d 61 6b 65 2d 68 61 73 ecords (make-has
2290: 68 2d 74 61 62 6c 65 29 29 29 0a 0a 20 20 20 20 h-table)))..
22a0: 28 73 65 74 2d 6d 65 67 61 74 65 73 74 2d 65 6e (set-megatest-en
22b0: 76 2d 76 61 72 73 20 72 75 6e 2d 69 64 29 20 3b v-vars run-id) ;
22c0: 3b 20 74 68 65 73 65 20 6d 61 79 20 62 65 20 6e ; these may be n
22d0: 65 65 64 65 64 20 62 79 20 74 68 65 20 6c 61 75 eeded by the lau
22e0: 6e 63 68 69 6e 67 20 70 72 6f 63 65 73 73 0a 0a nching process..
22f0: 20 20 20 20 28 69 66 20 28 66 69 6c 65 2d 65 78 (if (file-ex
2300: 69 73 74 73 3f 20 72 75 6e 63 6f 6e 66 69 67 66 ists? runconfigf
2310: 29 0a 09 28 6f 70 65 6e 2d 72 75 6e 2d 63 6c 6f )..(open-run-clo
2320: 73 65 20 73 65 74 75 70 2d 65 6e 76 2d 64 65 66 se setup-env-def
2330: 61 75 6c 74 73 20 64 62 20 72 75 6e 63 6f 6e 66 aults db runconf
2340: 69 67 66 20 72 75 6e 2d 69 64 20 2a 61 6c 72 65 igf run-id *alre
2350: 61 64 79 2d 73 65 65 6e 2d 72 75 6e 63 6f 6e 66 ady-seen-runconf
2360: 69 67 2d 69 6e 66 6f 2a 20 22 70 72 65 2d 6c 61 ig-info* "pre-la
2370: 75 6e 63 68 2d 65 6e 76 2d 76 61 72 73 22 29 0a unch-env-vars").
2380: 09 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 .(debug:print 0
2390: 22 57 41 52 4e 49 4e 47 3a 20 59 6f 75 20 64 6f "WARNING: You do
23a0: 20 6e 6f 74 20 68 61 76 65 20 61 20 72 75 6e 20 not have a run
23b0: 63 6f 6e 66 69 67 20 66 69 6c 65 3a 20 22 20 72 config file: " r
23c0: 75 6e 63 6f 6e 66 69 67 66 29 29 0a 20 20 20 20 unconfigf)).
23d0: 0a 20 20 20 20 3b 3b 20 6c 6f 6f 6b 20 75 70 20 . ;; look up
23e0: 61 6c 6c 20 74 65 73 74 73 20 6d 61 74 63 68 69 all tests matchi
23f0: 6e 67 20 74 68 65 20 63 6f 6d 6d 61 20 73 65 70 ng the comma sep
2400: 61 72 61 74 65 64 20 6c 69 73 74 20 6f 66 20 67 arated list of g
2410: 6c 6f 62 73 20 69 6e 0a 20 20 20 20 3b 3b 20 74 lobs in. ;; t
2420: 65 73 74 2d 70 61 74 74 73 20 28 75 73 69 6e 67 est-patts (using
2430: 20 25 20 61 73 20 77 69 6c 64 63 61 72 64 29 0a % as wildcard).
2440: 0a 20 20 20 20 28 73 65 74 21 20 74 65 73 74 2d . (set! test-
2450: 6e 61 6d 65 73 20 28 61 70 70 65 6e 64 20 28 74 names (append (t
2460: 65 73 74 73 3a 67 65 74 2d 76 61 6c 69 64 2d 74 ests:get-valid-t
2470: 65 73 74 73 20 2a 74 6f 70 70 61 74 68 2a 20 74 ests *toppath* t
2480: 65 73 74 2d 70 61 74 74 73 29 20 74 65 73 74 2d est-patts) test-
2490: 6e 61 6d 65 73 29 29 0a 20 20 20 20 28 73 65 74 names)). (set
24a0: 21 20 74 65 73 74 2d 6e 61 6d 65 73 20 28 64 65 ! test-names (de
24b0: 6c 65 74 65 2d 64 75 70 6c 69 63 61 74 65 73 20 lete-duplicates
24c0: 74 65 73 74 2d 6e 61 6d 65 73 29 29 0a 0a 20 20 test-names))..
24d0: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 (debug:print-i
24e0: 6e 66 6f 20 30 20 22 74 65 73 74 20 6e 61 6d 65 nfo 0 "test name
24f0: 73 20 22 20 74 65 73 74 2d 6e 61 6d 65 73 29 0a s " test-names).
2500: 0a 20 20 20 20 3b 3b 20 6f 6e 20 74 68 65 20 66 . ;; on the f
2510: 69 72 73 74 20 70 61 73 73 20 6f 72 20 63 61 6c irst pass or cal
2520: 6c 20 74 6f 20 72 75 6e 2d 74 65 73 74 73 20 73 l to run-tests s
2530: 65 74 20 46 41 49 4c 53 20 74 6f 20 4e 4f 54 5f et FAILS to NOT_
2540: 53 54 41 52 54 45 44 20 69 66 0a 20 20 20 20 3b STARTED if. ;
2550: 3b 20 2d 6b 65 65 70 67 6f 69 6e 67 20 69 73 20 ; -keepgoing is
2560: 73 70 65 63 69 66 69 65 64 0a 20 20 20 20 28 69 specified. (i
2570: 66 20 28 65 71 3f 20 2a 70 61 73 73 6e 75 6d 2a f (eq? *passnum*
2580: 20 30 29 0a 09 28 62 65 67 69 6e 0a 09 20 20 3b 0)..(begin.. ;
2590: 3b 20 68 61 76 65 20 74 6f 20 64 65 6c 65 74 65 ; have to delete
25a0: 20 74 65 73 74 20 72 65 63 6f 72 64 73 20 77 68 test records wh
25b0: 65 72 65 20 4e 4f 54 5f 53 54 41 52 54 45 44 20 ere NOT_STARTED
25c0: 73 69 6e 63 65 20 74 68 65 79 20 63 61 6e 20 63 since they can c
25d0: 61 75 73 65 20 2d 6b 65 65 70 67 6f 69 6e 67 20 ause -keepgoing
25e0: 74 6f 20 0a 09 20 20 3b 3b 20 67 65 74 20 73 74 to .. ;; get st
25f0: 75 63 6b 20 64 75 65 20 74 6f 20 62 65 63 6f 6d uck due to becom
2600: 69 6e 67 20 69 6e 61 63 63 65 73 73 69 62 6c 65 ing inaccessible
2610: 20 66 72 6f 6d 20 61 20 66 61 69 6c 65 64 20 74 from a failed t
2620: 65 73 74 2e 20 49 2e 65 2e 20 69 66 20 74 65 73 est. I.e. if tes
2630: 74 20 42 20 64 65 70 65 6e 64 73 20 0a 09 20 20 t B depends ..
2640: 3b 3b 20 6f 6e 20 74 65 73 74 20 41 20 62 75 74 ;; on test A but
2650: 20 74 65 73 74 20 42 20 72 65 61 63 68 65 64 20 test B reached
2660: 74 68 65 20 70 6f 69 6e 74 20 6f 6e 20 62 65 69 the point on bei
2670: 6e 67 20 72 65 67 69 73 74 65 72 65 64 20 61 73 ng registered as
2680: 20 4e 4f 54 5f 53 54 41 52 54 45 44 20 61 6e 64 NOT_STARTED and
2690: 20 74 65 73 74 0a 09 20 20 3b 3b 20 41 20 66 61 test.. ;; A fa
26a0: 69 6c 65 64 20 66 6f 72 20 73 6f 6d 65 20 72 65 iled for some re
26b0: 61 73 6f 6e 20 74 68 65 6e 20 6f 6e 20 72 65 2d ason then on re-
26c0: 72 75 6e 20 75 73 69 6e 67 20 2d 6b 65 65 70 67 run using -keepg
26d0: 6f 69 6e 67 20 74 68 65 20 72 75 6e 20 63 61 6e oing the run can
26e0: 20 6e 65 76 65 72 20 63 6f 6d 70 6c 65 74 65 2e never complete.
26f0: 0a 09 20 20 28 63 64 62 3a 64 65 6c 65 74 65 2d .. (cdb:delete-
2700: 74 65 73 74 73 2d 69 6e 2d 73 74 61 74 65 20 2a tests-in-state *
2710: 72 75 6e 72 65 6d 6f 74 65 2a 20 72 75 6e 2d 69 runremote* run-i
2720: 64 20 22 4e 4f 54 5f 53 54 41 52 54 45 44 22 29 d "NOT_STARTED")
2730: 0a 09 20 20 28 63 64 62 3a 72 65 6d 6f 74 65 2d .. (cdb:remote-
2740: 72 75 6e 20 64 62 3a 73 65 74 2d 74 65 73 74 73 run db:set-tests
2750: 2d 73 74 61 74 65 2d 73 74 61 74 75 73 20 23 66 -state-status #f
2760: 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 6e 61 6d run-id test-nam
2770: 65 73 20 23 66 20 22 46 41 49 4c 22 20 22 4e 4f es #f "FAIL" "NO
2780: 54 5f 53 54 41 52 54 45 44 22 20 22 46 41 49 4c T_STARTED" "FAIL
2790: 22 29 29 29 0a 0a 20 20 20 20 3b 3b 20 66 72 6f "))).. ;; fro
27a0: 6d 20 68 65 72 65 20 6f 6e 20 6f 75 74 20 74 68 m here on out th
27b0: 65 20 64 62 20 77 69 6c 6c 20 62 65 20 6f 70 65 e db will be ope
27c0: 6e 65 64 20 61 6e 64 20 63 6c 6f 73 65 64 20 6f ned and closed o
27d0: 6e 20 65 76 65 72 79 20 63 61 6c 6c 20 72 75 6e n every call run
27e0: 73 3a 72 75 6e 2d 74 65 73 74 73 2d 71 75 65 75 s:run-tests-queu
27f0: 65 0a 20 20 20 20 3b 3b 20 28 73 71 6c 69 74 65 e. ;; (sqlite
2800: 33 3a 66 69 6e 61 6c 69 7a 65 21 20 64 62 29 20 3:finalize! db)
2810: 0a 20 20 20 20 3b 3b 20 6e 6f 77 20 61 64 64 20 . ;; now add
2820: 6e 6f 6e 2d 64 69 72 65 63 74 6c 79 20 72 65 66 non-directly ref
2830: 65 72 65 6e 63 65 64 20 64 65 70 65 6e 64 65 6e erenced dependen
2840: 63 69 65 73 20 28 69 2e 65 2e 20 77 61 69 74 6f cies (i.e. waito
2850: 6e 29 0a 20 20 20 20 28 69 66 20 28 6e 6f 74 20 n). (if (not
2860: 28 6e 75 6c 6c 3f 20 74 65 73 74 2d 6e 61 6d 65 (null? test-name
2870: 73 29 29 0a 09 28 6c 65 74 20 6c 6f 6f 70 20 28 s))..(let loop (
2880: 28 68 65 64 20 28 63 61 72 20 74 65 73 74 2d 6e (hed (car test-n
2890: 61 6d 65 73 29 29 0a 09 09 20 20 20 28 74 61 6c ames))... (tal
28a0: 20 28 63 64 72 20 74 65 73 74 2d 6e 61 6d 65 73 (cdr test-names
28b0: 29 29 29 20 20 20 20 20 20 20 20 20 3b 3b 20 27 ))) ;; '
28c0: 72 65 74 75 72 6e 2d 70 72 6f 63 73 20 74 65 6c return-procs tel
28d0: 6c 73 20 74 68 65 20 63 6f 6e 66 69 67 20 72 65 ls the config re
28e0: 61 64 65 72 20 74 6f 20 70 72 65 70 20 72 75 6e ader to prep run
28f0: 6e 69 6e 67 20 73 79 73 74 65 6d 20 62 75 74 20 ning system but
2900: 72 65 74 75 72 6e 20 61 20 70 72 6f 63 0a 09 20 return a proc..
2910: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e (debug:print-in
2920: 66 6f 20 34 20 22 68 65 64 3d 22 20 68 65 64 20 fo 4 "hed=" hed
2930: 22 20 61 74 20 74 6f 70 20 6f 66 20 6c 6f 6f 70 " at top of loop
2940: 22 29 0a 09 20 20 28 6c 65 74 2a 20 28 28 63 6f ").. (let* ((co
2950: 6e 66 69 67 20 20 28 74 65 73 74 73 3a 67 65 74 nfig (tests:get
2960: 2d 74 65 73 74 63 6f 6e 66 69 67 20 68 65 64 20 -testconfig hed
2970: 27 72 65 74 75 72 6e 2d 70 72 6f 63 73 29 29 0a 'return-procs)).
2980: 09 09 20 28 77 61 69 74 6f 6e 73 20 28 69 66 20 .. (waitons (if
2990: 63 6f 6e 66 69 67 20 28 73 74 72 69 6e 67 2d 73 config (string-s
29a0: 70 6c 69 74 20 28 6c 65 74 20 28 28 77 20 28 63 plit (let ((w (c
29b0: 6f 6e 66 69 67 2d 6c 6f 6f 6b 75 70 20 63 6f 6e onfig-lookup con
29c0: 66 69 67 20 22 72 65 71 75 69 72 65 6d 65 6e 74 fig "requirement
29d0: 73 22 20 22 77 61 69 74 6f 6e 22 29 29 29 0a 09 s" "waiton")))..
29e0: 09 09 09 09 09 20 20 20 20 20 28 69 66 20 77 20 ..... (if w
29f0: 77 20 22 22 29 29 29 0a 09 09 09 20 20 20 20 20 w "")))....
2a00: 20 28 62 65 67 69 6e 0a 09 09 09 09 28 64 65 62 (begin.....(deb
2a10: 75 67 3a 70 72 69 6e 74 20 30 20 22 45 52 52 4f ug:print 0 "ERRO
2a20: 52 3a 20 6e 6f 6e 2d 65 78 69 73 74 65 6e 74 20 R: non-existent
2a30: 72 65 71 75 69 72 65 64 20 74 65 73 74 20 5c 22 required test \"
2a40: 22 20 68 65 64 20 22 5c 22 22 29 0a 20 20 20 20 " hed "\"").
2a50: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2a60: 20 20 20 20 20 20 20 20 20 20 20 20 28 69 66 20 (if
2a70: 64 62 20 28 73 71 6c 69 74 65 33 3a 66 69 6e 61 db (sqlite3:fina
2a80: 6c 69 7a 65 21 20 64 62 29 29 0a 09 09 09 09 28 lize! db)).....(
2a90: 65 78 69 74 20 31 29 29 29 29 29 0a 09 20 20 20 exit 1)))))..
2aa0: 20 3b 3b 20 63 68 65 63 6b 20 66 6f 72 20 68 65 ;; check for he
2ab0: 64 20 69 6e 20 77 61 69 74 6f 6e 73 20 3d 3e 20 d in waitons =>
2ac0: 74 68 69 73 20 77 6f 75 6c 64 20 62 65 20 63 69 this would be ci
2ad0: 72 63 75 6c 61 72 2c 20 72 65 6d 6f 76 65 20 69 rcular, remove i
2ae0: 74 20 61 6e 64 20 69 73 73 75 65 20 61 6e 0a 09 t and issue an..
2af0: 20 20 20 20 3b 3b 20 65 72 72 6f 72 0a 09 20 20 ;; error..
2b00: 20 20 28 69 66 20 28 6d 65 6d 62 65 72 20 68 65 (if (member he
2b10: 64 20 77 61 69 74 6f 6e 73 29 0a 09 09 28 62 65 d waitons)...(be
2b20: 67 69 6e 0a 09 09 20 20 28 64 65 62 75 67 3a 70 gin... (debug:p
2b30: 72 69 6e 74 20 30 20 22 45 52 52 4f 52 3a 20 74 rint 0 "ERROR: t
2b40: 65 73 74 20 22 20 68 65 64 20 22 20 68 61 73 20 est " hed " has
2b50: 6c 69 73 74 65 64 20 69 74 73 65 6c 66 20 61 73 listed itself as
2b60: 20 61 20 77 61 69 74 6f 6e 2c 20 70 6c 65 61 73 a waiton, pleas
2b70: 65 20 63 6f 72 72 65 63 74 20 74 68 69 73 21 22 e correct this!"
2b80: 29 0a 09 09 20 20 28 73 65 74 21 20 77 61 69 74 )... (set! wait
2b90: 6f 6e 73 20 28 66 69 6c 74 65 72 20 28 6c 61 6d ons (filter (lam
2ba0: 62 64 61 20 28 78 29 28 6e 6f 74 20 28 65 71 75 bda (x)(not (equ
2bb0: 61 6c 3f 20 78 20 68 65 64 29 29 29 20 77 61 69 al? x hed))) wai
2bc0: 74 6f 6e 73 29 29 29 29 0a 09 20 20 20 20 0a 09 tons)))).. ..
2bd0: 20 20 20 20 3b 3b 20 28 69 74 65 6d 73 20 20 20 ;; (items
2be0: 28 69 74 65 6d 73 3a 67 65 74 2d 69 74 65 6d 73 (items:get-items
2bf0: 2d 66 72 6f 6d 2d 63 6f 6e 66 69 67 20 63 6f 6e -from-config con
2c00: 66 69 67 29 29 29 0a 09 20 20 20 20 28 69 66 20 fig))).. (if
2c10: 28 6e 6f 74 20 28 68 61 73 68 2d 74 61 62 6c 65 (not (hash-table
2c20: 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 74 65 73 -ref/default tes
2c30: 74 2d 72 65 63 6f 72 64 73 20 68 65 64 20 23 66 t-records hed #f
2c40: 29 29 0a 09 09 28 68 61 73 68 2d 74 61 62 6c 65 ))...(hash-table
2c50: 2d 73 65 74 21 20 74 65 73 74 2d 72 65 63 6f 72 -set! test-recor
2c60: 64 73 0a 09 09 09 09 20 68 65 64 20 28 76 65 63 ds..... hed (vec
2c70: 74 6f 72 20 68 65 64 20 20 20 20 20 3b 3b 20 30 tor hed ;; 0
2c80: 0a 09 09 09 09 09 20 20 20 20 20 63 6f 6e 66 69 ...... confi
2c90: 67 20 20 3b 3b 20 31 0a 09 09 09 09 09 20 20 20 g ;; 1......
2ca0: 20 20 77 61 69 74 6f 6e 73 20 3b 3b 20 32 0a 09 waitons ;; 2..
2cb0: 09 09 09 09 20 20 20 20 20 28 63 6f 6e 66 69 67 .... (config
2cc0: 2d 6c 6f 6f 6b 75 70 20 63 6f 6e 66 69 67 20 22 -lookup config "
2cd0: 72 65 71 75 69 72 65 6d 65 6e 74 73 22 20 22 70 requirements" "p
2ce0: 72 69 6f 72 69 74 79 22 29 20 20 20 20 20 3b 3b riority") ;;
2cf0: 20 70 72 69 6f 72 69 74 79 20 33 0a 09 09 09 09 priority 3.....
2d00: 09 20 20 20 20 20 28 6c 65 74 20 28 28 69 74 65 . (let ((ite
2d10: 6d 73 20 20 20 20 20 20 28 68 61 73 68 2d 74 61 ms (hash-ta
2d20: 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 ble-ref/default
2d30: 63 6f 6e 66 69 67 20 22 69 74 65 6d 73 22 20 23 config "items" #
2d40: 66 29 29 20 3b 3b 20 69 74 65 6d 73 20 34 0a 09 f)) ;; items 4..
2d50: 09 09 09 09 09 20 20 20 28 69 74 65 6d 73 74 61 ..... (itemsta
2d60: 62 6c 65 20 28 68 61 73 68 2d 74 61 62 6c 65 2d ble (hash-table-
2d70: 72 65 66 2f 64 65 66 61 75 6c 74 20 63 6f 6e 66 ref/default conf
2d80: 69 67 20 22 69 74 65 6d 73 74 61 62 6c 65 22 20 ig "itemstable"
2d90: 23 66 29 29 29 20 0a 09 09 09 09 09 20 20 20 20 #f))) ......
2da0: 20 20 20 3b 3b 20 69 66 20 65 69 74 68 65 72 20 ;; if either
2db0: 69 74 65 6d 73 20 6f 72 20 69 74 65 6d 73 20 74 items or items t
2dc0: 61 62 6c 65 20 69 73 20 61 20 70 72 6f 63 20 72 able is a proc r
2dd0: 65 74 75 72 6e 20 69 74 20 73 6f 20 74 65 73 74 eturn it so test
2de0: 20 72 75 6e 6e 69 6e 67 0a 09 09 09 09 09 20 20 running......
2df0: 20 20 20 20 20 3b 3b 20 70 72 6f 63 65 73 73 20 ;; process
2e00: 63 61 6e 20 6b 6e 6f 77 20 74 6f 20 63 61 6c 6c can know to call
2e10: 20 69 74 65 6d 73 3a 67 65 74 2d 69 74 65 6d 73 items:get-items
2e20: 2d 66 72 6f 6d 2d 63 6f 6e 66 69 67 0a 09 09 09 -from-config....
2e30: 09 09 20 20 20 20 20 20 20 3b 3b 20 69 66 20 65 .. ;; if e
2e40: 69 74 68 65 72 20 69 73 20 61 20 6c 69 73 74 20 ither is a list
2e50: 61 6e 64 20 6e 6f 6e 65 20 69 73 20 61 20 70 72 and none is a pr
2e60: 6f 63 20 67 6f 20 61 68 65 61 64 20 61 6e 64 20 oc go ahead and
2e70: 63 61 6c 6c 20 67 65 74 2d 69 74 65 6d 73 0a 09 call get-items..
2e80: 09 09 09 09 20 20 20 20 20 20 20 3b 3b 20 6f 74 .... ;; ot
2e90: 68 65 72 77 69 73 65 20 72 65 74 75 72 6e 20 23 herwise return #
2ea0: 66 20 2d 20 74 68 69 73 20 69 73 20 6e 6f 74 20 f - this is not
2eb0: 61 6e 20 69 74 65 72 61 74 65 64 20 74 65 73 74 an iterated test
2ec0: 0a 09 09 09 09 09 20 20 20 20 20 20 20 28 63 6f ...... (co
2ed0: 6e 64 0a 09 09 09 09 09 09 28 28 70 72 6f 63 65 nd.......((proce
2ee0: 64 75 72 65 3f 20 69 74 65 6d 73 29 20 20 20 20 dure? items)
2ef0: 20 20 0a 09 09 09 09 09 09 20 28 64 65 62 75 67 ....... (debug
2f00: 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 34 20 22 69 :print-info 4 "i
2f10: 74 65 6d 73 20 69 73 20 61 20 70 72 6f 63 65 64 tems is a proced
2f20: 75 72 65 2c 20 77 69 6c 6c 20 63 61 6c 63 20 6c ure, will calc l
2f30: 61 74 65 72 22 29 0a 09 09 09 09 09 09 20 69 74 ater")....... it
2f40: 65 6d 73 29 20 20 20 20 20 20 20 20 20 20 20 20 ems)
2f50: 3b 3b 20 63 61 6c 63 20 6c 61 74 65 72 0a 09 09 ;; calc later...
2f60: 09 09 09 09 28 28 70 72 6f 63 65 64 75 72 65 3f ....((procedure?
2f70: 20 69 74 65 6d 73 74 61 62 6c 65 29 0a 09 09 09 itemstable)....
2f80: 09 09 09 20 28 64 65 62 75 67 3a 70 72 69 6e 74 ... (debug:print
2f90: 2d 69 6e 66 6f 20 34 20 22 69 74 65 6d 73 74 61 -info 4 "itemsta
2fa0: 62 6c 65 20 69 73 20 61 20 70 72 6f 63 65 64 75 ble is a procedu
2fb0: 72 65 2c 20 77 69 6c 6c 20 63 61 6c 63 20 6c 61 re, will calc la
2fc0: 74 65 72 22 29 0a 09 09 09 09 09 09 20 69 74 65 ter")....... ite
2fd0: 6d 73 74 61 62 6c 65 29 20 20 20 20 20 20 20 3b mstable) ;
2fe0: 3b 20 63 61 6c 63 20 6c 61 74 65 72 0a 09 09 09 ; calc later....
2ff0: 09 09 09 28 28 66 69 6c 74 65 72 20 28 6c 61 6d ...((filter (lam
3000: 62 64 61 20 28 78 29 0a 09 09 09 09 09 09 09 20 bda (x)........
3010: 20 20 28 6c 65 74 20 28 28 76 61 6c 20 28 63 61 (let ((val (ca
3020: 72 20 78 29 29 29 0a 09 09 09 09 09 09 09 20 20 r x)))........
3030: 20 20 20 28 69 66 20 28 70 72 6f 63 65 64 75 72 (if (procedur
3040: 65 3f 20 76 61 6c 29 20 76 61 6c 20 23 66 29 29 e? val) val #f))
3050: 29 0a 09 09 09 09 09 09 09 20 28 61 70 70 65 6e )........ (appen
3060: 64 20 28 69 66 20 28 6c 69 73 74 3f 20 69 74 65 d (if (list? ite
3070: 6d 73 29 20 69 74 65 6d 73 20 27 28 29 29 0a 09 ms) items '())..
3080: 09 09 09 09 09 09 09 20 28 69 66 20 28 6c 69 73 ....... (if (lis
3090: 74 3f 20 69 74 65 6d 73 74 61 62 6c 65 29 20 69 t? itemstable) i
30a0: 74 65 6d 73 74 61 62 6c 65 20 27 28 29 29 29 29 temstable '())))
30b0: 0a 09 09 09 09 09 09 20 27 68 61 76 65 2d 70 72 ....... 'have-pr
30c0: 6f 63 65 64 75 72 65 29 0a 09 09 09 09 09 09 28 ocedure).......(
30d0: 28 6f 72 20 28 6c 69 73 74 3f 20 69 74 65 6d 73 (or (list? items
30e0: 29 28 6c 69 73 74 3f 20 69 74 65 6d 73 74 61 62 )(list? itemstab
30f0: 6c 65 29 29 20 3b 3b 20 63 61 6c 63 20 6e 6f 77 le)) ;; calc now
3100: 0a 09 09 09 09 09 09 20 28 64 65 62 75 67 3a 70 ....... (debug:p
3110: 72 69 6e 74 2d 69 6e 66 6f 20 34 20 22 69 74 65 rint-info 4 "ite
3120: 6d 73 20 61 6e 64 20 69 74 65 6d 73 74 61 62 6c ms and itemstabl
3130: 65 20 61 72 65 20 6c 69 73 74 73 2c 20 63 61 6c e are lists, cal
3140: 63 20 6e 6f 77 5c 6e 22 0a 09 09 09 09 09 09 09 c now\n"........
3150: 20 20 20 20 20 20 22 20 20 20 20 69 74 65 6d 73 " items
3160: 3a 20 22 20 69 74 65 6d 73 20 22 20 69 74 65 6d : " items " item
3170: 73 74 61 62 6c 65 3a 20 22 20 69 74 65 6d 73 74 stable: " itemst
3180: 61 62 6c 65 29 0a 09 09 09 09 09 09 20 28 69 74 able)....... (it
3190: 65 6d 73 3a 67 65 74 2d 69 74 65 6d 73 2d 66 72 ems:get-items-fr
31a0: 6f 6d 2d 63 6f 6e 66 69 67 20 63 6f 6e 66 69 67 om-config config
31b0: 29 29 0a 09 09 09 09 09 09 28 65 6c 73 65 20 23 )).......(else #
31c0: 66 29 29 29 20 20 20 20 20 20 20 20 20 20 20 20 f)))
31d0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 3b ;
31e0: 3b 20 6e 6f 74 20 69 74 65 72 61 74 65 64 0a 09 ; not iterated..
31f0: 09 09 09 09 20 20 20 20 20 23 66 20 20 20 20 20 .... #f
3200: 20 3b 3b 20 69 74 65 6d 73 64 61 74 20 35 0a 09 ;; itemsdat 5..
3210: 09 09 09 09 20 20 20 20 20 23 66 20 20 20 20 20 .... #f
3220: 20 3b 3b 20 73 70 61 72 65 20 2d 20 75 73 65 64 ;; spare - used
3230: 20 66 6f 72 20 69 74 65 6d 2d 70 61 74 68 0a 09 for item-path..
3240: 09 09 09 09 20 20 20 20 20 29 29 29 0a 09 20 20 .... )))..
3250: 20 20 28 66 6f 72 2d 65 61 63 68 20 0a 09 20 20 (for-each ..
3260: 20 20 20 28 6c 61 6d 62 64 61 20 28 77 61 69 74 (lambda (wait
3270: 6f 6e 29 0a 09 20 20 20 20 20 20 20 28 69 66 20 on).. (if
3280: 28 61 6e 64 20 77 61 69 74 6f 6e 20 28 6e 6f 74 (and waiton (not
3290: 20 28 6d 65 6d 62 65 72 20 77 61 69 74 6f 6e 20 (member waiton
32a0: 74 65 73 74 2d 6e 61 6d 65 73 29 29 29 0a 09 09 test-names)))...
32b0: 20 20 20 28 62 65 67 69 6e 0a 09 09 20 20 20 20 (begin...
32c0: 20 28 73 65 74 21 20 72 65 71 75 69 72 65 64 2d (set! required-
32d0: 74 65 73 74 73 20 28 63 6f 6e 73 20 77 61 69 74 tests (cons wait
32e0: 6f 6e 20 72 65 71 75 69 72 65 64 2d 74 65 73 74 on required-test
32f0: 73 29 29 0a 09 09 20 20 20 20 20 28 73 65 74 21 s))... (set!
3300: 20 74 65 73 74 2d 6e 61 6d 65 73 20 28 63 6f 6e test-names (con
3310: 73 20 77 61 69 74 6f 6e 20 74 65 73 74 2d 6e 61 s waiton test-na
3320: 6d 65 73 29 29 29 29 29 20 3b 3b 20 77 61 73 20 mes))))) ;; was
3330: 61 6e 20 61 70 70 65 6e 64 2c 20 6e 6f 77 20 61 an append, now a
3340: 20 63 6f 6e 73 0a 09 20 20 20 20 20 77 61 69 74 cons.. wait
3350: 6f 6e 73 29 0a 09 20 20 20 20 28 6c 65 74 20 28 ons).. (let (
3360: 28 72 65 6d 74 65 73 74 73 20 28 64 65 6c 65 74 (remtests (delet
3370: 65 2d 64 75 70 6c 69 63 61 74 65 73 20 28 61 70 e-duplicates (ap
3380: 70 65 6e 64 20 77 61 69 74 6f 6e 73 20 74 61 6c pend waitons tal
3390: 29 29 29 29 0a 09 20 20 20 20 20 20 28 69 66 20 )))).. (if
33a0: 28 6e 6f 74 20 28 6e 75 6c 6c 3f 20 72 65 6d 74 (not (null? remt
33b0: 65 73 74 73 29 29 0a 09 09 20 20 28 6c 6f 6f 70 ests))... (loop
33c0: 20 28 63 61 72 20 72 65 6d 74 65 73 74 73 29 28 (car remtests)(
33d0: 63 64 72 20 72 65 6d 74 65 73 74 73 29 29 29 29 cdr remtests))))
33e0: 29 29 29 0a 0a 20 20 20 20 28 69 66 20 28 6e 6f ))).. (if (no
33f0: 74 20 28 6e 75 6c 6c 3f 20 72 65 71 75 69 72 65 t (null? require
3400: 64 2d 74 65 73 74 73 29 29 0a 09 28 64 65 62 75 d-tests))..(debu
3410: 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 31 20 22 g:print-info 1 "
3420: 41 64 64 69 6e 67 20 22 20 72 65 71 75 69 72 65 Adding " require
3430: 64 2d 74 65 73 74 73 20 22 20 74 6f 20 74 68 65 d-tests " to the
3440: 20 72 75 6e 20 71 75 65 75 65 22 29 29 0a 20 20 run queue")).
3450: 20 20 3b 3b 20 4e 4f 54 45 3a 20 74 68 65 73 65 ;; NOTE: these
3460: 20 61 72 65 20 61 6c 6c 20 70 61 72 65 6e 74 20 are all parent
3470: 74 65 73 74 73 2c 20 69 74 65 6d 73 20 61 72 65 tests, items are
3480: 20 6e 6f 74 20 65 78 70 61 6e 64 65 64 20 79 65 not expanded ye
3490: 74 2e 0a 20 20 20 20 28 64 65 62 75 67 3a 70 72 t.. (debug:pr
34a0: 69 6e 74 2d 69 6e 66 6f 20 34 20 22 74 65 73 74 int-info 4 "test
34b0: 2d 72 65 63 6f 72 64 73 3d 22 20 28 68 61 73 68 -records=" (hash
34c0: 2d 74 61 62 6c 65 2d 3e 61 6c 69 73 74 20 74 65 -table->alist te
34d0: 73 74 2d 72 65 63 6f 72 64 73 29 29 0a 20 20 20 st-records)).
34e0: 20 28 72 75 6e 73 3a 72 75 6e 2d 74 65 73 74 73 (runs:run-tests
34f0: 2d 71 75 65 75 65 20 72 75 6e 2d 69 64 20 72 75 -queue run-id ru
3500: 6e 6e 61 6d 65 20 74 65 73 74 2d 72 65 63 6f 72 nname test-recor
3510: 64 73 20 6b 65 79 76 61 6c 6c 73 74 20 66 6c 61 ds keyvallst fla
3520: 67 73 20 74 65 73 74 2d 70 61 74 74 73 29 0a 20 gs test-patts).
3530: 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d (debug:print-
3540: 69 6e 66 6f 20 34 20 22 41 6c 6c 20 64 6f 6e 65 info 4 "All done
3550: 20 62 79 20 68 65 72 65 22 29 29 29 0a 0a 28 64 by here")))..(d
3560: 65 66 69 6e 65 20 28 72 75 6e 73 3a 63 61 6c 63 efine (runs:calc
3570: 2d 66 61 69 6c 73 20 70 72 65 72 65 71 73 2d 6e -fails prereqs-n
3580: 6f 74 2d 6d 65 74 29 0a 20 20 28 66 69 6c 74 65 ot-met). (filte
3590: 72 20 28 6c 61 6d 62 64 61 20 28 74 65 73 74 29 r (lambda (test)
35a0: 0a 09 20 20 20 20 28 61 6e 64 20 28 76 65 63 74 .. (and (vect
35b0: 6f 72 3f 20 74 65 73 74 29 20 3b 3b 20 6e 6f 74 or? test) ;; not
35c0: 20 28 73 74 72 69 6e 67 3f 20 74 65 73 74 29 29 (string? test))
35d0: 0a 09 09 20 28 65 71 75 61 6c 3f 20 28 64 62 3a ... (equal? (db:
35e0: 74 65 73 74 2d 67 65 74 2d 73 74 61 74 65 20 74 test-get-state t
35f0: 65 73 74 29 20 22 43 4f 4d 50 4c 45 54 45 44 22 est) "COMPLETED"
3600: 29 0a 09 09 20 28 6e 6f 74 20 28 6d 65 6d 62 65 )... (not (membe
3610: 72 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 73 r (db:test-get-s
3620: 74 61 74 75 73 20 74 65 73 74 29 0a 09 09 09 20 tatus test)....
3630: 20 20 20 20 20 27 28 22 50 41 53 53 22 20 22 57 '("PASS" "W
3640: 41 52 4e 22 20 22 43 48 45 43 4b 22 20 22 57 41 ARN" "CHECK" "WA
3650: 49 56 45 44 22 29 29 29 29 29 0a 09 20 20 70 72 IVED"))))).. pr
3660: 65 72 65 71 73 2d 6e 6f 74 2d 6d 65 74 29 29 0a ereqs-not-met)).
3670: 0a 28 64 65 66 69 6e 65 20 28 72 75 6e 73 3a 63 .(define (runs:c
3680: 61 6c 63 2d 6e 6f 74 2d 63 6f 6d 70 6c 65 74 65 alc-not-complete
3690: 64 20 70 72 65 72 65 71 73 2d 6e 6f 74 2d 6d 65 d prereqs-not-me
36a0: 74 29 0a 20 20 28 66 69 6c 74 65 72 0a 20 20 20 t). (filter.
36b0: 28 6c 61 6d 62 64 61 20 28 74 29 0a 20 20 20 20 (lambda (t).
36c0: 20 28 6f 72 20 28 6e 6f 74 20 28 76 65 63 74 6f (or (not (vecto
36d0: 72 3f 20 74 29 29 0a 09 20 28 6e 6f 74 20 28 65 r? t)).. (not (e
36e0: 71 75 61 6c 3f 20 22 43 4f 4d 50 4c 45 54 45 44 qual? "COMPLETED
36f0: 22 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 73 " (db:test-get-s
3700: 74 61 74 65 20 74 29 29 29 29 29 0a 20 20 20 70 tate t))))). p
3710: 72 65 72 65 71 73 2d 6e 6f 74 2d 6d 65 74 29 29 rereqs-not-met))
3720: 0a 0a 28 64 65 66 69 6e 65 20 28 72 75 6e 73 3a ..(define (runs:
3730: 70 72 65 74 74 79 2d 73 74 72 69 6e 67 20 6c 73 pretty-string ls
3740: 74 29 0a 20 20 28 6d 61 70 20 28 6c 61 6d 62 64 t). (map (lambd
3750: 61 20 28 74 29 0a 09 20 28 69 66 20 28 6e 6f 74 a (t).. (if (not
3760: 20 28 76 65 63 74 6f 72 3f 20 74 29 29 0a 09 20 (vector? t))..
3770: 20 20 20 20 28 63 6f 6e 63 20 74 29 0a 09 20 20 (conc t)..
3780: 20 20 20 28 63 6f 6e 63 20 28 64 62 3a 74 65 73 (conc (db:tes
3790: 74 2d 67 65 74 2d 74 65 73 74 6e 61 6d 65 20 74 t-get-testname t
37a0: 29 20 22 3a 22 20 28 64 62 3a 74 65 73 74 2d 67 ) ":" (db:test-g
37b0: 65 74 2d 73 74 61 74 65 20 74 29 20 22 2f 22 20 et-state t) "/"
37c0: 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 73 74 61 (db:test-get-sta
37d0: 74 75 73 20 74 29 29 29 29 0a 20 20 20 20 20 20 tus t)))).
37e0: 20 6c 73 74 29 29 0a 0a 28 64 65 66 69 6e 65 20 lst))..(define
37f0: 28 72 75 6e 73 3a 6d 61 6b 65 2d 66 75 6c 6c 2d (runs:make-full-
3800: 74 65 73 74 2d 6e 61 6d 65 20 74 65 73 74 6e 61 test-name testna
3810: 6d 65 20 69 74 65 6d 70 61 74 68 29 0a 20 20 28 me itempath). (
3820: 69 66 20 28 65 71 75 61 6c 3f 20 69 74 65 6d 70 if (equal? itemp
3830: 61 74 68 20 22 22 29 20 74 65 73 74 6e 61 6d 65 ath "") testname
3840: 20 28 63 6f 6e 63 20 74 65 73 74 6e 61 6d 65 20 (conc testname
3850: 22 2f 22 20 69 74 65 6d 70 61 74 68 29 29 29 0a "/" itempath))).
3860: 0a 3b 3b 20 74 65 73 74 2d 72 65 63 6f 72 64 73 .;; test-records
3870: 20 69 73 20 61 20 68 61 73 68 20 74 61 62 6c 65 is a hash table
3880: 20 74 65 73 74 6e 61 6d 65 3a 69 74 65 6d 5f 70 testname:item_p
3890: 61 74 68 20 3d 3e 20 76 65 63 74 6f 72 20 3c 20 ath => vector <
38a0: 74 65 73 74 6e 61 6d 65 20 74 65 73 74 63 6f 6e testname testcon
38b0: 66 69 67 20 77 61 69 74 6f 6e 73 20 70 72 69 6f fig waitons prio
38c0: 72 69 74 79 20 69 74 65 6d 73 2d 69 6e 66 6f 20 rity items-info
38d0: 2e 2e 2e 20 3e 0a 28 64 65 66 69 6e 65 20 28 72 ... >.(define (r
38e0: 75 6e 73 3a 72 75 6e 2d 74 65 73 74 73 2d 71 75 uns:run-tests-qu
38f0: 65 75 65 20 72 75 6e 2d 69 64 20 72 75 6e 6e 61 eue run-id runna
3900: 6d 65 20 74 65 73 74 2d 72 65 63 6f 72 64 73 20 me test-records
3910: 6b 65 79 76 61 6c 6c 73 74 20 66 6c 61 67 73 20 keyvallst flags
3920: 74 65 73 74 2d 70 61 74 74 73 29 0a 20 20 20 20 test-patts).
3930: 3b 3b 20 41 74 20 74 68 69 73 20 70 6f 69 6e 74 ;; At this point
3940: 20 74 68 65 20 6c 69 73 74 20 6f 66 20 70 61 72 the list of par
3950: 65 6e 74 20 74 65 73 74 73 20 69 73 20 65 78 70 ent tests is exp
3960: 61 6e 64 65 64 20 0a 20 20 20 20 3b 3b 20 4e 42 anded . ;; NB
3970: 2f 2f 20 53 68 6f 75 6c 64 20 65 78 70 61 6e 64 // Should expand
3980: 20 69 74 65 6d 73 20 68 65 72 65 20 61 6e 64 20 items here and
3990: 74 68 65 6e 20 69 6e 73 65 72 74 20 69 6e 74 6f then insert into
39a0: 20 74 68 65 20 72 75 6e 20 71 75 65 75 65 2e 0a the run queue..
39b0: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 35 (debug:print 5
39c0: 20 22 74 65 73 74 2d 72 65 63 6f 72 64 73 3a 20 "test-records:
39d0: 22 20 74 65 73 74 2d 72 65 63 6f 72 64 73 20 22 " test-records "
39e0: 2c 20 6b 65 79 76 61 6c 6c 73 74 3a 20 22 20 6b , keyvallst: " k
39f0: 65 79 76 61 6c 6c 73 74 20 22 20 66 6c 61 67 73 eyvallst " flags
3a00: 3a 20 22 20 28 68 61 73 68 2d 74 61 62 6c 65 2d : " (hash-table-
3a10: 3e 61 6c 69 73 74 20 66 6c 61 67 73 29 29 0a 20 >alist flags)).
3a20: 20 28 6c 65 74 20 28 28 73 6f 72 74 65 64 2d 74 (let ((sorted-t
3a30: 65 73 74 2d 6e 61 6d 65 73 20 28 74 65 73 74 73 est-names (tests
3a40: 3a 73 6f 72 74 2d 62 79 2d 70 72 69 6f 72 69 74 :sort-by-priorit
3a50: 79 2d 61 6e 64 2d 77 61 69 74 6f 6e 20 74 65 73 y-and-waiton tes
3a60: 74 2d 72 65 63 6f 72 64 73 29 29 0a 09 28 74 65 t-records))..(te
3a70: 73 74 2d 72 65 67 69 73 74 65 72 79 20 20 20 20 st-registery
3a80: 28 6d 61 6b 65 2d 68 61 73 68 2d 74 61 62 6c 65 (make-hash-table
3a90: 29 29 0a 09 28 6e 75 6d 2d 72 65 74 72 69 65 73 ))..(num-retries
3aa0: 20 20 20 20 20 20 20 20 30 29 0a 09 28 6d 61 78 0)..(max
3ab0: 2d 72 65 74 72 69 65 73 20 20 20 20 20 20 20 28 -retries (
3ac0: 63 6f 6e 66 69 67 2d 6c 6f 6f 6b 75 70 20 2a 63 config-lookup *c
3ad0: 6f 6e 66 69 67 64 61 74 2a 20 22 73 65 74 75 70 onfigdat* "setup
3ae0: 22 20 22 6d 61 78 72 65 74 72 69 65 73 22 29 29 " "maxretries"))
3af0: 0a 09 28 64 6f 74 66 69 6c 65 70 20 20 20 20 20 ..(dotfilep
3b00: 20 20 20 20 20 28 69 66 20 28 61 72 67 73 3a 67 (if (args:g
3b10: 65 74 2d 61 72 67 20 22 2d 64 6f 74 66 69 6c 65 et-arg "-dotfile
3b20: 22 29 28 6f 70 65 6e 2d 6f 75 74 70 75 74 2d 66 ")(open-output-f
3b30: 69 6c 65 20 28 61 72 67 73 3a 67 65 74 2d 61 72 ile (args:get-ar
3b40: 67 20 22 2d 64 6f 74 66 69 6c 65 22 29 29 20 23 g "-dotfile")) #
3b50: 66 29 29 29 0a 20 20 20 20 28 73 65 74 21 20 6d f))). (set! m
3b60: 61 78 2d 72 65 74 72 69 65 73 20 28 69 66 20 28 ax-retries (if (
3b70: 61 6e 64 20 6d 61 78 2d 72 65 74 72 69 65 73 20 and max-retries
3b80: 28 73 74 72 69 6e 67 2d 3e 6e 75 6d 62 65 72 20 (string->number
3b90: 6d 61 78 2d 72 65 74 72 69 65 73 29 29 28 73 74 max-retries))(st
3ba0: 72 69 6e 67 2d 3e 6e 75 6d 62 65 72 20 6d 61 78 ring->number max
3bb0: 2d 72 65 74 72 69 65 73 29 20 31 30 30 29 29 0a -retries) 100)).
3bc0: 20 20 20 20 28 69 66 20 28 6e 6f 74 20 28 6e 75 (if (not (nu
3bd0: 6c 6c 3f 20 73 6f 72 74 65 64 2d 74 65 73 74 2d ll? sorted-test-
3be0: 6e 61 6d 65 73 29 29 0a 09 28 6c 65 74 20 6c 6f names))..(let lo
3bf0: 6f 70 20 28 28 68 65 64 20 20 20 20 20 20 20 20 op ((hed
3c00: 20 28 63 61 72 20 73 6f 72 74 65 64 2d 74 65 73 (car sorted-tes
3c10: 74 2d 6e 61 6d 65 73 29 29 0a 09 09 20 20 20 28 t-names))... (
3c20: 74 61 6c 20 20 20 20 20 20 20 20 20 28 63 64 72 tal (cdr
3c30: 20 73 6f 72 74 65 64 2d 74 65 73 74 2d 6e 61 6d sorted-test-nam
3c40: 65 73 29 29 0a 09 09 20 20 20 28 72 65 72 75 6e es))... (rerun
3c50: 73 20 20 20 20 20 20 27 28 29 29 29 0a 09 20 20 s '()))..
3c60: 28 69 66 20 28 6e 6f 74 20 28 6e 75 6c 6c 3f 20 (if (not (null?
3c70: 72 65 72 75 6e 73 29 29 28 64 65 62 75 67 3a 70 reruns))(debug:p
3c80: 72 69 6e 74 2d 69 6e 66 6f 20 34 20 22 72 65 72 rint-info 4 "rer
3c90: 75 6e 73 3d 22 20 72 65 72 75 6e 73 29 29 0a 09 uns=" reruns))..
3ca0: 20 20 3b 3b 20 28 70 72 69 6e 74 20 22 54 6f 70 ;; (print "Top
3cb0: 20 6f 66 20 6c 6f 6f 70 2c 20 68 65 64 3d 22 20 of loop, hed="
3cc0: 68 65 64 20 22 2c 20 74 61 6c 3d 22 20 74 61 6c hed ", tal=" tal
3cd0: 20 22 20 2c 72 65 72 75 6e 73 3d 22 20 72 65 72 " ,reruns=" rer
3ce0: 75 6e 73 29 0a 09 20 20 28 6c 65 74 2a 20 28 28 uns).. (let* ((
3cf0: 74 65 73 74 2d 72 65 63 6f 72 64 20 28 68 61 73 test-record (has
3d00: 68 2d 74 61 62 6c 65 2d 72 65 66 20 74 65 73 74 h-table-ref test
3d10: 2d 72 65 63 6f 72 64 73 20 68 65 64 29 29 0a 09 -records hed))..
3d20: 09 20 28 74 65 73 74 2d 6e 61 6d 65 20 20 20 28 . (test-name (
3d30: 74 65 73 74 73 3a 74 65 73 74 71 75 65 75 65 2d tests:testqueue-
3d40: 67 65 74 2d 74 65 73 74 6e 61 6d 65 20 74 65 73 get-testname tes
3d50: 74 2d 72 65 63 6f 72 64 29 29 0a 09 09 20 28 74 t-record))... (t
3d60: 63 6f 6e 66 69 67 20 20 20 20 20 28 74 65 73 74 config (test
3d70: 73 3a 74 65 73 74 71 75 65 75 65 2d 67 65 74 2d s:testqueue-get-
3d80: 74 65 73 74 63 6f 6e 66 69 67 20 74 65 73 74 2d testconfig test-
3d90: 72 65 63 6f 72 64 29 29 0a 09 09 20 28 74 65 73 record))... (tes
3da0: 74 6d 6f 64 65 20 20 20 20 28 6c 65 74 20 28 28 tmode (let ((
3db0: 6d 20 28 63 6f 6e 66 69 67 2d 6c 6f 6f 6b 75 70 m (config-lookup
3dc0: 20 74 63 6f 6e 66 69 67 20 22 72 65 71 75 69 72 tconfig "requir
3dd0: 65 6d 65 6e 74 73 22 20 22 6d 6f 64 65 22 29 29 ements" "mode"))
3de0: 29 0a 09 09 09 09 28 69 66 20 6d 20 28 73 74 72 ).....(if m (str
3df0: 69 6e 67 2d 3e 73 79 6d 62 6f 6c 20 6d 29 20 27 ing->symbol m) '
3e00: 6e 6f 72 6d 61 6c 29 29 29 0a 09 09 20 28 77 61 normal)))... (wa
3e10: 69 74 6f 6e 73 20 20 20 20 20 28 74 65 73 74 73 itons (tests
3e20: 3a 74 65 73 74 71 75 65 75 65 2d 67 65 74 2d 77 :testqueue-get-w
3e30: 61 69 74 6f 6e 73 20 20 20 20 74 65 73 74 2d 72 aitons test-r
3e40: 65 63 6f 72 64 29 29 0a 09 09 20 28 70 72 69 6f ecord))... (prio
3e50: 72 69 74 79 20 20 20 20 28 74 65 73 74 73 3a 74 rity (tests:t
3e60: 65 73 74 71 75 65 75 65 2d 67 65 74 2d 70 72 69 estqueue-get-pri
3e70: 6f 72 69 74 79 20 20 20 74 65 73 74 2d 72 65 63 ority test-rec
3e80: 6f 72 64 29 29 0a 09 09 20 28 69 74 65 6d 64 61 ord))... (itemda
3e90: 74 20 20 20 20 20 28 74 65 73 74 73 3a 74 65 73 t (tests:tes
3ea0: 74 71 75 65 75 65 2d 67 65 74 2d 69 74 65 6d 64 tqueue-get-itemd
3eb0: 61 74 20 20 20 20 74 65 73 74 2d 72 65 63 6f 72 at test-recor
3ec0: 64 29 29 20 3b 3b 20 69 74 65 6d 64 61 74 20 63 d)) ;; itemdat c
3ed0: 61 6e 20 62 65 20 61 20 73 74 72 69 6e 67 2c 20 an be a string,
3ee0: 6c 69 73 74 20 6f 72 20 23 66 0a 09 09 20 28 69 list or #f... (i
3ef0: 74 65 6d 73 20 20 20 20 20 20 20 28 74 65 73 74 tems (test
3f00: 73 3a 74 65 73 74 71 75 65 75 65 2d 67 65 74 2d s:testqueue-get-
3f10: 69 74 65 6d 73 20 20 20 20 20 20 74 65 73 74 2d items test-
3f20: 72 65 63 6f 72 64 29 29 0a 09 09 20 28 69 74 65 record))... (ite
3f30: 6d 2d 70 61 74 68 20 20 20 28 69 74 65 6d 2d 6c m-path (item-l
3f40: 69 73 74 2d 3e 70 61 74 68 20 69 74 65 6d 64 61 ist->path itemda
3f50: 74 29 29 0a 09 09 20 28 6e 65 77 74 61 6c 20 20 t))... (newtal
3f60: 20 20 20 20 28 61 70 70 65 6e 64 20 74 61 6c 20 (append tal
3f70: 28 6c 69 73 74 20 68 65 64 29 29 29 29 0a 09 20 (list hed))))..
3f80: 20 20 20 0a 09 20 20 20 20 28 64 65 62 75 67 3a .. (debug:
3f90: 70 72 69 6e 74 20 36 0a 09 09 09 20 22 74 65 73 print 6.... "tes
3fa0: 74 2d 6e 61 6d 65 3a 20 22 20 74 65 73 74 2d 6e t-name: " test-n
3fb0: 61 6d 65 0a 09 09 09 20 22 5c 6e 20 20 68 65 64 ame.... "\n hed
3fc0: 3a 20 20 20 20 20 20 20 20 20 22 20 68 65 64 0a : " hed.
3fd0: 09 09 09 20 22 5c 6e 20 20 69 74 65 6d 64 61 74 ... "\n itemdat
3fe0: 3a 20 20 20 20 20 22 20 69 74 65 6d 64 61 74 0a : " itemdat.
3ff0: 09 09 09 20 22 5c 6e 20 20 69 74 65 6d 73 3a 20 ... "\n items:
4000: 20 20 20 20 20 20 22 20 69 74 65 6d 73 0a 09 09 " items...
4010: 09 20 22 5c 6e 20 20 69 74 65 6d 2d 70 61 74 68 . "\n item-path
4020: 3a 20 20 20 22 20 69 74 65 6d 2d 70 61 74 68 0a : " item-path.
4030: 09 09 09 20 22 5c 6e 20 20 77 61 69 74 6f 6e 73 ... "\n waitons
4040: 3a 20 20 20 20 20 22 20 77 61 69 74 6f 6e 73 0a : " waitons.
4050: 09 09 09 20 22 5c 6e 20 20 6e 75 6d 2d 72 65 74 ... "\n num-ret
4060: 72 69 65 73 3a 20 22 20 6e 75 6d 2d 72 65 74 72 ries: " num-retr
4070: 69 65 73 0a 09 09 09 20 22 5c 6e 20 20 74 61 6c ies.... "\n tal
4080: 3a 20 20 20 20 20 20 20 20 20 22 20 74 61 6c 0a : " tal.
4090: 09 09 09 20 22 5c 6e 20 20 72 65 72 75 6e 73 3a ... "\n reruns:
40a0: 20 20 20 20 20 20 22 20 72 65 72 75 6e 73 29 0a " reruns).
40b0: 0a 09 20 20 20 20 3b 3b 20 63 68 65 63 6b 20 66 .. ;; check f
40c0: 6f 72 20 68 65 64 20 69 6e 20 77 61 69 74 6f 6e or hed in waiton
40d0: 73 20 3d 3e 20 74 68 69 73 20 77 6f 75 6c 64 20 s => this would
40e0: 62 65 20 63 69 72 63 75 6c 61 72 2c 20 72 65 6d be circular, rem
40f0: 6f 76 65 20 69 74 20 61 6e 64 20 69 73 73 75 65 ove it and issue
4100: 20 61 6e 0a 09 20 20 20 20 3b 3b 20 65 72 72 6f an.. ;; erro
4110: 72 0a 09 20 20 20 20 28 69 66 20 28 6d 65 6d 62 r.. (if (memb
4120: 65 72 20 74 65 73 74 2d 6e 61 6d 65 20 77 61 69 er test-name wai
4130: 74 6f 6e 73 29 0a 09 09 28 62 65 67 69 6e 0a 09 tons)...(begin..
4140: 09 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 . (debug:print
4150: 30 20 22 45 52 52 4f 52 3a 20 74 65 73 74 20 22 0 "ERROR: test "
4160: 20 74 65 73 74 2d 6e 61 6d 65 20 22 20 68 61 73 test-name " has
4170: 20 6c 69 73 74 65 64 20 69 74 73 65 6c 66 20 61 listed itself a
4180: 73 20 61 20 77 61 69 74 6f 6e 2c 20 70 6c 65 61 s a waiton, plea
4190: 73 65 20 63 6f 72 72 65 63 74 20 74 68 69 73 21 se correct this!
41a0: 22 29 0a 09 09 20 20 28 73 65 74 21 20 77 61 69 ")... (set! wai
41b0: 74 6f 6e 20 28 66 69 6c 74 65 72 20 28 6c 61 6d ton (filter (lam
41c0: 62 64 61 20 28 78 29 28 6e 6f 74 20 28 65 71 75 bda (x)(not (equ
41d0: 61 6c 3f 20 78 20 68 65 64 29 29 29 20 77 61 69 al? x hed))) wai
41e0: 74 6f 6e 73 29 29 29 29 0a 0a 09 20 20 20 20 28 tons))))... (
41f0: 63 6f 6e 64 20 3b 3b 20 4f 55 54 45 52 20 43 4f cond ;; OUTER CO
4200: 4e 44 0a 09 20 20 20 20 20 28 28 6e 6f 74 20 69 ND.. ((not i
4210: 74 65 6d 73 29 20 3b 3b 20 77 68 65 6e 20 66 61 tems) ;; when fa
4220: 6c 73 65 20 74 68 65 20 74 65 73 74 20 69 73 20 lse the test is
4230: 6f 6b 20 74 6f 20 62 65 20 68 61 6e 64 65 64 20 ok to be handed
4240: 6f 66 66 20 74 6f 20 6c 61 75 6e 63 68 20 28 62 off to launch (b
4250: 75 74 20 6e 6f 74 20 62 65 66 6f 72 65 29 0a 09 ut not before)..
4260: 20 20 20 20 20 20 28 6c 65 74 2a 20 28 28 72 75 (let* ((ru
4270: 6e 2d 6c 69 6d 69 74 73 2d 69 6e 66 6f 20 20 20 n-limits-info
4280: 20 20 20 20 20 20 28 6f 70 65 6e 2d 72 75 6e 2d (open-run-
4290: 63 6c 6f 73 65 20 72 75 6e 73 3a 63 61 6e 2d 72 close runs:can-r
42a0: 75 6e 2d 6d 6f 72 65 2d 74 65 73 74 73 20 74 65 un-more-tests te
42b0: 73 74 2d 72 65 63 6f 72 64 29 29 20 3b 3b 20 6c st-record)) ;; l
42c0: 6f 6f 6b 20 61 74 20 74 68 65 20 74 65 73 74 20 ook at the test
42d0: 6a 6f 62 67 72 6f 75 70 20 61 6e 64 20 74 6f 74 jobgroup and tot
42e0: 20 6a 6f 62 73 20 72 75 6e 6e 69 6e 67 0a 09 09 jobs running...
42f0: 20 20 20 20 20 28 68 61 76 65 2d 72 65 73 6f 75 (have-resou
4300: 72 63 65 73 20 20 20 20 20 20 20 20 20 20 28 63 rces (c
4310: 61 72 20 72 75 6e 2d 6c 69 6d 69 74 73 2d 69 6e ar run-limits-in
4320: 66 6f 29 29 0a 09 09 20 20 20 20 20 28 6e 75 6d fo))... (num
4330: 2d 72 75 6e 6e 69 6e 67 20 20 20 20 20 20 20 20 -running
4340: 20 20 20 20 20 28 6c 69 73 74 2d 72 65 66 20 72 (list-ref r
4350: 75 6e 2d 6c 69 6d 69 74 73 2d 69 6e 66 6f 20 31 un-limits-info 1
4360: 29 29 0a 09 09 20 20 20 20 20 28 6e 75 6d 2d 72 ))... (num-r
4370: 75 6e 6e 69 6e 67 2d 69 6e 2d 6a 6f 62 67 72 6f unning-in-jobgro
4380: 75 70 20 28 6c 69 73 74 2d 72 65 66 20 72 75 6e up (list-ref run
4390: 2d 6c 69 6d 69 74 73 2d 69 6e 66 6f 20 32 29 29 -limits-info 2))
43a0: 0a 09 09 20 20 20 20 20 28 6d 61 78 2d 63 6f 6e ... (max-con
43b0: 63 75 72 72 65 6e 74 2d 6a 6f 62 73 20 20 20 20 current-jobs
43c0: 20 28 6c 69 73 74 2d 72 65 66 20 72 75 6e 2d 6c (list-ref run-l
43d0: 69 6d 69 74 73 2d 69 6e 66 6f 20 33 29 29 0a 09 imits-info 3))..
43e0: 09 20 20 20 20 20 28 6a 6f 62 2d 67 72 6f 75 70 . (job-group
43f0: 2d 6c 69 6d 69 74 20 20 20 20 20 20 20 20 20 28 -limit (
4400: 6c 69 73 74 2d 72 65 66 20 72 75 6e 2d 6c 69 6d list-ref run-lim
4410: 69 74 73 2d 69 6e 66 6f 20 34 29 29 0a 09 09 20 its-info 4))...
4420: 20 20 20 20 28 70 72 65 72 65 71 73 2d 6e 6f 74 (prereqs-not
4430: 2d 6d 65 74 20 20 20 20 20 20 20 20 20 28 6f 70 -met (op
4440: 65 6e 2d 72 75 6e 2d 63 6c 6f 73 65 20 64 62 3a en-run-close db:
4450: 67 65 74 2d 70 72 65 72 65 71 73 2d 6e 6f 74 2d get-prereqs-not-
4460: 6d 65 74 20 23 66 20 72 75 6e 2d 69 64 20 77 61 met #f run-id wa
4470: 69 74 6f 6e 73 20 69 74 65 6d 2d 70 61 74 68 20 itons item-path
4480: 6d 6f 64 65 3a 20 74 65 73 74 6d 6f 64 65 29 29 mode: testmode))
4490: 0a 09 09 20 20 20 20 20 28 66 61 69 6c 73 20 20 ... (fails
44a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
44b0: 20 28 72 75 6e 73 3a 63 61 6c 63 2d 66 61 69 6c (runs:calc-fail
44c0: 73 20 70 72 65 72 65 71 73 2d 6e 6f 74 2d 6d 65 s prereqs-not-me
44d0: 74 29 29 0a 09 09 20 20 20 20 20 28 6e 6f 6e 2d t))... (non-
44e0: 63 6f 6d 70 6c 65 74 65 64 20 20 20 20 20 20 20 completed
44f0: 20 20 20 20 28 72 75 6e 73 3a 63 61 6c 63 2d 6e (runs:calc-n
4500: 6f 74 2d 63 6f 6d 70 6c 65 74 65 64 20 70 72 65 ot-completed pre
4510: 72 65 71 73 2d 6e 6f 74 2d 6d 65 74 29 29 29 0a reqs-not-met))).
4520: 09 09 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 ..(debug:print-i
4530: 6e 66 6f 20 38 20 22 68 61 76 65 2d 72 65 73 6f nfo 8 "have-reso
4540: 75 72 63 65 73 3a 20 22 20 68 61 76 65 2d 72 65 urces: " have-re
4550: 73 6f 75 72 63 65 73 20 22 20 70 72 65 72 65 71 sources " prereq
4560: 73 2d 6e 6f 74 2d 6d 65 74 3a 20 22 20 0a 09 09 s-not-met: " ...
4570: 09 20 20 20 20 20 28 73 74 72 69 6e 67 2d 69 6e . (string-in
4580: 74 65 72 73 70 65 72 73 65 20 0a 09 09 09 20 20 tersperse ....
4590: 20 20 20 20 28 6d 61 70 20 28 6c 61 6d 62 64 61 (map (lambda
45a0: 20 28 74 29 0a 09 09 09 09 20 20 20 20 20 28 69 (t)..... (i
45b0: 66 20 28 76 65 63 74 6f 72 3f 20 74 29 0a 09 09 f (vector? t)...
45c0: 09 09 09 20 28 63 6f 6e 63 20 28 64 62 3a 74 65 ... (conc (db:te
45d0: 73 74 2d 67 65 74 2d 73 74 61 74 65 20 74 29 20 st-get-state t)
45e0: 22 2f 22 20 28 64 62 3a 74 65 73 74 2d 67 65 74 "/" (db:test-get
45f0: 2d 73 74 61 74 75 73 20 74 29 29 0a 09 09 09 09 -status t)).....
4600: 09 20 28 63 6f 6e 63 20 22 20 57 41 52 4e 49 4e . (conc " WARNIN
4610: 47 3a 20 74 20 69 73 20 6e 6f 74 20 61 20 76 65 G: t is not a ve
4620: 63 74 6f 72 3d 22 20 74 20 29 29 29 0a 09 09 09 ctor=" t )))....
4630: 09 20 20 20 70 72 65 72 65 71 73 2d 6e 6f 74 2d . prereqs-not-
4640: 6d 65 74 29 20 22 2c 20 22 29 20 22 20 66 61 69 met) ", ") " fai
4650: 6c 73 3a 20 22 20 66 61 69 6c 73 29 0a 09 09 28 ls: " fails)...(
4660: 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f debug:print-info
4670: 20 34 20 22 68 65 64 3d 22 20 68 65 64 20 22 5c 4 "hed=" hed "\
4680: 6e 20 20 74 65 73 74 2d 72 65 63 6f 72 64 3d 22 n test-record="
4690: 20 74 65 73 74 2d 72 65 63 6f 72 64 20 22 5c 6e test-record "\n
46a0: 20 20 74 65 73 74 2d 6e 61 6d 65 3a 20 22 20 74 test-name: " t
46b0: 65 73 74 2d 6e 61 6d 65 20 22 5c 6e 20 20 69 74 est-name "\n it
46c0: 65 6d 2d 70 61 74 68 3a 20 22 20 69 74 65 6d 2d em-path: " item-
46d0: 70 61 74 68 20 22 5c 6e 20 20 74 65 73 74 2d 70 path "\n test-p
46e0: 61 74 74 73 3a 20 22 20 74 65 73 74 2d 70 61 74 atts: " test-pat
46f0: 74 73 29 0a 0a 09 09 3b 3b 20 44 6f 6e 27 74 20 ts)....;; Don't
4700: 6b 6e 6f 77 20 61 74 20 74 68 69 73 20 74 69 6d know at this tim
4710: 65 20 69 66 20 74 68 65 20 74 65 73 74 20 68 61 e if the test ha
4720: 76 65 20 62 65 65 6e 20 6c 61 75 6e 63 68 65 64 ve been launched
4730: 20 61 74 20 73 6f 6d 65 20 74 69 6d 65 20 69 6e at some time in
4740: 20 74 68 65 20 70 61 73 74 0a 09 09 3b 3b 20 69 the past...;; i
4750: 2e 65 2e 20 69 73 20 74 68 69 73 20 61 20 72 65 .e. is this a re
4760: 2d 6c 61 75 6e 63 68 3f 0a 09 09 28 64 65 62 75 -launch?...(debu
4770: 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 34 20 22 g:print-info 4 "
4780: 72 75 6e 2d 6c 69 6d 69 74 73 2d 69 6e 66 6f 20 run-limits-info
4790: 3d 20 22 20 72 75 6e 2d 6c 69 6d 69 74 73 2d 69 = " run-limits-i
47a0: 6e 66 6f 29 0a 09 09 28 63 6f 6e 64 20 3b 3b 20 nfo)...(cond ;;
47b0: 49 4e 4e 45 52 20 43 4f 4e 44 20 23 31 20 66 6f INNER COND #1 fo
47c0: 72 20 61 20 6c 61 75 6e 63 68 61 62 6c 65 20 74 r a launchable t
47d0: 65 73 74 0a 09 09 20 3b 3b 20 43 68 65 63 6b 20 est... ;; Check
47e0: 69 74 65 6d 20 70 61 74 68 20 61 67 61 69 6e 73 item path agains
47f0: 74 20 69 74 65 6d 2d 70 61 74 74 73 0a 09 09 20 t item-patts...
4800: 28 28 6e 6f 74 20 28 74 65 73 74 73 3a 6d 61 74 ((not (tests:mat
4810: 63 68 20 74 65 73 74 2d 70 61 74 74 73 20 28 74 ch test-patts (t
4820: 65 73 74 73 3a 74 65 73 74 71 75 65 75 65 2d 67 ests:testqueue-g
4830: 65 74 2d 74 65 73 74 6e 61 6d 65 20 74 65 73 74 et-testname test
4840: 2d 72 65 63 6f 72 64 29 20 69 74 65 6d 2d 70 61 -record) item-pa
4850: 74 68 29 29 20 3b 3b 20 54 68 69 73 20 74 65 73 th)) ;; This tes
4860: 74 2f 69 74 65 6d 70 61 74 68 20 69 73 20 6e 6f t/itempath is no
4870: 74 20 74 6f 20 62 65 20 72 75 6e 0a 09 09 20 20 t to be run...
4880: 3b 3b 20 65 6c 73 65 20 74 68 65 20 72 75 6e 20 ;; else the run
4890: 69 73 20 73 74 75 63 6b 2c 20 74 65 6d 70 6f 72 is stuck, tempor
48a0: 61 72 69 6c 79 20 6f 72 20 70 65 72 6d 61 6e 65 arily or permane
48b0: 6e 74 6c 79 0a 09 09 20 20 3b 3b 20 62 75 74 20 ntly... ;; but
48c0: 73 68 6f 75 6c 64 20 63 68 65 63 6b 20 69 66 20 should check if
48d0: 69 74 20 69 73 20 64 75 65 20 74 6f 20 6c 61 63 it is due to lac
48e0: 6b 20 6f 66 20 72 65 73 6f 75 72 63 65 73 20 76 k of resources v
48f0: 73 2e 20 70 72 65 72 65 71 75 69 73 69 74 65 73 s. prerequisites
4900: 0a 09 09 20 20 28 64 65 62 75 67 3a 70 72 69 6e ... (debug:prin
4910: 74 2d 69 6e 66 6f 20 31 20 22 53 6b 69 70 70 69 t-info 1 "Skippi
4920: 6e 67 20 22 20 28 74 65 73 74 73 3a 74 65 73 74 ng " (tests:test
4930: 71 75 65 75 65 2d 67 65 74 2d 74 65 73 74 6e 61 queue-get-testna
4940: 6d 65 20 74 65 73 74 2d 72 65 63 6f 72 64 29 20 me test-record)
4950: 22 20 22 20 69 74 65 6d 2d 70 61 74 68 20 22 20 " " item-path "
4960: 61 73 20 69 74 20 64 6f 65 73 6e 27 74 20 6d 61 as it doesn't ma
4970: 74 63 68 20 22 20 74 65 73 74 2d 70 61 74 74 73 tch " test-patts
4980: 29 0a 09 09 20 20 28 74 68 72 65 61 64 2d 73 6c )... (thread-sl
4990: 65 65 70 21 20 2a 67 6c 6f 62 61 6c 2d 64 65 6c eep! *global-del
49a0: 74 61 2a 29 0a 09 09 20 20 28 69 66 20 28 6e 6f ta*)... (if (no
49b0: 74 20 28 6e 75 6c 6c 3f 20 74 61 6c 29 29 0a 09 t (null? tal))..
49c0: 09 20 20 20 20 20 20 28 6c 6f 6f 70 20 28 63 61 . (loop (ca
49d0: 72 20 74 61 6c 29 28 63 64 72 20 74 61 6c 29 20 r tal)(cdr tal)
49e0: 72 65 72 75 6e 73 29 29 29 0a 09 09 20 28 20 3b reruns)))... ( ;
49f0: 3b 20 28 61 6e 64 0a 09 09 20 20 28 6e 6f 74 20 ; (and... (not
4a00: 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f (hash-table-ref/
4a10: 64 65 66 61 75 6c 74 20 74 65 73 74 2d 72 65 67 default test-reg
4a20: 69 73 74 65 72 79 20 28 72 75 6e 73 3a 6d 61 6b istery (runs:mak
4a30: 65 2d 66 75 6c 6c 2d 74 65 73 74 2d 6e 61 6d 65 e-full-test-name
4a40: 20 74 65 73 74 2d 6e 61 6d 65 20 69 74 65 6d 2d test-name item-
4a50: 70 61 74 68 29 20 23 66 29 29 0a 09 09 20 20 20 path) #f))...
4a60: 20 20 20 3b 3b 20 28 61 6e 64 20 6d 61 78 2d 63 ;; (and max-c
4a70: 6f 6e 63 75 72 72 65 6e 74 2d 6a 6f 62 73 20 28 oncurrent-jobs (
4a80: 3e 20 28 2d 20 6d 61 78 2d 63 6f 6e 63 75 72 72 > (- max-concurr
4a90: 65 6e 74 2d 6a 6f 62 73 20 6e 75 6d 2d 72 75 6e ent-jobs num-run
4aa0: 6e 69 6e 67 29 20 35 29 29 29 0a 09 09 20 20 28 ning) 5)))... (
4ab0: 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f debug:print-info
4ac0: 20 34 20 22 50 72 65 2d 72 65 67 69 73 74 65 72 4 "Pre-register
4ad0: 69 6e 67 20 74 65 73 74 20 22 20 74 65 73 74 2d ing test " test-
4ae0: 6e 61 6d 65 20 22 2f 22 20 69 74 65 6d 2d 70 61 name "/" item-pa
4af0: 74 68 20 22 20 74 6f 20 63 72 65 61 74 65 20 70 th " to create p
4b00: 6c 61 63 65 68 6f 6c 64 65 72 22 20 29 0a 09 09 laceholder" )...
4b10: 20 20 28 6f 70 65 6e 2d 72 75 6e 2d 63 6c 6f 73 (open-run-clos
4b20: 65 20 64 62 3a 74 65 73 74 73 2d 72 65 67 69 73 e db:tests-regis
4b30: 74 65 72 2d 74 65 73 74 20 23 66 20 72 75 6e 2d ter-test #f run-
4b40: 69 64 20 74 65 73 74 2d 6e 61 6d 65 20 69 74 65 id test-name ite
4b50: 6d 2d 70 61 74 68 29 0a 09 09 20 20 28 68 61 73 m-path)... (has
4b60: 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 74 65 73 h-table-set! tes
4b70: 74 2d 72 65 67 69 73 74 65 72 79 20 28 72 75 6e t-registery (run
4b80: 73 3a 6d 61 6b 65 2d 66 75 6c 6c 2d 74 65 73 74 s:make-full-test
4b90: 2d 6e 61 6d 65 20 74 65 73 74 2d 6e 61 6d 65 20 -name test-name
4ba0: 69 74 65 6d 2d 70 61 74 68 29 20 23 74 29 0a 09 item-path) #t)..
4bb0: 09 20 20 28 74 68 72 65 61 64 2d 73 6c 65 65 70 . (thread-sleep
4bc0: 21 20 2a 67 6c 6f 62 61 6c 2d 64 65 6c 74 61 2a ! *global-delta*
4bd0: 29 0a 09 09 20 20 28 6c 6f 6f 70 20 28 63 61 72 )... (loop (car
4be0: 20 6e 65 77 74 61 6c 29 28 63 64 72 20 6e 65 77 newtal)(cdr new
4bf0: 74 61 6c 29 20 72 65 72 75 6e 73 29 29 0a 09 09 tal) reruns))...
4c00: 20 28 28 6e 6f 74 20 68 61 76 65 2d 72 65 73 6f ((not have-reso
4c10: 75 72 63 65 73 29 20 3b 3b 20 73 69 6d 70 6c 79 urces) ;; simply
4c20: 20 74 72 79 20 61 67 61 69 6e 20 61 66 74 65 72 try again after
4c30: 20 77 61 69 74 69 6e 67 20 61 20 73 65 63 6f 6e waiting a secon
4c40: 64 0a 09 09 20 20 28 64 65 62 75 67 3a 70 72 69 d... (debug:pri
4c50: 6e 74 2d 69 6e 66 6f 20 31 20 22 6e 6f 20 72 65 nt-info 1 "no re
4c60: 73 6f 75 72 63 65 73 20 74 6f 20 72 75 6e 20 6e sources to run n
4c70: 65 77 20 74 65 73 74 73 2c 20 77 61 69 74 69 6e ew tests, waitin
4c80: 67 20 2e 2e 2e 22 29 0a 09 09 20 20 28 74 68 72 g ...")... (thr
4c90: 65 61 64 2d 73 6c 65 65 70 21 20 28 2b 20 32 20 ead-sleep! (+ 2
4ca0: 2a 67 6c 6f 62 61 6c 2d 64 65 6c 74 61 2a 29 29 *global-delta*))
4cb0: 0a 09 09 20 20 3b 3b 20 63 6f 75 6c 64 20 68 61 ... ;; could ha
4cc0: 76 65 20 64 6f 6e 65 20 68 65 64 20 74 61 6c 20 ve done hed tal
4cd0: 68 65 72 65 20 62 75 74 20 64 6f 69 6e 67 20 63 here but doing c
4ce0: 61 72 2f 63 64 72 20 6f 66 20 6e 65 77 74 61 6c ar/cdr of newtal
4cf0: 20 74 6f 20 72 6f 74 61 74 65 20 74 65 73 74 73 to rotate tests
4d00: 0a 09 09 20 20 28 6c 6f 6f 70 20 28 63 61 72 20 ... (loop (car
4d10: 6e 65 77 74 61 6c 29 28 63 64 72 20 6e 65 77 74 newtal)(cdr newt
4d20: 61 6c 29 20 72 65 72 75 6e 73 29 29 0a 09 09 20 al) reruns))...
4d30: 28 28 61 6e 64 20 68 61 76 65 2d 72 65 73 6f 75 ((and have-resou
4d40: 72 63 65 73 0a 09 09 20 20 20 20 20 20 20 28 6f rces... (o
4d50: 72 20 28 6e 75 6c 6c 3f 20 70 72 65 72 65 71 73 r (null? prereqs
4d60: 2d 6e 6f 74 2d 6d 65 74 29 0a 09 09 09 20 20 20 -not-met)....
4d70: 28 61 6e 64 20 28 65 71 3f 20 74 65 73 74 6d 6f (and (eq? testmo
4d80: 64 65 20 27 74 6f 70 6c 65 76 65 6c 29 0a 09 09 de 'toplevel)...
4d90: 09 09 28 6e 75 6c 6c 3f 20 6e 6f 6e 2d 63 6f 6d ..(null? non-com
4da0: 70 6c 65 74 65 64 29 29 29 29 0a 09 09 20 20 28 pleted))))... (
4db0: 69 66 20 64 6f 74 66 69 6c 65 70 0a 09 09 20 20 if dotfilep...
4dc0: 20 20 20 20 28 77 69 74 68 2d 6f 75 74 70 75 74 (with-output
4dd0: 2d 74 6f 2d 70 6f 72 74 20 28 6c 61 6d 62 64 61 -to-port (lambda
4de0: 20 28 29 0a 09 09 09 09 09 20 20 20 20 20 28 66 ()...... (f
4df0: 6f 72 2d 65 61 63 68 20 28 6c 61 6d 62 64 61 20 or-each (lambda
4e00: 28 77 29 0a 09 09 09 09 09 09 09 20 28 70 72 69 (w)........ (pri
4e10: 6e 74 20 22 20 22 20 77 20 22 20 2d 3e 20 22 20 nt " " w " -> "
4e20: 74 65 73 74 2d 6e 61 6d 65 20 22 3b 22 29 29 0a test-name ";")).
4e30: 09 09 09 09 09 09 20 20 20 20 20 20 20 77 61 69 ...... wai
4e40: 74 6f 6e 73 29 0a 09 09 09 09 09 20 20 20 20 20 tons)......
4e50: 28 70 72 69 6e 74 20 22 20 22 20 74 65 73 74 2d (print " " test-
4e60: 6e 61 6d 65 20 22 3b 22 29 29 29 0a 09 09 20 20 name ";")))...
4e70: 20 20 20 20 28 72 75 6e 3a 74 65 73 74 20 72 75 (run:test ru
4e80: 6e 2d 69 64 20 72 75 6e 6e 61 6d 65 20 6b 65 79 n-id runname key
4e90: 76 61 6c 6c 73 74 20 74 65 73 74 2d 72 65 63 6f vallst test-reco
4ea0: 72 64 20 66 6c 61 67 73 20 23 66 29 29 0a 09 09 rd flags #f))...
4eb0: 20 20 28 74 68 72 65 61 64 2d 73 6c 65 65 70 21 (thread-sleep!
4ec0: 20 2a 67 6c 6f 62 61 6c 2d 64 65 6c 74 61 2a 29 *global-delta*)
4ed0: 0a 09 09 20 20 28 69 66 20 28 6e 6f 74 20 28 6e ... (if (not (n
4ee0: 75 6c 6c 3f 20 74 61 6c 29 29 0a 09 09 20 20 20 ull? tal))...
4ef0: 20 20 20 28 6c 6f 6f 70 20 28 63 61 72 20 74 61 (loop (car ta
4f00: 6c 29 28 63 64 72 20 74 61 6c 29 20 72 65 72 75 l)(cdr tal) reru
4f10: 6e 73 29 29 29 0a 09 09 20 28 65 6c 73 65 20 3b ns)))... (else ;
4f20: 3b 20 6d 75 73 74 20 62 65 20 77 65 20 68 61 76 ; must be we hav
4f30: 65 20 75 6e 6d 65 74 20 70 72 65 72 65 71 75 69 e unmet prerequi
4f40: 73 69 74 65 73 0a 09 09 20 20 20 20 28 64 65 62 sites... (deb
4f50: 75 67 3a 70 72 69 6e 74 20 34 20 22 46 41 49 4c ug:print 4 "FAIL
4f60: 53 3a 20 22 20 66 61 69 6c 73 29 0a 09 09 20 20 S: " fails)...
4f70: 20 20 3b 3b 20 49 66 20 6f 6e 65 20 6f 72 20 6d ;; If one or m
4f80: 6f 72 65 20 6f 66 20 74 68 65 20 70 72 65 72 65 ore of the prere
4f90: 71 73 2d 6e 6f 74 2d 6d 65 74 20 61 72 65 20 46 qs-not-met are F
4fa0: 41 49 4c 20 74 68 65 6e 20 77 65 20 63 61 6e 20 AIL then we can
4fb0: 69 73 73 75 65 0a 09 09 20 20 20 20 3b 3b 20 61 issue... ;; a
4fc0: 20 6d 65 73 73 61 67 65 20 61 6e 64 20 64 72 6f message and dro
4fd0: 70 20 68 65 64 20 66 72 6f 6d 20 74 68 65 20 69 p hed from the i
4fe0: 74 65 6d 73 20 74 6f 20 62 65 20 70 72 6f 63 65 tems to be proce
4ff0: 73 73 65 64 2e 0a 09 09 20 20 20 20 28 69 66 20 ssed.... (if
5000: 28 6e 75 6c 6c 3f 20 66 61 69 6c 73 29 0a 09 09 (null? fails)...
5010: 09 28 62 65 67 69 6e 0a 09 09 09 20 20 3b 3b 20 .(begin.... ;;
5020: 63 6f 75 6c 64 6e 27 74 20 72 75 6e 2c 20 74 61 couldn't run, ta
5030: 6b 65 20 61 20 62 72 65 61 74 68 65 72 0a 09 09 ke a breather...
5040: 09 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d . (debug:print-
5050: 69 6e 66 6f 20 34 20 22 53 68 6f 75 6c 64 6e 27 info 4 "Shouldn'
5060: 74 20 72 65 61 6c 6c 79 20 67 65 74 20 68 65 72 t really get her
5070: 65 2c 20 72 61 63 65 20 63 6f 6e 64 69 74 69 6f e, race conditio
5080: 6e 3f 20 55 6e 61 62 6c 65 20 74 6f 20 6c 61 75 n? Unable to lau
5090: 6e 63 68 20 6d 6f 72 65 20 74 65 73 74 73 20 61 nch more tests a
50a0: 74 20 74 68 69 73 20 6d 6f 6d 65 6e 74 2c 20 6b t this moment, k
50b0: 69 6c 6c 69 6e 67 20 74 69 6d 65 20 2e 2e 2e 22 illing time ..."
50c0: 29 0a 09 09 09 20 20 28 74 68 72 65 61 64 2d 73 ).... (thread-s
50d0: 6c 65 65 70 21 20 28 2b 20 30 2e 30 31 20 2a 67 leep! (+ 0.01 *g
50e0: 6c 6f 62 61 6c 2d 64 65 6c 74 61 2a 29 29 20 3b lobal-delta*)) ;
50f0: 3b 20 6c 6f 6e 67 20 73 6c 65 65 70 20 68 65 72 ; long sleep her
5100: 65 20 2d 20 6e 6f 20 72 65 73 6f 75 72 63 65 73 e - no resources
5110: 2c 20 6d 61 79 20 61 73 20 77 65 6c 6c 20 62 65 , may as well be
5120: 20 70 61 74 69 65 6e 74 0a 09 09 09 20 20 3b 3b patient.... ;;
5130: 20 77 65 20 6d 61 64 65 20 6e 65 77 20 74 61 6c we made new tal
5140: 20 62 79 20 73 74 69 63 6b 69 6e 67 20 68 65 64 by sticking hed
5150: 20 61 74 20 74 68 65 20 62 61 63 6b 20 6f 66 20 at the back of
5160: 74 68 65 20 6c 69 73 74 0a 09 09 09 20 20 28 6c the list.... (l
5170: 6f 6f 70 20 28 63 61 72 20 6e 65 77 74 61 6c 29 oop (car newtal)
5180: 28 63 64 72 20 6e 65 77 74 61 6c 29 20 72 65 72 (cdr newtal) rer
5190: 75 6e 73 29 29 0a 09 09 09 3b 3b 20 74 68 65 20 uns))....;; the
51a0: 77 61 69 74 6f 6e 20 69 73 20 46 41 49 4c 20 73 waiton is FAIL s
51b0: 6f 20 6e 6f 20 70 6f 69 6e 74 20 69 6e 20 74 72 o no point in tr
51c0: 79 69 6e 67 20 74 6f 20 72 75 6e 20 68 65 64 20 ying to run hed
51d0: 65 76 65 72 20 61 67 61 69 6e 0a 09 09 09 28 69 ever again....(i
51e0: 66 20 28 6e 6f 74 20 28 6e 75 6c 6c 3f 20 74 61 f (not (null? ta
51f0: 6c 29 29 0a 09 09 09 20 20 20 20 28 69 66 20 28 l)).... (if (
5200: 76 65 63 74 6f 72 3f 20 68 65 64 29 0a 09 09 09 vector? hed)....
5210: 09 28 62 65 67 69 6e 20 28 64 65 62 75 67 3a 70 .(begin (debug:p
5220: 72 69 6e 74 20 31 20 22 57 41 52 4e 3a 20 44 72 rint 1 "WARN: Dr
5230: 6f 70 70 69 6e 67 20 74 65 73 74 20 22 20 28 64 opping test " (d
5240: 62 3a 74 65 73 74 2d 67 65 74 2d 74 65 73 74 6e b:test-get-testn
5250: 61 6d 65 20 68 65 64 29 20 22 2f 22 20 28 64 62 ame hed) "/" (db
5260: 3a 74 65 73 74 2d 67 65 74 2d 69 74 65 6d 2d 70 :test-get-item-p
5270: 61 74 68 20 68 65 64 29 0a 09 09 09 09 09 09 20 ath hed).......
5280: 20 20 20 22 20 66 72 6f 6d 20 74 68 65 20 6c 61 " from the la
5290: 75 6e 63 68 20 6c 69 73 74 20 61 73 20 69 74 20 unch list as it
52a0: 68 61 73 20 70 72 65 72 65 71 75 69 73 74 65 73 has prerequistes
52b0: 20 74 68 61 74 20 61 72 65 20 46 41 49 4c 22 29 that are FAIL")
52c0: 0a 09 09 09 09 20 20 20 20 20 20 20 28 74 68 72 ..... (thr
52d0: 65 61 64 2d 73 6c 65 65 70 21 20 2a 67 6c 6f 62 ead-sleep! *glob
52e0: 61 6c 2d 64 65 6c 74 61 2a 29 0a 09 09 09 09 20 al-delta*).....
52f0: 20 20 20 20 20 20 28 6c 6f 6f 70 20 28 63 61 72 (loop (car
5300: 20 74 61 6c 29 28 63 64 72 20 74 61 6c 29 20 28 tal)(cdr tal) (
5310: 63 6f 6e 73 20 68 65 64 20 72 65 72 75 6e 73 29 cons hed reruns)
5320: 29 29 0a 09 09 09 09 28 62 65 67 69 6e 0a 09 09 )).....(begin...
5330: 09 09 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 .. (debug:print
5340: 20 31 20 22 57 41 52 4e 3a 20 54 65 73 74 20 6e 1 "WARN: Test n
5350: 6f 74 20 70 72 6f 63 65 73 73 65 64 20 63 6f 72 ot processed cor
5360: 72 65 63 74 6c 79 2e 20 43 6f 75 6c 64 20 62 65 rectly. Could be
5370: 20 61 20 72 61 63 65 20 63 6f 6e 64 69 74 69 6f a race conditio
5380: 6e 20 69 6e 20 79 6f 75 72 20 74 65 73 74 20 69 n in your test i
5390: 6d 70 6c 65 6d 65 6e 74 61 74 69 6f 6e 3f 20 22 mplementation? "
53a0: 20 68 65 64 29 20 3b 3b 20 20 22 20 61 73 20 69 hed) ;; " as i
53b0: 74 20 68 61 73 20 70 72 65 72 65 71 75 69 73 74 t has prerequist
53c0: 65 73 20 74 68 61 74 20 61 72 65 20 46 41 49 4c es that are FAIL
53d0: 2e 20 28 4e 4f 54 45 3a 20 68 65 64 20 69 73 20 . (NOTE: hed is
53e0: 6e 6f 74 20 61 20 76 65 63 74 6f 72 29 22 29 0a not a vector)").
53f0: 09 09 09 09 20 20 28 74 68 72 65 61 64 2d 73 6c .... (thread-sl
5400: 65 65 70 21 20 28 2b 20 30 2e 30 31 20 2a 67 6c eep! (+ 0.01 *gl
5410: 6f 62 61 6c 2d 64 65 6c 74 61 2a 29 29 0a 09 09 obal-delta*))...
5420: 09 09 20 20 28 6c 6f 6f 70 20 68 65 64 20 74 61 .. (loop hed ta
5430: 6c 20 72 65 72 75 6e 73 29 29 29 29 29 29 29 29 l reruns))))))))
5440: 29 20 3b 3b 20 45 4e 44 20 4f 46 20 49 4e 4e 45 ) ;; END OF INNE
5450: 52 20 43 4f 4e 44 0a 09 20 20 20 20 20 0a 09 20 R COND.. ..
5460: 20 20 20 20 3b 3b 20 63 61 73 65 20 77 68 65 72 ;; case wher
5470: 65 20 61 6e 20 69 74 65 6d 73 20 63 61 6d 65 20 e an items came
5480: 69 6e 20 61 73 20 61 20 6c 69 73 74 20 62 65 65 in as a list bee
5490: 6e 20 70 72 6f 63 65 73 73 65 64 0a 09 20 20 20 n processed..
54a0: 20 20 28 28 61 6e 64 20 28 6c 69 73 74 3f 20 69 ((and (list? i
54b0: 74 65 6d 73 29 20 20 20 20 20 3b 3b 20 74 68 75 tems) ;; thu
54c0: 73 20 77 65 20 6b 6e 6f 77 20 6f 75 72 20 69 74 s we know our it
54d0: 65 6d 73 20 61 72 65 20 61 6c 72 65 61 64 79 20 ems are already
54e0: 63 61 6c 63 75 6c 61 74 65 64 0a 09 09 20 20 20 calculated...
54f0: 28 6e 6f 74 20 20 20 69 74 65 6d 64 61 74 29 29 (not itemdat))
5500: 20 3b 3b 20 61 6e 64 20 6e 6f 74 20 79 65 74 20 ;; and not yet
5510: 65 78 70 61 6e 64 65 64 20 69 6e 74 6f 20 74 68 expanded into th
5520: 65 20 6c 69 73 74 20 6f 66 20 74 68 69 6e 67 73 e list of things
5530: 20 74 6f 20 62 65 20 64 6f 6e 65 0a 09 20 20 20 to be done..
5540: 20 20 20 28 69 66 20 28 61 6e 64 20 28 64 65 62 (if (and (deb
5550: 75 67 3a 64 65 62 75 67 2d 6d 6f 64 65 20 31 29 ug:debug-mode 1)
5560: 20 3b 3b 20 28 3e 3d 20 2a 76 65 72 62 6f 73 69 ;; (>= *verbosi
5570: 74 79 2a 20 31 29 0a 09 09 20 20 20 20 20 20 20 ty* 1)...
5580: 28 3e 20 28 6c 65 6e 67 74 68 20 69 74 65 6d 73 (> (length items
5590: 29 20 30 29 0a 09 09 20 20 20 20 20 20 20 28 3e ) 0)... (>
55a0: 20 28 6c 65 6e 67 74 68 20 28 63 61 72 20 69 74 (length (car it
55b0: 65 6d 73 29 29 20 30 29 29 0a 09 09 20 20 28 70 ems)) 0))... (p
55c0: 70 20 69 74 65 6d 73 29 29 0a 09 20 20 20 20 20 p items))..
55d0: 20 28 66 6f 72 2d 65 61 63 68 0a 09 20 20 20 20 (for-each..
55e0: 20 20 20 28 6c 61 6d 62 64 61 20 28 6d 79 2d 69 (lambda (my-i
55f0: 74 65 6d 64 61 74 29 0a 09 09 20 28 6c 65 74 2a temdat)... (let*
5600: 20 28 28 6e 65 77 2d 74 65 73 74 2d 72 65 63 6f ((new-test-reco
5610: 72 64 20 28 6c 65 74 20 28 28 6e 65 77 72 65 63 rd (let ((newrec
5620: 20 28 6d 61 6b 65 2d 74 65 73 74 73 3a 74 65 73 (make-tests:tes
5630: 74 71 75 65 75 65 29 29 29 0a 09 09 09 09 09 20 tqueue)))......
5640: 20 20 28 76 65 63 74 6f 72 2d 63 6f 70 79 21 20 (vector-copy!
5650: 74 65 73 74 2d 72 65 63 6f 72 64 20 6e 65 77 72 test-record newr
5660: 65 63 29 0a 09 09 09 09 09 20 20 20 6e 65 77 72 ec)...... newr
5670: 65 63 29 29 0a 09 09 09 28 6d 79 2d 69 74 65 6d ec))....(my-item
5680: 2d 70 61 74 68 20 28 69 74 65 6d 2d 6c 69 73 74 -path (item-list
5690: 2d 3e 70 61 74 68 20 6d 79 2d 69 74 65 6d 64 61 ->path my-itemda
56a0: 74 29 29 29 0a 09 09 20 20 20 28 69 66 20 28 74 t)))... (if (t
56b0: 65 73 74 73 3a 6d 61 74 63 68 20 74 65 73 74 2d ests:match test-
56c0: 70 61 74 74 73 20 68 65 64 20 6d 79 2d 69 74 65 patts hed my-ite
56d0: 6d 2d 70 61 74 68 29 20 3b 3b 20 28 70 61 74 74 m-path) ;; (patt
56e0: 2d 6c 69 73 74 2d 6d 61 74 63 68 20 6d 79 2d 69 -list-match my-i
56f0: 74 65 6d 2d 70 61 74 68 20 69 74 65 6d 2d 70 61 tem-path item-pa
5700: 74 74 73 29 20 20 20 20 20 20 20 20 20 20 20 3b tts) ;
5710: 3b 20 79 65 73 2c 20 77 65 20 77 61 6e 74 20 74 ; yes, we want t
5720: 6f 20 70 72 6f 63 65 73 73 20 74 68 69 73 20 69 o process this i
5730: 74 65 6d 2c 20 4e 4f 54 45 3a 20 53 68 6f 75 6c tem, NOTE: Shoul
5740: 64 20 6e 6f 74 20 6e 65 65 64 20 74 68 69 73 20 d not need this
5750: 63 68 65 63 6b 20 68 65 72 65 21 0a 09 09 20 20 check here!...
5760: 20 20 20 20 20 28 6c 65 74 20 28 28 6e 65 77 74 (let ((newt
5770: 65 73 74 6e 61 6d 65 20 28 72 75 6e 73 3a 6d 61 estname (runs:ma
5780: 6b 65 2d 66 75 6c 6c 2d 74 65 73 74 2d 6e 61 6d ke-full-test-nam
5790: 65 20 68 65 64 20 6d 79 2d 69 74 65 6d 2d 70 61 e hed my-item-pa
57a0: 74 68 29 29 29 20 20 20 20 3b 3b 20 74 65 73 74 th))) ;; test
57b0: 20 6e 61 6d 65 73 20 61 72 65 20 75 6e 69 71 75 names are uniqu
57c0: 65 20 6f 6e 20 74 65 73 74 6e 61 6d 65 2f 69 74 e on testname/it
57d0: 65 6d 2d 70 61 74 68 0a 09 09 09 20 28 74 65 73 em-path.... (tes
57e0: 74 73 3a 74 65 73 74 71 75 65 75 65 2d 73 65 74 ts:testqueue-set
57f0: 2d 69 74 65 6d 73 21 20 20 20 20 20 6e 65 77 2d -items! new-
5800: 74 65 73 74 2d 72 65 63 6f 72 64 20 23 66 29 0a test-record #f).
5810: 09 09 09 20 28 74 65 73 74 73 3a 74 65 73 74 71 ... (tests:testq
5820: 75 65 75 65 2d 73 65 74 2d 69 74 65 6d 64 61 74 ueue-set-itemdat
5830: 21 20 20 20 6e 65 77 2d 74 65 73 74 2d 72 65 63 ! new-test-rec
5840: 6f 72 64 20 6d 79 2d 69 74 65 6d 64 61 74 29 0a ord my-itemdat).
5850: 09 09 09 20 28 74 65 73 74 73 3a 74 65 73 74 71 ... (tests:testq
5860: 75 65 75 65 2d 73 65 74 2d 69 74 65 6d 5f 70 61 ueue-set-item_pa
5870: 74 68 21 20 6e 65 77 2d 74 65 73 74 2d 72 65 63 th! new-test-rec
5880: 6f 72 64 20 6d 79 2d 69 74 65 6d 2d 70 61 74 68 ord my-item-path
5890: 29 0a 09 09 09 20 28 68 61 73 68 2d 74 61 62 6c ).... (hash-tabl
58a0: 65 2d 73 65 74 21 20 74 65 73 74 2d 72 65 63 6f e-set! test-reco
58b0: 72 64 73 20 6e 65 77 74 65 73 74 6e 61 6d 65 20 rds newtestname
58c0: 6e 65 77 2d 74 65 73 74 2d 72 65 63 6f 72 64 29 new-test-record)
58d0: 0a 09 09 09 20 28 73 65 74 21 20 74 61 6c 20 28 .... (set! tal (
58e0: 63 6f 6e 73 20 6e 65 77 74 65 73 74 6e 61 6d 65 cons newtestname
58f0: 20 74 61 6c 29 29 29 29 29 29 20 3b 3b 20 73 69 tal)))))) ;; si
5900: 6e 63 65 20 74 68 65 73 65 20 61 72 65 20 69 74 nce these are it
5910: 65 6d 69 7a 65 64 20 63 72 65 61 74 65 20 6e 65 emized create ne
5920: 77 20 74 65 73 74 20 6e 61 6d 65 73 20 74 65 73 w test names tes
5930: 74 6e 61 6d 65 2f 69 74 65 6d 70 61 74 68 0a 09 tname/itempath..
5940: 20 20 20 20 20 20 20 69 74 65 6d 73 29 0a 09 20 items)..
5950: 20 20 20 20 20 28 69 66 20 28 6e 6f 74 20 28 6e (if (not (n
5960: 75 6c 6c 3f 20 74 61 6c 29 29 0a 09 09 20 20 28 ull? tal))... (
5970: 62 65 67 69 6e 0a 09 09 20 20 20 20 28 64 65 62 begin... (deb
5980: 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 34 20 ug:print-info 4
5990: 22 45 6e 64 20 6f 66 20 69 74 65 6d 73 20 6c 69 "End of items li
59a0: 73 74 2c 20 6c 6f 6f 70 69 6e 67 20 77 69 74 68 st, looping with
59b0: 20 6e 65 78 74 20 61 66 74 65 72 20 73 68 6f 72 next after shor
59c0: 74 20 64 65 6c 61 79 22 29 0a 09 09 20 20 20 20 t delay")...
59d0: 28 74 68 72 65 61 64 2d 73 6c 65 65 70 21 20 28 (thread-sleep! (
59e0: 2b 20 30 2e 30 31 20 2a 67 6c 6f 62 61 6c 2d 64 + 0.01 *global-d
59f0: 65 6c 74 61 2a 29 29 0a 09 09 20 20 20 20 28 6c elta*))... (l
5a00: 6f 6f 70 20 28 63 61 72 20 74 61 6c 29 28 63 64 oop (car tal)(cd
5a10: 72 20 74 61 6c 29 20 72 65 72 75 6e 73 29 29 29 r tal) reruns)))
5a20: 29 0a 0a 09 20 20 20 20 20 3b 3b 20 69 66 20 69 )... ;; if i
5a30: 74 65 6d 73 20 69 73 20 61 20 70 72 6f 63 20 74 tems is a proc t
5a40: 68 65 6e 20 6e 65 65 64 20 74 6f 20 72 75 6e 20 hen need to run
5a50: 69 74 65 6d 73 3a 67 65 74 2d 69 74 65 6d 73 2d items:get-items-
5a60: 66 72 6f 6d 2d 63 6f 6e 66 69 67 2c 20 67 65 74 from-config, get
5a70: 20 74 68 65 20 6c 69 73 74 20 61 6e 64 20 6c 6f the list and lo
5a80: 6f 70 20 0a 09 20 20 20 20 20 3b 3b 20 20 20 20 op .. ;;
5a90: 2d 20 62 75 74 20 6f 6e 6c 79 20 64 6f 20 74 68 - but only do th
5aa0: 61 74 20 69 66 20 72 65 73 6f 75 72 63 65 73 20 at if resources
5ab0: 65 78 69 73 74 20 74 6f 20 6b 69 63 6b 20 6f 66 exist to kick of
5ac0: 66 20 74 68 65 20 6a 6f 62 0a 09 20 20 20 20 20 f the job..
5ad0: 28 28 6f 72 20 28 70 72 6f 63 65 64 75 72 65 3f ((or (procedure?
5ae0: 20 69 74 65 6d 73 29 28 65 71 3f 20 69 74 65 6d items)(eq? item
5af0: 73 20 27 68 61 76 65 2d 70 72 6f 63 65 64 75 72 s 'have-procedur
5b00: 65 29 29 0a 09 20 20 20 20 20 20 28 6c 65 74 20 e)).. (let
5b10: 28 28 63 61 6e 2d 72 75 6e 2d 6d 6f 72 65 20 20 ((can-run-more
5b20: 20 20 28 72 75 6e 73 3a 63 61 6e 2d 72 75 6e 2d (runs:can-run-
5b30: 6d 6f 72 65 2d 74 65 73 74 73 20 74 65 73 74 2d more-tests test-
5b40: 72 65 63 6f 72 64 29 29 29 0a 09 09 28 69 66 20 record)))...(if
5b50: 28 61 6e 64 20 28 6c 69 73 74 3f 20 63 61 6e 2d (and (list? can-
5b60: 72 75 6e 2d 6d 6f 72 65 29 0a 09 09 09 20 28 63 run-more).... (c
5b70: 61 72 20 63 61 6e 2d 72 75 6e 2d 6d 6f 72 65 29 ar can-run-more)
5b80: 29 0a 09 09 20 20 20 20 28 6c 65 74 2a 20 28 28 )... (let* ((
5b90: 70 72 65 72 65 71 73 2d 6e 6f 74 2d 6d 65 74 20 prereqs-not-met
5ba0: 28 6f 70 65 6e 2d 72 75 6e 2d 63 6c 6f 73 65 20 (open-run-close
5bb0: 64 62 3a 67 65 74 2d 70 72 65 72 65 71 73 2d 6e db:get-prereqs-n
5bc0: 6f 74 2d 6d 65 74 20 23 66 20 72 75 6e 2d 69 64 ot-met #f run-id
5bd0: 20 77 61 69 74 6f 6e 73 20 69 74 65 6d 2d 70 61 waitons item-pa
5be0: 74 68 20 6d 6f 64 65 3a 20 74 65 73 74 6d 6f 64 th mode: testmod
5bf0: 65 29 29 0a 09 09 09 20 20 20 28 66 61 69 6c 73 e)).... (fails
5c00: 20 20 20 20 20 20 20 20 20 20 20 28 72 75 6e 73 (runs
5c10: 3a 63 61 6c 63 2d 66 61 69 6c 73 20 70 72 65 72 :calc-fails prer
5c20: 65 71 73 2d 6e 6f 74 2d 6d 65 74 29 29 0a 09 09 eqs-not-met))...
5c30: 09 20 20 20 28 6e 6f 6e 2d 63 6f 6d 70 6c 65 74 . (non-complet
5c40: 65 64 20 20 20 28 72 75 6e 73 3a 63 61 6c 63 2d ed (runs:calc-
5c50: 6e 6f 74 2d 63 6f 6d 70 6c 65 74 65 64 20 70 72 not-completed pr
5c60: 65 72 65 71 73 2d 6e 6f 74 2d 6d 65 74 29 29 29 ereqs-not-met)))
5c70: 0a 09 09 20 20 20 20 20 20 28 64 65 62 75 67 3a ... (debug:
5c80: 70 72 69 6e 74 2d 69 6e 66 6f 20 38 20 22 63 61 print-info 8 "ca
5c90: 6e 2d 72 75 6e 2d 6d 6f 72 65 3a 20 22 20 63 61 n-run-more: " ca
5ca0: 6e 2d 72 75 6e 2d 6d 6f 72 65 0a 09 09 09 09 20 n-run-more.....
5cb0: 20 20 22 5c 6e 20 74 65 73 74 6e 61 6d 65 3a 20 "\n testname:
5cc0: 20 20 20 20 20 20 20 22 20 68 65 64 0a 09 09 09 " hed....
5cd0: 09 20 20 20 22 5c 6e 20 70 72 65 72 65 71 73 2d . "\n prereqs-
5ce0: 6e 6f 74 2d 6d 65 74 3a 20 22 20 28 72 75 6e 73 not-met: " (runs
5cf0: 3a 70 72 65 74 74 79 2d 73 74 72 69 6e 67 20 70 :pretty-string p
5d00: 72 65 72 65 71 73 2d 6e 6f 74 2d 6d 65 74 29 0a rereqs-not-met).
5d10: 09 09 09 09 20 20 20 22 5c 6e 20 6e 6f 6e 2d 63 .... "\n non-c
5d20: 6f 6d 70 6c 65 74 65 64 3a 20 20 20 22 20 28 72 ompleted: " (r
5d30: 75 6e 73 3a 70 72 65 74 74 79 2d 73 74 72 69 6e uns:pretty-strin
5d40: 67 20 6e 6f 6e 2d 63 6f 6d 70 6c 65 74 65 64 29 g non-completed)
5d50: 20 0a 09 09 09 09 20 20 20 22 5c 6e 20 66 61 69 ..... "\n fai
5d60: 6c 73 3a 20 20 20 20 20 20 20 20 20 20 20 22 20 ls: "
5d70: 28 72 75 6e 73 3a 70 72 65 74 74 79 2d 73 74 72 (runs:pretty-str
5d80: 69 6e 67 20 66 61 69 6c 73 29 0a 09 09 09 09 20 ing fails).....
5d90: 20 20 22 5c 6e 20 74 65 73 74 6d 6f 64 65 3a 20 "\n testmode:
5da0: 20 20 20 20 20 20 20 22 20 74 65 73 74 6d 6f 64 " testmod
5db0: 65 0a 09 09 09 09 20 20 20 22 5c 6e 20 6e 75 6d e..... "\n num
5dc0: 2d 72 65 74 72 69 65 73 3a 20 20 20 20 20 22 20 -retries: "
5dd0: 6e 75 6d 2d 72 65 74 72 69 65 73 0a 09 09 09 09 num-retries.....
5de0: 20 20 20 22 5c 6e 20 28 65 71 3f 20 74 65 73 74 "\n (eq? test
5df0: 6d 6f 64 65 20 27 74 6f 70 6c 65 76 65 6c 29 3a mode 'toplevel):
5e00: 20 22 20 28 65 71 3f 20 74 65 73 74 6d 6f 64 65 " (eq? testmode
5e10: 20 27 74 6f 70 6c 65 76 65 6c 29 0a 09 09 09 09 'toplevel).....
5e20: 20 20 20 22 5c 6e 20 28 6e 75 6c 6c 3f 20 6e 6f "\n (null? no
5e30: 6e 2d 63 6f 6d 70 6c 65 74 65 64 29 3a 20 20 20 n-completed):
5e40: 20 22 20 28 6e 75 6c 6c 3f 20 6e 6f 6e 2d 63 6f " (null? non-co
5e50: 6d 70 6c 65 74 65 64 29 0a 09 09 09 09 20 20 20 mpleted).....
5e60: 22 5c 6e 20 72 65 72 75 6e 73 3a 20 20 20 20 20 "\n reruns:
5e70: 20 20 20 20 20 22 20 72 65 72 75 6e 73 0a 09 09 " reruns...
5e80: 09 09 20 20 20 22 5c 6e 20 69 74 65 6d 73 3a 20 .. "\n items:
5e90: 20 20 20 20 20 20 20 20 20 20 22 20 69 74 65 6d " item
5ea0: 73 0a 09 09 09 09 20 20 20 22 5c 6e 20 63 61 6e s..... "\n can
5eb0: 2d 72 75 6e 2d 6d 6f 72 65 3a 20 20 20 20 22 20 -run-more: "
5ec0: 63 61 6e 2d 72 75 6e 2d 6d 6f 72 65 29 0a 09 09 can-run-more)...
5ed0: 20 20 20 20 20 20 3b 3b 20 28 74 68 72 65 61 64 ;; (thread
5ee0: 2d 73 6c 65 65 70 21 20 28 2b 20 30 2e 30 31 20 -sleep! (+ 0.01
5ef0: 2a 67 6c 6f 62 61 6c 2d 64 65 6c 74 61 2a 29 29 *global-delta*))
5f00: 0a 09 09 20 20 20 20 20 20 28 63 6f 6e 64 20 3b ... (cond ;
5f10: 3b 20 49 4e 4e 45 52 20 43 4f 4e 44 20 23 32 0a ; INNER COND #2.
5f20: 09 09 20 20 20 20 20 20 20 28 28 6f 72 20 28 6e .. ((or (n
5f30: 75 6c 6c 3f 20 70 72 65 72 65 71 73 2d 6e 6f 74 ull? prereqs-not
5f40: 2d 6d 65 74 29 20 3b 3b 20 61 6c 6c 20 70 72 65 -met) ;; all pre
5f50: 72 65 71 73 20 6d 65 74 2c 20 66 69 72 65 20 6f reqs met, fire o
5f60: 66 66 20 74 68 65 20 74 65 73 74 0a 09 09 09 20 ff the test....
5f70: 20 20 20 3b 3b 20 6f 72 2c 20 69 66 20 69 74 20 ;; or, if it
5f80: 69 73 20 61 20 27 74 6f 70 6c 65 76 65 6c 20 74 is a 'toplevel t
5f90: 65 73 74 20 61 6e 64 20 61 6c 6c 20 70 72 65 72 est and all prer
5fa0: 65 71 73 20 6e 6f 74 20 6d 65 74 20 61 72 65 20 eqs not met are
5fb0: 43 4f 4d 50 4c 45 54 45 44 20 74 68 65 6e 20 6c COMPLETED then l
5fc0: 61 75 6e 63 68 0a 09 09 09 20 20 20 20 28 61 6e aunch.... (an
5fd0: 64 20 28 65 71 3f 20 74 65 73 74 6d 6f 64 65 20 d (eq? testmode
5fe0: 27 74 6f 70 6c 65 76 65 6c 29 0a 09 09 09 09 20 'toplevel).....
5ff0: 28 6e 75 6c 6c 3f 20 6e 6f 6e 2d 63 6f 6d 70 6c (null? non-compl
6000: 65 74 65 64 29 29 29 0a 09 09 09 28 6c 65 74 20 eted)))....(let
6010: 28 28 74 65 73 74 2d 6e 61 6d 65 20 28 74 65 73 ((test-name (tes
6020: 74 73 3a 74 65 73 74 71 75 65 75 65 2d 67 65 74 ts:testqueue-get
6030: 2d 74 65 73 74 6e 61 6d 65 20 74 65 73 74 2d 72 -testname test-r
6040: 65 63 6f 72 64 29 29 29 0a 09 09 09 20 20 28 73 ecord))).... (s
6050: 65 74 65 6e 76 20 22 4d 54 5f 54 45 53 54 5f 4e etenv "MT_TEST_N
6060: 41 4d 45 22 20 74 65 73 74 2d 6e 61 6d 65 29 20 AME" test-name)
6070: 3b 3b 20 0a 09 09 09 20 20 28 73 65 74 65 6e 76 ;; .... (setenv
6080: 20 22 4d 54 5f 52 55 4e 4e 41 4d 45 22 20 20 20 "MT_RUNNAME"
6090: 72 75 6e 6e 61 6d 65 29 0a 09 09 09 20 20 28 73 runname).... (s
60a0: 65 74 2d 6d 65 67 61 74 65 73 74 2d 65 6e 76 2d et-megatest-env-
60b0: 76 61 72 73 20 72 75 6e 2d 69 64 29 20 3b 3b 20 vars run-id) ;;
60c0: 74 68 65 73 65 20 6d 61 79 20 62 65 20 6e 65 65 these may be nee
60d0: 64 65 64 20 62 79 20 74 68 65 20 6c 61 75 6e 63 ded by the launc
60e0: 68 69 6e 67 20 70 72 6f 63 65 73 73 0a 09 09 09 hing process....
60f0: 20 20 28 6c 65 74 20 28 28 69 74 65 6d 73 2d 6c (let ((items-l
6100: 69 73 74 20 28 69 74 65 6d 73 3a 67 65 74 2d 69 ist (items:get-i
6110: 74 65 6d 73 2d 66 72 6f 6d 2d 63 6f 6e 66 69 67 tems-from-config
6120: 20 74 63 6f 6e 66 69 67 29 29 29 0a 09 09 09 20 tconfig)))....
6130: 20 20 20 28 69 66 20 28 6c 69 73 74 3f 20 69 74 (if (list? it
6140: 65 6d 73 2d 6c 69 73 74 29 0a 09 09 09 09 28 62 ems-list).....(b
6150: 65 67 69 6e 0a 09 09 09 09 20 20 28 74 65 73 74 egin..... (test
6160: 73 3a 74 65 73 74 71 75 65 75 65 2d 73 65 74 2d s:testqueue-set-
6170: 69 74 65 6d 73 21 20 74 65 73 74 2d 72 65 63 6f items! test-reco
6180: 72 64 20 69 74 65 6d 73 2d 6c 69 73 74 29 0a 09 rd items-list)..
6190: 09 09 09 20 20 28 74 68 72 65 61 64 2d 73 6c 65 ... (thread-sle
61a0: 65 70 21 20 2a 67 6c 6f 62 61 6c 2d 64 65 6c 74 ep! *global-delt
61b0: 61 2a 29 0a 09 09 09 09 20 20 28 6c 6f 6f 70 20 a*)..... (loop
61c0: 68 65 64 20 74 61 6c 20 72 65 72 75 6e 73 29 29 hed tal reruns))
61d0: 0a 09 09 09 09 28 62 65 67 69 6e 0a 09 09 09 09 .....(begin.....
61e0: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 (debug:print 0
61f0: 20 22 45 52 52 4f 52 3a 20 54 68 65 20 70 72 6f "ERROR: The pro
6200: 63 20 66 72 6f 6d 20 72 65 61 64 69 6e 67 20 74 c from reading t
6210: 68 65 20 73 65 74 75 70 20 64 69 64 20 6e 6f 74 he setup did not
6220: 20 79 69 65 6c 64 20 61 20 6c 69 73 74 20 2d 20 yield a list -
6230: 70 6c 65 61 73 65 20 72 65 70 6f 72 74 20 74 68 please report th
6240: 69 73 22 29 0a 09 09 09 09 20 20 28 65 78 69 74 is")..... (exit
6250: 20 31 29 29 29 29 29 29 0a 09 09 20 20 20 20 20 1))))))...
6260: 20 20 28 28 6e 75 6c 6c 3f 20 66 61 69 6c 73 29 ((null? fails)
6270: 0a 09 09 09 28 64 65 62 75 67 3a 70 72 69 6e 74 ....(debug:print
6280: 2d 69 6e 66 6f 20 34 20 22 66 61 69 6c 73 20 69 -info 4 "fails i
6290: 73 20 6e 75 6c 6c 2c 20 6d 6f 76 69 6e 67 20 6f s null, moving o
62a0: 6e 20 69 6e 20 74 68 65 20 71 75 65 75 65 20 62 n in the queue b
62b0: 75 74 20 6b 65 65 70 69 6e 67 20 22 20 68 65 64 ut keeping " hed
62c0: 20 22 20 66 6f 72 20 6e 6f 77 22 29 0a 09 09 09 " for now")....
62d0: 3b 3b 20 6f 6e 6c 79 20 69 6e 63 72 65 6d 65 6e ;; only incremen
62e0: 74 20 6e 75 6d 2d 72 65 74 72 69 65 73 20 77 68 t num-retries wh
62f0: 65 6e 20 74 68 65 72 65 20 61 72 65 20 6e 6f 20 en there are no
6300: 74 65 73 74 73 20 72 75 6e 69 6e 67 0a 09 09 09 tests runing....
6310: 28 69 66 20 28 65 71 3f 20 30 20 28 6c 69 73 74 (if (eq? 0 (list
6320: 2d 72 65 66 20 63 61 6e 2d 72 75 6e 2d 6d 6f 72 -ref can-run-mor
6330: 65 20 31 29 29 0a 09 09 09 20 20 20 20 28 62 65 e 1)).... (be
6340: 67 69 6e 0a 09 09 09 20 20 20 20 20 20 28 69 66 gin.... (if
6350: 20 28 3e 20 6e 75 6d 2d 72 65 74 72 69 65 73 20 (> num-retries
6360: 31 30 30 29 20 3b 3b 20 66 69 72 73 74 20 31 30 100) ;; first 10
6370: 30 20 72 65 74 72 69 65 73 20 61 72 65 20 6c 6f 0 retries are lo
6380: 77 20 74 69 6d 65 20 63 6f 73 74 0a 09 09 09 09 w time cost.....
6390: 20 20 28 74 68 72 65 61 64 2d 73 6c 65 65 70 21 (thread-sleep!
63a0: 20 28 2b 20 32 20 2a 67 6c 6f 62 61 6c 2d 64 65 (+ 2 *global-de
63b0: 6c 74 61 2a 29 29 0a 09 09 09 09 20 20 28 74 68 lta*))..... (th
63c0: 72 65 61 64 2d 73 6c 65 65 70 21 20 28 2b 20 30 read-sleep! (+ 0
63d0: 2e 30 31 20 2a 67 6c 6f 62 61 6c 2d 64 65 6c 74 .01 *global-delt
63e0: 61 2a 29 29 29 0a 09 09 09 20 20 20 20 20 20 28 a*))).... (
63f0: 73 65 74 21 20 6e 75 6d 2d 72 65 74 72 69 65 73 set! num-retries
6400: 20 28 2b 20 6e 75 6d 2d 72 65 74 72 69 65 73 20 (+ num-retries
6410: 31 29 29 29 29 0a 09 09 09 28 69 66 20 28 3e 20 1))))....(if (>
6420: 6e 75 6d 2d 72 65 74 72 69 65 73 20 20 6d 61 78 num-retries max
6430: 2d 72 65 74 72 69 65 73 29 0a 09 09 09 20 20 20 -retries)....
6440: 20 28 69 66 20 28 6e 6f 74 20 28 6e 75 6c 6c 3f (if (not (null?
6450: 20 74 61 6c 29 29 0a 09 09 09 09 28 6c 6f 6f 70 tal)).....(loop
6460: 20 28 63 61 72 20 74 61 6c 29 28 63 64 72 20 74 (car tal)(cdr t
6470: 61 6c 29 20 72 65 72 75 6e 73 29 29 0a 09 09 09 al) reruns))....
6480: 20 20 20 20 28 6c 6f 6f 70 20 28 63 61 72 20 6e (loop (car n
6490: 65 77 74 61 6c 29 28 63 64 72 20 6e 65 77 74 61 ewtal)(cdr newta
64a0: 6c 29 20 72 65 72 75 6e 73 29 29 29 20 3b 3b 20 l) reruns))) ;;
64b0: 61 6e 20 69 73 73 75 65 20 77 69 74 68 20 70 72 an issue with pr
64c0: 65 72 65 71 73 20 6e 6f 74 20 79 65 74 20 6d 65 ereqs not yet me
64d0: 74 3f 0a 09 09 20 20 20 20 20 20 20 28 28 61 6e t?... ((an
64e0: 64 20 28 6e 6f 74 20 28 6e 75 6c 6c 3f 20 66 61 d (not (null? fa
64f0: 69 6c 73 29 29 28 65 71 3f 20 74 65 73 74 6d 6f ils))(eq? testmo
6500: 64 65 20 27 6e 6f 72 6d 61 6c 29 29 0a 09 09 09 de 'normal))....
6510: 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 (debug:print-inf
6520: 6f 20 31 20 22 74 65 73 74 20 22 20 20 68 65 64 o 1 "test " hed
6530: 20 22 20 28 6d 6f 64 65 3d 22 20 74 65 73 74 6d " (mode=" testm
6540: 6f 64 65 20 22 29 20 68 61 73 20 66 61 69 6c 65 ode ") has faile
6550: 64 20 70 72 65 72 65 71 75 69 73 69 74 65 28 73 d prerequisite(s
6560: 29 3b 20 22 0a 09 09 09 09 20 20 20 20 20 28 73 ); "..... (s
6570: 74 72 69 6e 67 2d 69 6e 74 65 72 73 70 65 72 73 tring-interspers
6580: 65 20 28 6d 61 70 20 28 6c 61 6d 62 64 61 20 28 e (map (lambda (
6590: 74 29 28 63 6f 6e 63 20 28 64 62 3a 74 65 73 74 t)(conc (db:test
65a0: 2d 67 65 74 2d 74 65 73 74 6e 61 6d 65 20 74 29 -get-testname t)
65b0: 20 22 3a 22 20 28 64 62 3a 74 65 73 74 2d 67 65 ":" (db:test-ge
65c0: 74 2d 73 74 61 74 65 20 74 29 22 2f 22 28 64 62 t-state t)"/"(db
65d0: 3a 74 65 73 74 2d 67 65 74 2d 73 74 61 74 75 73 :test-get-status
65e0: 20 74 29 29 29 20 66 61 69 6c 73 29 20 22 2c 20 t))) fails) ",
65f0: 22 29 0a 09 09 09 09 20 20 20 20 20 22 2c 20 72 ")..... ", r
6600: 65 6d 6f 76 69 6e 67 20 69 74 20 66 72 6f 6d 20 emoving it from
6610: 74 6f 2d 64 6f 20 6c 69 73 74 22 29 0a 09 09 09 to-do list")....
6620: 28 69 66 20 28 6e 6f 74 20 28 6e 75 6c 6c 3f 20 (if (not (null?
6630: 74 61 6c 29 29 0a 09 09 09 20 20 20 20 28 62 65 tal)).... (be
6640: 67 69 6e 0a 09 09 09 20 20 20 20 20 20 28 74 68 gin.... (th
6650: 72 65 61 64 2d 73 6c 65 65 70 21 20 2a 67 6c 6f read-sleep! *glo
6660: 62 61 6c 2d 64 65 6c 74 61 2a 29 0a 09 09 09 20 bal-delta*)....
6670: 20 20 20 20 20 28 6c 6f 6f 70 20 28 63 61 72 20 (loop (car
6680: 74 61 6c 29 28 63 64 72 20 74 61 6c 29 28 63 6f tal)(cdr tal)(co
6690: 6e 73 20 68 65 64 20 72 65 72 75 6e 73 29 29 29 ns hed reruns)))
66a0: 29 29 0a 09 09 20 20 20 20 20 20 20 28 65 6c 73 ))... (els
66b0: 65 0a 09 09 09 28 64 65 62 75 67 3a 70 72 69 6e e....(debug:prin
66c0: 74 20 38 20 22 45 52 52 4f 52 3a 20 4e 6f 20 68 t 8 "ERROR: No h
66d0: 61 6e 64 6c 65 72 20 66 6f 72 20 74 68 69 73 20 andler for this
66e0: 63 6f 6e 64 69 74 69 6f 6e 2e 22 29 0a 09 09 09 condition.")....
66f0: 28 74 68 72 65 61 64 2d 73 6c 65 65 70 21 20 28 (thread-sleep! (
6700: 2b 20 31 20 2a 67 6c 6f 62 61 6c 2d 64 65 6c 74 + 1 *global-delt
6710: 61 2a 29 29 0a 09 09 09 28 6c 6f 6f 70 20 28 63 a*))....(loop (c
6720: 61 72 20 6e 65 77 74 61 6c 29 28 63 64 72 20 6e ar newtal)(cdr n
6730: 65 77 74 61 6c 29 20 72 65 72 75 6e 73 29 29 29 ewtal) reruns)))
6740: 29 20 3b 3b 20 45 4e 44 20 4f 46 20 49 46 20 43 ) ;; END OF IF C
6750: 41 4e 20 52 55 4e 20 4d 4f 52 45 0a 0a 09 09 20 AN RUN MORE....
6760: 20 20 20 3b 3b 20 69 66 20 63 61 6e 27 74 20 72 ;; if can't r
6770: 75 6e 20 6d 6f 72 65 20 6a 75 73 74 20 6c 6f 6f un more just loo
6780: 70 20 77 69 74 68 20 6e 65 78 74 20 70 6f 73 73 p with next poss
6790: 69 62 6c 65 20 74 65 73 74 0a 09 09 20 20 20 20 ible test...
67a0: 28 62 65 67 69 6e 0a 09 09 20 20 20 20 20 20 28 (begin... (
67b0: 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f debug:print-info
67c0: 20 34 20 22 70 72 6f 63 65 73 73 69 6e 67 20 74 4 "processing t
67d0: 68 65 20 63 61 73 65 20 77 69 74 68 20 61 20 6c he case with a l
67e0: 61 6d 62 64 61 20 66 6f 72 20 69 74 65 6d 73 20 ambda for items
67f0: 6f 72 20 27 68 61 76 65 2d 70 72 6f 63 65 64 75 or 'have-procedu
6800: 72 65 2e 20 4d 6f 76 69 6e 67 20 74 68 72 6f 75 re. Moving throu
6810: 67 68 20 74 68 65 20 71 75 65 75 65 20 77 69 74 gh the queue wit
6820: 68 6f 75 74 20 64 72 6f 70 70 69 6e 67 20 22 20 hout dropping "
6830: 68 65 64 29 0a 09 09 20 20 20 20 20 20 28 74 68 hed)... (th
6840: 72 65 61 64 2d 73 6c 65 65 70 21 20 28 2b 20 32 read-sleep! (+ 2
6850: 20 2a 67 6c 6f 62 61 6c 2d 64 65 6c 74 61 2a 29 *global-delta*)
6860: 29 0a 09 09 20 20 20 20 20 20 28 6c 6f 6f 70 20 )... (loop
6870: 28 63 61 72 20 6e 65 77 74 61 6c 29 28 63 64 72 (car newtal)(cdr
6880: 20 6e 65 77 74 61 6c 29 20 72 65 72 75 6e 73 29 newtal) reruns)
6890: 29 29 29 29 20 3b 3b 20 45 4e 44 20 4f 46 20 28 )))) ;; END OF (
68a0: 6f 72 20 28 70 72 6f 63 65 64 75 72 65 3f 20 69 or (procedure? i
68b0: 74 65 6d 73 29 28 65 71 3f 20 69 74 65 6d 73 20 tems)(eq? items
68c0: 27 68 61 76 65 2d 70 72 6f 63 65 64 75 72 65 29 'have-procedure)
68d0: 29 0a 09 20 20 20 20 20 0a 09 20 20 20 20 20 3b ).. .. ;
68e0: 3b 20 74 68 69 73 20 63 61 73 65 20 73 68 6f 75 ; this case shou
68f0: 6c 64 20 6e 6f 74 20 68 61 70 70 65 6e 2c 20 61 ld not happen, a
6900: 64 64 65 64 20 74 6f 20 68 65 6c 70 20 63 61 74 dded to help cat
6910: 63 68 20 61 6e 79 20 62 75 67 73 0a 09 20 20 20 ch any bugs..
6920: 20 20 28 28 61 6e 64 20 28 6c 69 73 74 3f 20 69 ((and (list? i
6930: 74 65 6d 73 29 20 69 74 65 6d 64 61 74 29 0a 09 tems) itemdat)..
6940: 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 (debug:pri
6950: 6e 74 20 30 20 22 45 52 52 4f 52 3a 20 53 68 6f nt 0 "ERROR: Sho
6960: 75 6c 64 20 6e 6f 74 20 68 61 76 65 20 61 20 6c uld not have a l
6970: 69 73 74 20 6f 66 20 69 74 65 6d 73 20 69 6e 20 ist of items in
6980: 61 20 74 65 73 74 20 61 6e 64 20 74 68 65 20 69 a test and the i
6990: 74 65 6d 73 70 61 74 68 20 73 65 74 20 2d 20 70 temspath set - p
69a0: 6c 65 61 73 65 20 72 65 70 6f 72 74 20 74 68 69 lease report thi
69b0: 73 22 29 0a 09 20 20 20 20 20 20 28 65 78 69 74 s").. (exit
69c0: 20 31 29 29 0a 09 20 20 20 20 20 28 28 6e 6f 74 1)).. ((not
69d0: 20 28 6e 75 6c 6c 3f 20 72 65 72 75 6e 73 29 29 (null? reruns))
69e0: 0a 09 20 20 20 20 20 20 28 6c 65 74 2a 20 28 28 .. (let* ((
69f0: 6e 65 77 6c 73 74 20 28 74 65 73 74 73 3a 66 69 newlst (tests:fi
6a00: 6c 74 65 72 2d 6e 6f 6e 2d 72 75 6e 6e 61 62 6c lter-non-runnabl
6a10: 65 20 72 75 6e 2d 69 64 20 74 61 6c 20 74 65 73 e run-id tal tes
6a20: 74 2d 72 65 63 6f 72 64 73 29 29 20 3b 3b 20 69 t-records)) ;; i
6a30: 2e 65 2e 20 6e 6f 74 20 46 41 49 4c 2c 20 57 41 .e. not FAIL, WA
6a40: 49 56 45 44 2c 20 49 4e 43 4f 4d 50 4c 45 54 45 IVED, INCOMPLETE
6a50: 2c 20 50 41 53 53 2c 20 4b 49 4c 4c 45 44 2c 0a , PASS, KILLED,.
6a60: 09 09 20 20 20 20 20 28 6a 75 6e 6b 65 64 20 28 .. (junked (
6a70: 6c 73 65 74 2d 64 69 66 66 65 72 65 6e 63 65 20 lset-difference
6a80: 65 71 75 61 6c 3f 20 74 61 6c 20 6e 65 77 6c 73 equal? tal newls
6a90: 74 29 29 29 0a 09 09 28 64 65 62 75 67 3a 70 72 t)))...(debug:pr
6aa0: 69 6e 74 2d 69 6e 66 6f 20 34 20 22 66 75 6c 6c int-info 4 "full
6ab0: 20 64 72 6f 70 20 74 68 72 6f 75 67 68 2c 20 69 drop through, i
6ac0: 66 20 72 65 72 75 6e 73 20 69 73 20 6c 65 73 73 f reruns is less
6ad0: 20 74 68 61 6e 20 31 30 30 20 77 65 20 77 69 6c than 100 we wil
6ae0: 6c 20 66 6f 72 63 65 20 72 65 74 72 79 20 74 68 l force retry th
6af0: 65 6d 2c 20 72 65 72 75 6e 73 3d 22 20 72 65 72 em, reruns=" rer
6b00: 75 6e 73 20 22 2c 20 74 61 6c 3d 22 20 74 61 6c uns ", tal=" tal
6b10: 29 0a 09 09 28 69 66 20 28 3c 20 6e 75 6d 2d 72 )...(if (< num-r
6b20: 65 74 72 69 65 73 20 6d 61 78 2d 72 65 74 72 69 etries max-retri
6b30: 65 73 29 0a 09 09 20 20 20 20 28 73 65 74 21 20 es)... (set!
6b40: 6e 65 77 6c 73 74 20 28 61 70 70 65 6e 64 20 72 newlst (append r
6b50: 65 72 75 6e 73 20 6e 65 77 6c 73 74 29 29 29 0a eruns newlst))).
6b60: 09 09 28 73 65 74 21 20 6e 75 6d 2d 72 65 74 72 ..(set! num-retr
6b70: 69 65 73 20 28 2b 20 6e 75 6d 2d 72 65 74 72 69 ies (+ num-retri
6b80: 65 73 20 31 29 29 0a 09 09 28 74 68 72 65 61 64 es 1))...(thread
6b90: 2d 73 6c 65 65 70 21 20 28 2b 20 31 20 2a 67 6c -sleep! (+ 1 *gl
6ba0: 6f 62 61 6c 2d 64 65 6c 74 61 2a 29 29 0a 09 09 obal-delta*))...
6bb0: 28 69 66 20 28 6e 6f 74 20 28 6e 75 6c 6c 3f 20 (if (not (null?
6bc0: 6e 65 77 6c 73 74 29 29 0a 09 09 20 20 20 20 3b newlst))... ;
6bd0: 3b 20 73 69 6e 63 65 20 72 65 72 75 6e 73 20 68 ; since reruns h
6be0: 61 76 65 20 62 65 65 6e 20 74 61 63 6b 65 64 20 ave been tacked
6bf0: 6f 6e 20 74 6f 20 6e 65 77 6c 73 74 20 63 72 65 on to newlst cre
6c00: 61 74 65 20 6e 65 77 20 72 65 72 75 6e 73 20 66 ate new reruns f
6c10: 72 6f 6d 20 6a 75 6e 6b 65 64 0a 09 09 20 20 20 rom junked...
6c20: 20 28 6c 6f 6f 70 20 28 63 61 72 20 6e 65 77 6c (loop (car newl
6c30: 73 74 29 28 63 64 72 20 6e 65 77 6c 73 74 29 28 st)(cdr newlst)(
6c40: 64 65 6c 65 74 65 2d 64 75 70 6c 69 63 61 74 65 delete-duplicate
6c50: 73 20 6a 75 6e 6b 65 64 29 29 29 29 29 0a 09 20 s junked)))))..
6c60: 20 20 20 20 28 28 6e 6f 74 20 28 6e 75 6c 6c 3f ((not (null?
6c70: 20 74 61 6c 29 29 0a 09 20 20 20 20 20 20 28 64 tal)).. (d
6c80: 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 ebug:print-info
6c90: 34 20 22 49 27 6d 20 70 72 65 74 74 79 20 73 75 4 "I'm pretty su
6ca0: 72 65 20 49 20 73 68 6f 75 6c 64 6e 27 74 20 67 re I shouldn't g
6cb0: 65 74 20 68 65 72 65 2e 22 29 29 0a 09 20 20 20 et here."))..
6cc0: 20 20 28 65 6c 73 65 0a 09 20 20 20 20 20 20 28 (else.. (
6cd0: 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f debug:print-info
6ce0: 20 34 20 22 45 78 69 74 69 6e 67 20 6c 6f 6f 70 4 "Exiting loop
6cf0: 20 77 69 74 68 2e 2e 2e 5c 6e 20 20 68 65 64 3d with...\n hed=
6d00: 22 20 68 65 64 20 22 5c 6e 20 20 74 61 6c 3d 22 " hed "\n tal="
6d10: 20 74 61 6c 20 22 5c 6e 20 20 72 65 72 75 6e 73 tal "\n reruns
6d20: 3d 22 20 72 65 72 75 6e 73 29 29 0a 09 20 20 20 =" reruns))..
6d30: 20 20 29 29 29 29 20 3b 3b 20 4c 45 54 2a 20 28 )))) ;; LET* (
6d40: 28 74 65 73 74 2d 72 65 63 6f 72 64 0a 0a 20 20 (test-record..
6d50: 20 20 3b 3b 20 77 65 20 67 65 74 20 68 65 72 65 ;; we get here
6d60: 20 6f 6e 20 22 64 72 6f 70 20 74 68 72 6f 75 67 on "drop throug
6d70: 68 22 20 2d 20 6c 6f 6f 70 20 66 6f 72 20 6e 65 h" - loop for ne
6d80: 78 74 20 74 65 73 74 20 69 6e 20 71 75 65 75 65 xt test in queue
6d90: 0a 20 20 20 20 3b 3b 20 46 49 58 4d 45 21 21 21 . ;; FIXME!!!
6da0: 21 20 54 48 49 53 20 53 48 4f 55 4c 44 20 4e 4f ! THIS SHOULD NO
6db0: 54 20 52 45 51 55 49 52 45 20 41 4e 20 45 58 49 T REQUIRE AN EXI
6dc0: 54 21 21 21 21 21 21 21 0a 20 20 20 20 0a 20 20 T!!!!!!!. .
6dd0: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 (debug:print-i
6de0: 6e 66 6f 20 31 20 22 41 6c 6c 20 74 65 73 74 73 nfo 1 "All tests
6df0: 20 6c 61 75 6e 63 68 65 64 22 29 0a 20 20 20 20 launched").
6e00: 28 74 68 72 65 61 64 2d 73 6c 65 65 70 21 20 30 (thread-sleep! 0
6e10: 2e 35 29 0a 20 20 20 20 3b 3b 20 46 49 58 4d 45 .5). ;; FIXME
6e20: 21 20 54 68 69 73 20 68 61 72 73 68 20 65 78 69 ! This harsh exi
6e30: 74 20 73 68 6f 75 6c 64 20 6e 6f 74 20 62 65 20 t should not be
6e40: 6e 65 63 65 73 73 61 72 79 2e 2e 2e 2e 0a 20 20 necessary.....
6e50: 20 20 3b 3b 20 28 69 66 20 28 6e 6f 74 20 2a 72 ;; (if (not *r
6e60: 75 6e 72 65 6d 6f 74 65 2a 29 28 65 78 69 74 29 unremote*)(exit)
6e70: 29 20 3b 3b 20 0a 20 20 20 20 23 66 29 29 20 3b ) ;; . #f)) ;
6e80: 3b 20 72 65 74 75 72 6e 20 61 20 23 66 20 61 73 ; return a #f as
6e90: 20 61 20 68 69 6e 74 20 74 68 61 74 20 77 65 20 a hint that we
6ea0: 61 72 65 20 64 6f 6e 65 0a 20 20 3b 3b 20 48 65 are done. ;; He
6eb0: 72 65 20 77 65 20 6e 65 65 64 20 74 6f 20 63 68 re we need to ch
6ec0: 65 63 6b 20 74 68 61 74 20 61 6c 6c 20 74 68 65 eck that all the
6ed0: 20 74 65 73 74 73 20 72 65 6d 61 69 6e 69 6e 67 tests remaining
6ee0: 20 74 6f 20 62 65 20 72 75 6e 20 61 72 65 20 65 to be run are e
6ef0: 6c 69 67 69 62 6c 65 20 74 6f 20 72 75 6e 0a 20 ligible to run.
6f00: 20 3b 3b 20 61 6e 64 20 61 72 65 20 6e 6f 74 20 ;; and are not
6f10: 62 6c 6f 63 6b 65 64 20 62 79 20 66 61 69 6c 65 blocked by faile
6f20: 64 0a 20 20 0a 0a 3b 3b 20 70 61 72 65 6e 74 2d d. ..;; parent-
6f30: 74 65 73 74 20 69 73 20 74 68 65 72 65 20 61 73 test is there as
6f40: 20 61 20 70 6c 61 63 65 68 6f 6c 64 65 72 20 66 a placeholder f
6f50: 6f 72 20 77 68 65 6e 20 70 61 72 65 6e 74 2d 74 or when parent-t
6f60: 65 73 74 73 20 63 61 6e 20 62 65 20 72 75 6e 20 ests can be run
6f70: 61 73 20 61 20 73 65 74 75 70 20 73 74 65 70 0a as a setup step.
6f80: 28 64 65 66 69 6e 65 20 28 72 75 6e 3a 74 65 73 (define (run:tes
6f90: 74 20 72 75 6e 2d 69 64 20 72 75 6e 6e 61 6d 65 t run-id runname
6fa0: 20 6b 65 79 76 61 6c 6c 73 74 20 74 65 73 74 2d keyvallst test-
6fb0: 72 65 63 6f 72 64 20 66 6c 61 67 73 20 70 61 72 record flags par
6fc0: 65 6e 74 2d 74 65 73 74 29 0a 20 20 3b 3b 20 41 ent-test). ;; A
6fd0: 6c 6c 20 74 68 65 73 65 20 76 61 72 73 20 6d 69 ll these vars mi
6fe0: 67 68 74 20 62 65 20 72 65 66 65 72 65 6e 63 65 ght be reference
6ff0: 64 20 62 79 20 74 68 65 20 74 65 73 74 63 6f 6e d by the testcon
7000: 66 69 67 20 66 69 6c 65 20 72 65 61 64 65 72 0a fig file reader.
7010: 20 20 28 6c 65 74 2a 20 28 28 74 65 73 74 2d 6e (let* ((test-n
7020: 61 6d 65 20 20 20 20 28 74 65 73 74 73 3a 74 65 ame (tests:te
7030: 73 74 71 75 65 75 65 2d 67 65 74 2d 74 65 73 74 stqueue-get-test
7040: 6e 61 6d 65 20 20 20 74 65 73 74 2d 72 65 63 6f name test-reco
7050: 72 64 29 29 0a 09 20 28 74 65 73 74 2d 77 61 69 rd)).. (test-wai
7060: 74 6f 6e 73 20 28 74 65 73 74 73 3a 74 65 73 74 tons (tests:test
7070: 71 75 65 75 65 2d 67 65 74 2d 77 61 69 74 6f 6e queue-get-waiton
7080: 73 20 20 20 20 74 65 73 74 2d 72 65 63 6f 72 64 s test-record
7090: 29 29 0a 09 20 28 74 65 73 74 2d 63 6f 6e 66 20 )).. (test-conf
70a0: 20 20 20 28 74 65 73 74 73 3a 74 65 73 74 71 75 (tests:testqu
70b0: 65 75 65 2d 67 65 74 2d 74 65 73 74 63 6f 6e 66 eue-get-testconf
70c0: 69 67 20 74 65 73 74 2d 72 65 63 6f 72 64 29 29 ig test-record))
70d0: 0a 09 20 28 69 74 65 6d 64 61 74 20 20 20 20 20 .. (itemdat
70e0: 20 28 74 65 73 74 73 3a 74 65 73 74 71 75 65 75 (tests:testqueu
70f0: 65 2d 67 65 74 2d 69 74 65 6d 64 61 74 20 20 20 e-get-itemdat
7100: 20 74 65 73 74 2d 72 65 63 6f 72 64 29 29 0a 09 test-record))..
7110: 20 28 74 65 73 74 2d 70 61 74 68 20 20 20 20 28 (test-path (
7120: 63 6f 6e 63 20 2a 74 6f 70 70 61 74 68 2a 20 22 conc *toppath* "
7130: 2f 74 65 73 74 73 2f 22 20 74 65 73 74 2d 6e 61 /tests/" test-na
7140: 6d 65 29 29 20 3b 3b 20 63 6f 75 6c 64 20 75 73 me)) ;; could us
7150: 65 20 74 65 73 74 73 3a 67 65 74 2d 74 65 73 74 e tests:get-test
7160: 63 6f 6e 66 69 67 20 68 65 72 65 20 2e 2e 2e 0a config here ....
7170: 09 20 28 66 6f 72 63 65 20 20 20 20 20 20 20 20 . (force
7180: 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f (hash-table-ref/
7190: 64 65 66 61 75 6c 74 20 66 6c 61 67 73 20 22 2d default flags "-
71a0: 66 6f 72 63 65 22 20 23 66 29 29 0a 09 20 28 72 force" #f)).. (r
71b0: 65 72 75 6e 20 20 20 20 20 20 20 20 28 68 61 73 erun (has
71c0: 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 h-table-ref/defa
71d0: 75 6c 74 20 66 6c 61 67 73 20 22 2d 72 65 72 75 ult flags "-reru
71e0: 6e 22 20 23 66 29 29 0a 09 20 28 6b 65 65 70 67 n" #f)).. (keepg
71f0: 6f 69 6e 67 20 20 20 20 28 68 61 73 68 2d 74 61 oing (hash-ta
7200: 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 ble-ref/default
7210: 66 6c 61 67 73 20 22 2d 6b 65 65 70 67 6f 69 6e flags "-keepgoin
7220: 67 22 20 23 66 29 29 0a 09 20 28 69 74 65 6d 2d g" #f)).. (item-
7230: 70 61 74 68 20 20 20 20 20 22 22 29 0a 09 20 28 path "").. (
7240: 64 62 20 20 20 20 20 20 20 20 20 20 20 23 66 29 db #f)
7250: 29 0a 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 ). (debug:pri
7260: 6e 74 20 34 0a 09 09 20 22 74 65 73 74 2d 63 6f nt 4... "test-co
7270: 6e 66 69 67 3a 20 22 20 28 68 61 73 68 2d 74 61 nfig: " (hash-ta
7280: 62 6c 65 2d 3e 61 6c 69 73 74 20 74 65 73 74 2d ble->alist test-
7290: 63 6f 6e 66 29 0a 09 09 20 22 5c 6e 20 20 20 69 conf)... "\n i
72a0: 74 65 6d 64 61 74 3a 20 22 20 69 74 65 6d 64 61 temdat: " itemda
72b0: 74 0a 09 09 20 29 0a 20 20 20 20 3b 3b 20 73 65 t... ). ;; se
72c0: 74 74 69 6e 67 20 69 74 65 6d 64 61 74 20 74 6f tting itemdat to
72d0: 20 61 20 6c 69 73 74 20 69 66 20 69 74 20 69 73 a list if it is
72e0: 20 23 66 0a 20 20 20 20 28 69 66 20 28 6e 6f 74 #f. (if (not
72f0: 20 69 74 65 6d 64 61 74 29 28 73 65 74 21 20 69 itemdat)(set! i
7300: 74 65 6d 64 61 74 20 27 28 29 29 29 0a 20 20 20 temdat '())).
7310: 20 28 73 65 74 21 20 69 74 65 6d 2d 70 61 74 68 (set! item-path
7320: 20 28 69 74 65 6d 2d 6c 69 73 74 2d 3e 70 61 74 (item-list->pat
7330: 68 20 69 74 65 6d 64 61 74 29 29 0a 20 20 20 20 h itemdat)).
7340: 28 64 65 62 75 67 3a 70 72 69 6e 74 20 32 20 22 (debug:print 2 "
7350: 41 74 74 65 6d 70 74 69 6e 67 20 74 6f 20 6c 61 Attempting to la
7360: 75 6e 63 68 20 74 65 73 74 20 22 20 74 65 73 74 unch test " test
7370: 2d 6e 61 6d 65 20 28 69 66 20 28 65 71 75 61 6c -name (if (equal
7380: 3f 20 69 74 65 6d 2d 70 61 74 68 20 22 2f 22 29 ? item-path "/")
7390: 20 22 2f 22 20 69 74 65 6d 2d 70 61 74 68 29 29 "/" item-path))
73a0: 0a 20 20 20 20 28 73 65 74 65 6e 76 20 22 4d 54 . (setenv "MT
73b0: 5f 54 45 53 54 5f 4e 41 4d 45 22 20 74 65 73 74 _TEST_NAME" test
73c0: 2d 6e 61 6d 65 29 20 3b 3b 20 0a 20 20 20 20 28 -name) ;; . (
73d0: 73 65 74 65 6e 76 20 22 4d 54 5f 52 55 4e 4e 41 setenv "MT_RUNNA
73e0: 4d 45 22 20 20 20 72 75 6e 6e 61 6d 65 29 0a 20 ME" runname).
73f0: 20 20 20 28 73 65 74 2d 6d 65 67 61 74 65 73 74 (set-megatest
7400: 2d 65 6e 76 2d 76 61 72 73 20 72 75 6e 2d 69 64 -env-vars run-id
7410: 29 20 3b 3b 20 74 68 65 73 65 20 6d 61 79 20 62 ) ;; these may b
7420: 65 20 6e 65 65 64 65 64 20 62 79 20 74 68 65 20 e needed by the
7430: 6c 61 75 6e 63 68 69 6e 67 20 70 72 6f 63 65 73 launching proces
7440: 73 0a 20 20 20 20 28 63 68 61 6e 67 65 2d 64 69 s. (change-di
7450: 72 65 63 74 6f 72 79 20 2a 74 6f 70 70 61 74 68 rectory *toppath
7460: 2a 29 0a 0a 20 20 20 20 3b 3b 20 48 65 72 65 20 *).. ;; Here
7470: 69 73 20 77 68 65 72 65 20 74 68 65 20 74 65 73 is where the tes
7480: 74 5f 6d 65 74 61 20 74 61 62 6c 65 20 69 73 20 t_meta table is
7490: 62 65 73 74 20 75 70 64 61 74 65 64 0a 20 20 20 best updated.
74a0: 20 3b 3b 20 59 65 73 2c 20 61 6e 6f 74 68 65 72 ;; Yes, another
74b0: 20 75 73 65 20 6f 66 20 61 20 67 6c 6f 62 61 6c use of a global
74c0: 20 66 6f 72 20 63 61 63 68 69 6e 67 2e 20 4e 65 for caching. Ne
74d0: 65 64 20 61 20 62 65 74 74 65 72 20 77 61 79 3f ed a better way?
74e0: 0a 20 20 20 20 28 69 66 20 28 6e 6f 74 20 28 68 . (if (not (h
74f0: 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 ash-table-ref/de
7500: 66 61 75 6c 74 20 2a 74 65 73 74 2d 6d 65 74 61 fault *test-meta
7510: 2d 75 70 64 61 74 65 64 2a 20 74 65 73 74 2d 6e -updated* test-n
7520: 61 6d 65 20 23 66 29 29 0a 20 20 20 20 20 20 20 ame #f)).
7530: 20 28 62 65 67 69 6e 0a 09 20 20 20 28 68 61 73 (begin.. (has
7540: 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 2a 74 65 h-table-set! *te
7550: 73 74 2d 6d 65 74 61 2d 75 70 64 61 74 65 64 2a st-meta-updated*
7560: 20 74 65 73 74 2d 6e 61 6d 65 20 23 74 29 0a 20 test-name #t).
7570: 20 20 20 20 20 20 20 20 20 20 28 6f 70 65 6e 2d (open-
7580: 72 75 6e 2d 63 6c 6f 73 65 20 72 75 6e 73 3a 75 run-close runs:u
7590: 70 64 61 74 65 2d 74 65 73 74 5f 6d 65 74 61 20 pdate-test_meta
75a0: 64 62 20 74 65 73 74 2d 6e 61 6d 65 20 74 65 73 db test-name tes
75b0: 74 2d 63 6f 6e 66 29 29 29 0a 20 20 20 20 0a 20 t-conf))). .
75c0: 20 20 20 3b 3b 20 28 6c 61 6d 62 64 61 20 28 69 ;; (lambda (i
75d0: 74 65 6d 64 61 74 29 20 3b 3b 3b 20 28 28 72 69 temdat) ;;; ((ri
75e0: 70 65 6e 65 73 73 20 22 6f 76 65 72 72 69 70 65 peness "overripe
75f0: 22 29 20 28 74 65 6d 70 65 72 61 74 75 72 65 20 ") (temperature
7600: 22 63 6f 6f 6c 22 29 20 28 73 65 61 73 6f 6e 20 "cool") (season
7610: 22 73 75 6d 6d 65 72 22 29 29 0a 20 20 20 20 28 "summer")). (
7620: 6c 65 74 2a 20 28 28 6e 65 77 2d 74 65 73 74 2d let* ((new-test-
7630: 70 61 74 68 20 28 73 74 72 69 6e 67 2d 69 6e 74 path (string-int
7640: 65 72 73 70 65 72 73 65 20 28 63 6f 6e 73 20 74 ersperse (cons t
7650: 65 73 74 2d 70 61 74 68 20 28 6d 61 70 20 63 61 est-path (map ca
7660: 64 72 20 69 74 65 6d 64 61 74 29 29 20 22 2f 22 dr itemdat)) "/"
7670: 29 29 0a 09 20 20 20 28 6e 65 77 2d 74 65 73 74 )).. (new-test
7680: 2d 6e 61 6d 65 20 28 69 66 20 28 65 71 75 61 6c -name (if (equal
7690: 3f 20 69 74 65 6d 2d 70 61 74 68 20 22 22 29 20 ? item-path "")
76a0: 74 65 73 74 2d 6e 61 6d 65 20 28 63 6f 6e 63 20 test-name (conc
76b0: 74 65 73 74 2d 6e 61 6d 65 20 22 2f 22 20 69 74 test-name "/" it
76c0: 65 6d 2d 70 61 74 68 29 29 29 20 3b 3b 20 6a 75 em-path))) ;; ju
76d0: 73 74 20 6e 65 65 64 20 69 74 20 74 6f 20 62 65 st need it to be
76e0: 20 75 6e 69 71 75 65 0a 09 20 20 20 28 74 65 73 unique.. (tes
76f0: 74 2d 69 64 20 20 20 20 20 20 20 28 63 64 62 3a t-id (cdb:
7700: 72 65 6d 6f 74 65 2d 72 75 6e 20 64 62 3a 67 65 remote-run db:ge
7710: 74 2d 74 65 73 74 2d 69 64 20 23 66 20 20 72 75 t-test-id #f ru
7720: 6e 2d 69 64 20 74 65 73 74 2d 6e 61 6d 65 20 69 n-id test-name i
7730: 74 65 6d 2d 70 61 74 68 29 29 0a 09 20 20 20 28 tem-path)).. (
7740: 74 65 73 74 64 61 74 20 20 20 20 20 20 20 28 63 testdat (c
7750: 64 62 3a 67 65 74 2d 74 65 73 74 2d 69 6e 66 6f db:get-test-info
7760: 2d 62 79 2d 69 64 20 2a 72 75 6e 72 65 6d 6f 74 -by-id *runremot
7770: 65 2a 20 74 65 73 74 2d 69 64 29 29 29 0a 20 20 e* test-id))).
7780: 20 20 20 20 28 69 66 20 28 6e 6f 74 20 74 65 73 (if (not tes
7790: 74 64 61 74 29 0a 09 20 20 28 62 65 67 69 6e 0a tdat).. (begin.
77a0: 09 20 20 20 20 3b 3b 20 65 6e 73 75 72 65 20 74 . ;; ensure t
77b0: 68 61 74 20 74 68 65 20 70 61 74 68 20 65 78 69 hat the path exi
77c0: 73 74 73 20 62 65 66 6f 72 65 20 72 65 67 69 73 sts before regis
77d0: 74 65 72 69 6e 67 20 74 68 65 20 74 65 73 74 0a tering the test.
77e0: 09 20 20 20 20 3b 3b 20 4e 4f 50 45 3a 20 43 61 . ;; NOPE: Ca
77f0: 6e 6e 6f 74 21 20 44 6f 6e 27 74 20 6b 6e 6f 77 nnot! Don't know
7800: 20 79 65 74 20 77 68 69 63 68 20 64 69 73 6b 20 yet which disk
7810: 61 72 65 61 20 77 69 6c 6c 20 62 65 20 61 73 73 area will be ass
7820: 69 67 6e 65 64 2e 2e 2e 2e 0a 09 20 20 20 20 3b igned...... ;
7830: 3b 20 28 73 79 73 74 65 6d 20 28 63 6f 6e 63 20 ; (system (conc
7840: 22 6d 6b 64 69 72 20 2d 70 20 22 20 6e 65 77 2d "mkdir -p " new-
7850: 74 65 73 74 2d 70 61 74 68 29 29 0a 09 20 20 20 test-path))..
7860: 20 3b 3b 0a 09 20 20 20 20 3b 3b 20 28 6f 70 65 ;;.. ;; (ope
7870: 6e 2d 72 75 6e 2d 63 6c 6f 73 65 20 74 65 73 74 n-run-close test
7880: 73 3a 72 65 67 69 73 74 65 72 2d 74 65 73 74 20 s:register-test
7890: 64 62 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 6e db run-id test-n
78a0: 61 6d 65 20 69 74 65 6d 2d 70 61 74 68 29 0a 09 ame item-path)..
78b0: 20 20 20 20 3b 3b 0a 09 20 20 20 20 3b 3b 20 4e ;;.. ;; N
78c0: 42 2f 2f 20 66 6f 72 20 74 68 65 20 61 62 6f 76 B// for the abov
78d0: 65 20 6c 69 6e 65 2e 20 49 20 77 61 6e 74 20 74 e line. I want t
78e0: 68 65 20 74 65 73 74 20 74 6f 20 62 65 20 72 65 he test to be re
78f0: 67 69 73 74 65 72 65 64 20 6c 6f 6e 67 20 62 65 gistered long be
7900: 66 6f 72 65 20 74 68 69 73 20 72 6f 75 74 69 6e fore this routin
7910: 65 20 67 65 74 73 20 63 61 6c 6c 65 64 21 0a 09 e gets called!..
7920: 20 20 20 20 3b 3b 0a 09 20 20 20 20 28 73 65 74 ;;.. (set
7930: 21 20 74 65 73 74 2d 69 64 20 28 6f 70 65 6e 2d ! test-id (open-
7940: 72 75 6e 2d 63 6c 6f 73 65 20 64 62 3a 67 65 74 run-close db:get
7950: 2d 74 65 73 74 2d 69 64 20 64 62 20 72 75 6e 2d -test-id db run-
7960: 69 64 20 74 65 73 74 2d 6e 61 6d 65 20 69 74 65 id test-name ite
7970: 6d 2d 70 61 74 68 29 29 0a 09 20 20 20 20 28 69 m-path)).. (i
7980: 66 20 28 6e 6f 74 20 74 65 73 74 2d 69 64 29 0a f (not test-id).
7990: 09 09 28 62 65 67 69 6e 0a 09 09 20 20 28 64 65 ..(begin... (de
79a0: 62 75 67 3a 70 72 69 6e 74 20 32 20 22 57 41 52 bug:print 2 "WAR
79b0: 4e 3a 20 54 65 73 74 20 6e 6f 74 20 70 72 65 2d N: Test not pre-
79c0: 63 72 65 61 74 65 64 3f 20 74 65 73 74 2d 6e 61 created? test-na
79d0: 6d 65 3d 22 20 74 65 73 74 2d 6e 61 6d 65 20 22 me=" test-name "
79e0: 2c 20 69 74 65 6d 2d 70 61 74 68 3d 22 20 69 74 , item-path=" it
79f0: 65 6d 2d 70 61 74 68 20 22 2c 20 72 75 6e 2d 69 em-path ", run-i
7a00: 64 3d 22 20 72 75 6e 2d 69 64 29 0a 09 09 20 20 d=" run-id)...
7a10: 28 6f 70 65 6e 2d 72 75 6e 2d 63 6c 6f 73 65 20 (open-run-close
7a20: 64 62 3a 74 65 73 74 73 2d 72 65 67 69 73 74 65 db:tests-registe
7a30: 72 2d 74 65 73 74 20 23 66 20 72 75 6e 2d 69 64 r-test #f run-id
7a40: 20 74 65 73 74 2d 6e 61 6d 65 20 69 74 65 6d 2d test-name item-
7a50: 70 61 74 68 29 0a 09 09 20 20 28 73 65 74 21 20 path)... (set!
7a60: 74 65 73 74 2d 69 64 20 28 6f 70 65 6e 2d 72 75 test-id (open-ru
7a70: 6e 2d 63 6c 6f 73 65 20 64 62 3a 67 65 74 2d 74 n-close db:get-t
7a80: 65 73 74 2d 69 64 20 64 62 20 72 75 6e 2d 69 64 est-id db run-id
7a90: 20 74 65 73 74 2d 6e 61 6d 65 20 69 74 65 6d 2d test-name item-
7aa0: 70 61 74 68 29 29 29 29 0a 09 20 20 20 20 28 64 path)))).. (d
7ab0: 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 ebug:print-info
7ac0: 34 20 22 74 65 73 74 2d 69 64 3d 22 20 74 65 73 4 "test-id=" tes
7ad0: 74 2d 69 64 20 22 2c 20 72 75 6e 2d 69 64 3d 22 t-id ", run-id="
7ae0: 20 72 75 6e 2d 69 64 20 22 2c 20 74 65 73 74 2d run-id ", test-
7af0: 6e 61 6d 65 3d 22 20 74 65 73 74 2d 6e 61 6d 65 name=" test-name
7b00: 20 22 2c 20 69 74 65 6d 2d 70 61 74 68 3d 5c 22 ", item-path=\"
7b10: 22 20 69 74 65 6d 2d 70 61 74 68 20 22 5c 22 22 " item-path "\""
7b20: 29 0a 09 20 20 20 20 28 73 65 74 21 20 74 65 73 ).. (set! tes
7b30: 74 64 61 74 20 28 63 64 62 3a 67 65 74 2d 74 65 tdat (cdb:get-te
7b40: 73 74 2d 69 6e 66 6f 2d 62 79 2d 69 64 20 2a 72 st-info-by-id *r
7b50: 75 6e 72 65 6d 6f 74 65 2a 20 74 65 73 74 2d 69 unremote* test-i
7b60: 64 29 29 29 29 0a 20 20 20 20 20 20 28 73 65 74 d)))). (set
7b70: 21 20 74 65 73 74 2d 69 64 20 28 64 62 3a 74 65 ! test-id (db:te
7b80: 73 74 2d 67 65 74 2d 69 64 20 74 65 73 74 64 61 st-get-id testda
7b90: 74 29 29 0a 20 20 20 20 20 20 28 63 68 61 6e 67 t)). (chang
7ba0: 65 2d 64 69 72 65 63 74 6f 72 79 20 74 65 73 74 e-directory test
7bb0: 2d 70 61 74 68 29 0a 20 20 20 20 20 20 28 63 61 -path). (ca
7bc0: 73 65 20 28 69 66 20 66 6f 72 63 65 20 3b 3b 20 se (if force ;;
7bd0: 28 61 72 67 73 3a 67 65 74 2d 61 72 67 20 22 2d (args:get-arg "-
7be0: 66 6f 72 63 65 22 29 0a 09 09 27 4e 4f 54 5f 53 force")...'NOT_S
7bf0: 54 41 52 54 45 44 0a 09 09 28 69 66 20 74 65 73 TARTED...(if tes
7c00: 74 64 61 74 0a 09 09 20 20 20 20 28 73 74 72 69 tdat... (stri
7c10: 6e 67 2d 3e 73 79 6d 62 6f 6c 20 28 74 65 73 74 ng->symbol (test
7c20: 3a 67 65 74 2d 73 74 61 74 65 20 74 65 73 74 64 :get-state testd
7c30: 61 74 29 29 0a 09 09 20 20 20 20 27 66 61 69 6c at))... 'fail
7c40: 65 64 2d 74 6f 2d 69 6e 73 65 72 74 29 29 0a 09 ed-to-insert))..
7c50: 28 28 66 61 69 6c 65 64 2d 74 6f 2d 69 6e 73 65 ((failed-to-inse
7c60: 72 74 29 0a 09 20 28 64 65 62 75 67 3a 70 72 69 rt).. (debug:pri
7c70: 6e 74 20 30 20 22 45 52 52 4f 52 3a 20 46 61 69 nt 0 "ERROR: Fai
7c80: 6c 65 64 20 74 6f 20 69 6e 73 65 72 74 20 74 68 led to insert th
7c90: 65 20 72 65 63 6f 72 64 20 69 6e 74 6f 20 74 68 e record into th
7ca0: 65 20 64 62 22 29 29 0a 09 28 28 4e 4f 54 5f 53 e db"))..((NOT_S
7cb0: 54 41 52 54 45 44 20 43 4f 4d 50 4c 45 54 45 44 TARTED COMPLETED
7cc0: 20 44 45 4c 45 54 45 44 29 0a 09 20 28 6c 65 74 DELETED).. (let
7cd0: 20 28 28 72 75 6e 66 6c 61 67 20 23 66 29 29 0a ((runflag #f)).
7ce0: 09 20 20 20 28 63 6f 6e 64 0a 09 20 20 20 20 3b . (cond.. ;
7cf0: 3b 20 2d 66 6f 72 63 65 2c 20 72 75 6e 20 6e 6f ; -force, run no
7d00: 20 6d 61 74 74 65 72 20 77 68 61 74 0a 09 20 20 matter what..
7d10: 20 20 28 66 6f 72 63 65 20 28 73 65 74 21 20 72 (force (set! r
7d20: 75 6e 66 6c 61 67 20 23 74 29 29 0a 09 20 20 20 unflag #t))..
7d30: 20 3b 3b 20 4e 4f 54 5f 53 54 41 52 54 45 44 2c ;; NOT_STARTED,
7d40: 20 72 75 6e 20 6e 6f 20 6d 61 74 74 65 72 20 77 run no matter w
7d50: 68 61 74 0a 09 20 20 20 20 28 28 6d 65 6d 62 65 hat.. ((membe
7d60: 72 20 28 74 65 73 74 3a 67 65 74 2d 73 74 61 74 r (test:get-stat
7d70: 65 20 74 65 73 74 64 61 74 29 20 27 28 22 44 45 e testdat) '("DE
7d80: 4c 45 54 45 44 22 20 22 4e 4f 54 5f 53 54 41 52 LETED" "NOT_STAR
7d90: 54 45 44 22 29 29 28 73 65 74 21 20 72 75 6e 66 TED"))(set! runf
7da0: 6c 61 67 20 23 74 29 29 0a 09 20 20 20 20 3b 3b lag #t)).. ;;
7db0: 20 6e 6f 74 20 2d 72 65 72 75 6e 20 61 6e 64 20 not -rerun and
7dc0: 50 41 53 53 2c 20 57 41 52 4e 20 6f 72 20 43 48 PASS, WARN or CH
7dd0: 45 43 4b 2c 20 64 6f 20 6e 6f 20 72 75 6e 0a 09 ECK, do no run..
7de0: 20 20 20 20 28 28 61 6e 64 20 28 6f 72 20 28 6e ((and (or (n
7df0: 6f 74 20 72 65 72 75 6e 29 0a 09 09 20 20 20 20 ot rerun)...
7e00: 20 20 6b 65 65 70 67 6f 69 6e 67 29 0a 09 09 20 keepgoing)...
7e10: 20 3b 3b 20 52 65 71 75 69 72 65 20 74 6f 20 66 ;; Require to f
7e20: 6f 72 63 65 20 72 65 2d 72 75 6e 20 66 6f 72 20 orce re-run for
7e30: 43 4f 4d 50 4c 45 54 45 44 20 6f 72 20 2a 61 6e COMPLETED or *an
7e40: 79 74 68 69 6e 67 2a 20 2b 20 50 41 53 53 2c 57 ything* + PASS,W
7e50: 41 52 4e 20 6f 72 20 43 48 45 43 4b 0a 09 09 20 ARN or CHECK...
7e60: 20 28 6f 72 20 28 6d 65 6d 62 65 72 20 28 74 65 (or (member (te
7e70: 73 74 3a 67 65 74 2d 73 74 61 74 75 73 20 74 65 st:get-status te
7e80: 73 74 64 61 74 29 20 27 28 22 50 41 53 53 22 20 stdat) '("PASS"
7e90: 22 57 41 52 4e 22 20 22 43 48 45 43 4b 22 29 29 "WARN" "CHECK"))
7ea0: 0a 09 09 20 20 20 20 20 20 28 6d 65 6d 62 65 72 ... (member
7eb0: 20 28 74 65 73 74 3a 67 65 74 2d 73 74 61 74 65 (test:get-state
7ec0: 20 20 74 65 73 74 64 61 74 29 20 27 28 22 43 4f testdat) '("CO
7ed0: 4d 50 4c 45 54 45 44 22 29 29 29 29 20 0a 09 20 MPLETED")))) ..
7ee0: 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 (debug:print
7ef0: 2d 69 6e 66 6f 20 32 20 22 72 75 6e 6e 69 6e 67 -info 2 "running
7f00: 20 74 65 73 74 20 22 20 74 65 73 74 2d 6e 61 6d test " test-nam
7f10: 65 20 22 2f 22 20 69 74 65 6d 2d 70 61 74 68 20 e "/" item-path
7f20: 22 20 73 75 70 70 72 65 73 73 65 64 20 61 73 20 " suppressed as
7f30: 69 74 20 69 73 20 22 20 28 74 65 73 74 3a 67 65 it is " (test:ge
7f40: 74 2d 73 74 61 74 65 20 74 65 73 74 64 61 74 29 t-state testdat)
7f50: 20 22 20 61 6e 64 20 22 20 28 74 65 73 74 3a 67 " and " (test:g
7f60: 65 74 2d 73 74 61 74 75 73 20 74 65 73 74 64 61 et-status testda
7f70: 74 29 29 0a 09 20 20 20 20 20 28 73 65 74 21 20 t)).. (set!
7f80: 72 75 6e 66 6c 61 67 20 23 66 29 29 0a 09 20 20 runflag #f))..
7f90: 20 20 3b 3b 20 2d 72 65 72 75 6e 20 61 6e 64 20 ;; -rerun and
7fa0: 73 74 61 74 75 73 20 69 73 20 6f 6e 65 20 6f 66 status is one of
7fb0: 20 74 68 65 20 73 70 65 63 69 66 65 64 2c 20 72 the specifed, r
7fc0: 75 6e 20 69 74 0a 09 20 20 20 20 28 28 61 6e 64 un it.. ((and
7fd0: 20 72 65 72 75 6e 0a 09 09 20 20 28 6c 65 74 2a rerun... (let*
7fe0: 20 28 28 72 65 72 75 6e 6c 73 74 20 20 20 28 73 ((rerunlst (s
7ff0: 74 72 69 6e 67 2d 73 70 6c 69 74 20 72 65 72 75 tring-split reru
8000: 6e 20 22 2c 22 29 29 0a 09 09 09 20 28 6d 75 73 n ",")).... (mus
8010: 74 2d 72 65 72 75 6e 20 28 6d 65 6d 62 65 72 20 t-rerun (member
8020: 28 74 65 73 74 3a 67 65 74 2d 73 74 61 74 75 73 (test:get-status
8030: 20 74 65 73 74 64 61 74 29 20 72 65 72 75 6e 6c testdat) rerunl
8040: 73 74 29 29 29 0a 09 09 20 20 20 20 28 64 65 62 st)))... (deb
8050: 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 33 20 ug:print-info 3
8060: 22 2d 72 65 72 75 6e 20 6c 69 73 74 3a 20 22 20 "-rerun list: "
8070: 72 65 72 75 6e 20 22 2c 20 74 65 73 74 2d 73 74 rerun ", test-st
8080: 61 74 75 73 3a 20 22 20 28 74 65 73 74 3a 67 65 atus: " (test:ge
8090: 74 2d 73 74 61 74 75 73 20 74 65 73 74 64 61 74 t-status testdat
80a0: 29 22 2c 20 6d 75 73 74 2d 72 65 72 75 6e 3a 20 )", must-rerun:
80b0: 22 20 6d 75 73 74 2d 72 65 72 75 6e 29 0a 09 09 " must-rerun)...
80c0: 20 20 20 20 6d 75 73 74 2d 72 65 72 75 6e 29 29 must-rerun))
80d0: 0a 09 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 .. (debug:pr
80e0: 69 6e 74 2d 69 6e 66 6f 20 32 20 22 52 65 72 75 int-info 2 "Reru
80f0: 6e 20 66 6f 72 63 65 64 20 66 6f 72 20 74 65 73 n forced for tes
8100: 74 20 22 20 74 65 73 74 2d 6e 61 6d 65 20 22 2f t " test-name "/
8110: 22 20 69 74 65 6d 2d 70 61 74 68 29 0a 09 20 20 " item-path)..
8120: 20 20 20 28 73 65 74 21 20 72 75 6e 66 6c 61 67 (set! runflag
8130: 20 23 74 29 29 0a 09 20 20 20 20 3b 3b 20 2d 6b #t)).. ;; -k
8140: 65 65 70 67 6f 69 6e 67 2c 20 64 6f 20 6e 6f 74 eepgoing, do not
8150: 20 72 65 72 75 6e 20 46 41 49 4c 0a 09 20 20 20 rerun FAIL..
8160: 20 28 28 61 6e 64 20 6b 65 65 70 67 6f 69 6e 67 ((and keepgoing
8170: 0a 09 09 20 20 28 6d 65 6d 62 65 72 20 28 74 65 ... (member (te
8180: 73 74 3a 67 65 74 2d 73 74 61 74 75 73 20 74 65 st:get-status te
8190: 73 74 64 61 74 29 20 27 28 22 46 41 49 4c 22 29 stdat) '("FAIL")
81a0: 29 29 0a 09 20 20 20 20 20 28 73 65 74 21 20 72 )).. (set! r
81b0: 75 6e 66 6c 61 67 20 23 66 29 29 0a 09 20 20 20 unflag #f))..
81c0: 20 28 28 61 6e 64 20 28 6e 6f 74 20 72 65 72 75 ((and (not reru
81d0: 6e 29 0a 09 09 20 20 28 6d 65 6d 62 65 72 20 28 n)... (member (
81e0: 74 65 73 74 3a 67 65 74 2d 73 74 61 74 75 73 20 test:get-status
81f0: 74 65 73 74 64 61 74 29 20 27 28 22 46 41 49 4c testdat) '("FAIL
8200: 22 20 22 6e 2f 61 22 29 29 29 0a 09 20 20 20 20 " "n/a")))..
8210: 20 28 73 65 74 21 20 72 75 6e 66 6c 61 67 20 23 (set! runflag #
8220: 74 29 29 0a 09 20 20 20 20 28 65 6c 73 65 20 28 t)).. (else (
8230: 73 65 74 21 20 72 75 6e 66 6c 61 67 20 23 66 29 set! runflag #f)
8240: 29 29 0a 09 20 20 20 28 64 65 62 75 67 3a 70 72 )).. (debug:pr
8250: 69 6e 74 20 36 20 22 52 55 4e 4e 49 4e 47 20 3d int 6 "RUNNING =
8260: 3e 20 72 75 6e 66 6c 61 67 3a 20 22 20 72 75 6e > runflag: " run
8270: 66 6c 61 67 20 22 20 53 54 41 54 45 3a 20 22 20 flag " STATE: "
8280: 28 74 65 73 74 3a 67 65 74 2d 73 74 61 74 65 20 (test:get-state
8290: 74 65 73 74 64 61 74 29 20 22 20 53 54 41 54 55 testdat) " STATU
82a0: 53 3a 20 22 20 28 74 65 73 74 3a 67 65 74 2d 73 S: " (test:get-s
82b0: 74 61 74 75 73 20 74 65 73 74 64 61 74 29 29 0a tatus testdat)).
82c0: 09 20 20 20 28 69 66 20 28 6e 6f 74 20 72 75 6e . (if (not run
82d0: 66 6c 61 67 29 0a 09 20 20 20 20 20 20 20 28 69 flag).. (i
82e0: 66 20 28 6e 6f 74 20 70 61 72 65 6e 74 2d 74 65 f (not parent-te
82f0: 73 74 29 0a 09 09 20 20 20 28 64 65 62 75 67 3a st)... (debug:
8300: 70 72 69 6e 74 20 31 20 22 4e 4f 54 45 3a 20 4e print 1 "NOTE: N
8310: 6f 74 20 73 74 61 72 74 69 6e 67 20 74 65 73 74 ot starting test
8320: 20 22 20 6e 65 77 2d 74 65 73 74 2d 6e 61 6d 65 " new-test-name
8330: 20 22 20 61 73 20 69 74 20 69 73 20 73 74 61 74 " as it is stat
8340: 65 20 5c 22 22 20 28 74 65 73 74 3a 67 65 74 2d e \"" (test:get-
8350: 73 74 61 74 65 20 74 65 73 74 64 61 74 29 20 0a state testdat) .
8360: 09 09 09 09 22 5c 22 20 61 6e 64 20 73 74 61 74 ...."\" and stat
8370: 75 73 20 5c 22 22 20 28 74 65 73 74 3a 67 65 74 us \"" (test:get
8380: 2d 73 74 61 74 75 73 20 74 65 73 74 64 61 74 29 -status testdat)
8390: 20 22 5c 22 2c 20 75 73 65 20 2d 72 65 72 75 6e "\", use -rerun
83a0: 20 5c 22 22 20 28 74 65 73 74 3a 67 65 74 2d 73 \"" (test:get-s
83b0: 74 61 74 75 73 20 74 65 73 74 64 61 74 29 0a 20 tatus testdat).
83c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
83d0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 22 "
83e0: 5c 22 20 6f 72 20 2d 66 6f 72 63 65 20 74 6f 20 \" or -force to
83f0: 6f 76 65 72 72 69 64 65 22 29 29 0a 09 20 20 20 override"))..
8400: 20 20 20 20 3b 3b 20 4e 4f 54 45 3a 20 4e 6f 20 ;; NOTE: No
8410: 6c 6f 6e 67 65 72 20 62 65 20 63 68 65 63 6b 69 longer be checki
8420: 6e 67 20 70 72 65 72 65 71 75 69 73 69 74 65 73 ng prerequisites
8430: 20 68 65 72 65 21 20 57 69 6c 6c 20 6e 65 76 65 here! Will neve
8440: 72 20 67 65 74 20 68 65 72 65 20 75 6e 6c 65 73 r get here unles
8450: 73 20 70 72 65 72 65 71 73 20 61 72 65 0a 09 20 s prereqs are..
8460: 20 20 20 20 20 20 3b 3b 20 20 20 20 20 20 20 61 ;; a
8470: 6c 72 65 61 64 79 20 6d 65 74 2e 0a 09 20 20 20 lready met...
8480: 20 20 20 20 28 69 66 20 28 6e 6f 74 20 28 6c 61 (if (not (la
8490: 75 6e 63 68 2d 74 65 73 74 20 23 66 20 72 75 6e unch-test #f run
84a0: 2d 69 64 20 72 75 6e 6e 61 6d 65 20 74 65 73 74 -id runname test
84b0: 2d 63 6f 6e 66 20 6b 65 79 76 61 6c 6c 73 74 20 -conf keyvallst
84c0: 74 65 73 74 2d 6e 61 6d 65 20 74 65 73 74 2d 70 test-name test-p
84d0: 61 74 68 20 69 74 65 6d 64 61 74 20 66 6c 61 67 ath itemdat flag
84e0: 73 29 29 0a 09 09 20 20 20 28 62 65 67 69 6e 0a s))... (begin.
84f0: 09 09 20 20 20 20 20 28 70 72 69 6e 74 20 22 45 .. (print "E
8500: 52 52 4f 52 3a 20 46 61 69 6c 65 64 20 74 6f 20 RROR: Failed to
8510: 6c 61 75 6e 63 68 20 74 68 65 20 74 65 73 74 2e launch the test.
8520: 20 45 78 69 74 69 6e 67 20 61 73 20 73 6f 6f 6e Exiting as soon
8530: 20 61 73 20 70 6f 73 73 69 62 6c 65 22 29 0a 09 as possible")..
8540: 09 20 20 20 20 20 28 73 65 74 21 20 2a 67 6c 6f . (set! *glo
8550: 62 61 6c 65 78 69 74 73 74 61 74 75 73 2a 20 31 balexitstatus* 1
8560: 29 20 3b 3b 20 0a 09 09 20 20 20 20 20 28 70 72 ) ;; ... (pr
8570: 6f 63 65 73 73 2d 73 69 67 6e 61 6c 20 28 63 75 ocess-signal (cu
8580: 72 72 65 6e 74 2d 70 72 6f 63 65 73 73 2d 69 64 rrent-process-id
8590: 29 20 73 69 67 6e 61 6c 2f 6b 69 6c 6c 29 29 29 ) signal/kill)))
85a0: 29 29 29 0a 09 28 28 4b 49 4c 4c 45 44 29 20 0a )))..((KILLED) .
85b0: 09 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 31 . (debug:print 1
85c0: 20 22 4e 4f 54 45 3a 20 22 20 6e 65 77 2d 74 65 "NOTE: " new-te
85d0: 73 74 2d 6e 61 6d 65 20 22 20 69 73 20 61 6c 72 st-name " is alr
85e0: 65 61 64 79 20 72 75 6e 6e 69 6e 67 20 6f 72 20 eady running or
85f0: 77 61 73 20 65 78 70 6c 69 63 74 6c 79 20 6b 69 was explictly ki
8600: 6c 6c 65 64 2c 20 75 73 65 20 2d 66 6f 72 63 65 lled, use -force
8610: 20 74 6f 20 6c 61 75 6e 63 68 20 69 74 2e 22 29 to launch it.")
8620: 29 0a 09 28 28 4c 41 55 4e 43 48 45 44 20 52 45 )..((LAUNCHED RE
8630: 4d 4f 54 45 48 4f 53 54 53 54 41 52 54 20 52 55 MOTEHOSTSTART RU
8640: 4e 4e 49 4e 47 29 20 20 0a 09 20 28 69 66 20 28 NNING) .. (if (
8650: 3e 20 28 2d 20 28 63 75 72 72 65 6e 74 2d 73 65 > (- (current-se
8660: 63 6f 6e 64 73 29 28 2b 20 28 64 62 3a 74 65 73 conds)(+ (db:tes
8670: 74 2d 67 65 74 2d 65 76 65 6e 74 5f 74 69 6d 65 t-get-event_time
8680: 20 74 65 73 74 64 61 74 29 0a 09 09 09 09 20 20 testdat).....
8690: 20 20 20 20 20 28 64 62 3a 74 65 73 74 2d 67 65 (db:test-ge
86a0: 74 2d 72 75 6e 5f 64 75 72 61 74 69 6f 6e 20 74 t-run_duration t
86b0: 65 73 74 64 61 74 29 29 29 0a 09 09 36 30 30 29 estdat)))...600)
86c0: 20 3b 3b 20 69 2e 65 2e 20 6e 6f 20 75 70 64 61 ;; i.e. no upda
86d0: 74 65 20 66 6f 72 20 6d 6f 72 65 20 74 68 61 6e te for more than
86e0: 20 36 30 30 20 73 65 63 6f 6e 64 73 0a 09 20 20 600 seconds..
86f0: 20 20 20 28 62 65 67 69 6e 0a 09 20 20 20 20 20 (begin..
8700: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 (debug:print 0
8710: 20 22 57 41 52 4e 49 4e 47 3a 20 54 65 73 74 20 "WARNING: Test
8720: 22 20 74 65 73 74 2d 6e 61 6d 65 20 22 20 61 70 " test-name " ap
8730: 70 65 61 72 73 20 74 6f 20 62 65 20 64 65 61 64 pears to be dead
8740: 2e 20 46 6f 72 63 69 6e 67 20 69 74 20 74 6f 20 . Forcing it to
8750: 73 74 61 74 65 20 49 4e 43 4f 4d 50 4c 45 54 45 state INCOMPLETE
8760: 20 61 6e 64 20 73 74 61 74 75 73 20 53 54 55 43 and status STUC
8770: 4b 2f 44 45 41 44 22 29 0a 09 20 20 20 20 20 20 K/DEAD")..
8780: 20 28 74 65 73 74 73 3a 74 65 73 74 2d 73 65 74 (tests:test-set
8790: 2d 73 74 61 74 75 73 21 20 74 65 73 74 2d 69 64 -status! test-id
87a0: 20 22 49 4e 43 4f 4d 50 4c 45 54 45 22 20 22 53 "INCOMPLETE" "S
87b0: 54 55 43 4b 2f 44 45 41 44 22 20 22 54 65 73 74 TUCK/DEAD" "Test
87c0: 20 69 73 20 73 74 75 63 6b 20 6f 72 20 64 65 61 is stuck or dea
87d0: 64 22 20 23 66 29 29 0a 09 20 20 20 20 20 28 64 d" #f)).. (d
87e0: 65 62 75 67 3a 70 72 69 6e 74 20 32 20 22 4e 4f ebug:print 2 "NO
87f0: 54 45 3a 20 22 20 74 65 73 74 2d 6e 61 6d 65 20 TE: " test-name
8800: 22 20 69 73 20 61 6c 72 65 61 64 79 20 72 75 6e " is already run
8810: 6e 69 6e 67 22 29 29 29 0a 09 28 65 6c 73 65 20 ning")))..(else
8820: 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 (debug:pri
8830: 6e 74 20 30 20 22 45 52 52 4f 52 3a 20 46 61 69 nt 0 "ERROR: Fai
8840: 6c 65 64 20 74 6f 20 6c 61 75 6e 63 68 20 74 65 led to launch te
8850: 73 74 20 22 20 6e 65 77 2d 74 65 73 74 2d 6e 61 st " new-test-na
8860: 6d 65 20 22 2e 20 55 6e 72 65 63 6f 67 6e 69 73 me ". Unrecognis
8870: 65 64 20 73 74 61 74 65 20 22 20 28 74 65 73 74 ed state " (test
8880: 3a 67 65 74 2d 73 74 61 74 65 20 74 65 73 74 64 :get-state testd
8890: 61 74 29 29 29 29 29 29 29 0a 0a 3b 3b 3d 3d 3d at)))))))..;;===
88a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
88b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
88c0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
88d0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
88e0: 3d 3d 3d 0a 3b 3b 20 45 4e 44 20 4f 46 20 4e 45 ===.;; END OF NE
88f0: 57 20 53 54 55 46 46 0a 3b 3b 3d 3d 3d 3d 3d 3d W STUFF.;;======
8900: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8910: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8920: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8930: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8940: 0a 0a 28 64 65 66 69 6e 65 20 28 67 65 74 2d 64 ..(define (get-d
8950: 69 72 2d 75 70 2d 6e 20 64 69 72 20 2e 20 70 61 ir-up-n dir . pa
8960: 72 61 6d 73 29 20 0a 20 20 28 6c 65 74 20 28 28 rams) . (let ((
8970: 64 70 61 72 74 73 20 20 28 73 74 72 69 6e 67 2d dparts (string-
8980: 73 70 6c 69 74 20 64 69 72 20 22 2f 22 29 29 0a split dir "/")).
8990: 09 28 63 6f 75 6e 74 20 20 20 28 69 66 20 28 6e .(count (if (n
89a0: 75 6c 6c 3f 20 70 61 72 61 6d 73 29 20 31 20 28 ull? params) 1 (
89b0: 63 61 72 20 70 61 72 61 6d 73 29 29 29 29 0a 20 car params)))).
89c0: 20 20 20 28 63 6f 6e 63 20 22 2f 22 20 28 73 74 (conc "/" (st
89d0: 72 69 6e 67 2d 69 6e 74 65 72 73 70 65 72 73 65 ring-intersperse
89e0: 20 0a 09 20 20 20 20 20 20 20 28 74 61 6b 65 20 .. (take
89f0: 64 70 61 72 74 73 20 28 2d 20 28 6c 65 6e 67 74 dparts (- (lengt
8a00: 68 20 64 70 61 72 74 73 29 20 63 6f 75 6e 74 29 h dparts) count)
8a10: 29 0a 09 20 20 20 20 20 20 20 22 2f 22 29 29 29 ).. "/")))
8a20: 29 0a 3b 3b 20 52 65 6d 6f 76 65 20 72 75 6e 73 ).;; Remove runs
8a30: 0a 3b 3b 20 66 69 65 6c 64 73 20 61 72 65 20 70 .;; fields are p
8a40: 61 73 73 69 6e 67 20 69 6e 20 74 68 72 6f 75 67 assing in throug
8a50: 68 20 0a 3b 3b 20 61 63 74 69 6f 6e 3a 0a 3b 3b h .;; action:.;;
8a60: 20 20 20 20 27 72 65 6d 6f 76 65 2d 72 75 6e 73 'remove-runs
8a70: 0a 3b 3b 20 20 20 20 27 73 65 74 2d 73 74 61 74 .;; 'set-stat
8a80: 65 2d 73 74 61 74 75 73 0a 3b 3b 0a 3b 3b 20 4e e-status.;;.;; N
8a90: 42 2f 2f 20 73 68 6f 75 6c 64 20 70 61 73 73 20 B// should pass
8aa0: 69 6e 20 6b 65 79 73 3f 0a 3b 3b 0a 28 64 65 66 in keys?.;;.(def
8ab0: 69 6e 65 20 28 72 75 6e 73 3a 6f 70 65 72 61 74 ine (runs:operat
8ac0: 65 2d 6f 6e 20 61 63 74 69 6f 6e 20 72 75 6e 6e e-on action runn
8ad0: 61 6d 65 70 61 74 74 20 74 65 73 74 70 61 74 74 amepatt testpatt
8ae0: 20 23 21 6b 65 79 20 28 73 74 61 74 65 20 23 66 #!key (state #f
8af0: 29 28 73 74 61 74 75 73 20 23 66 29 28 6e 65 77 )(status #f)(new
8b00: 2d 73 74 61 74 65 2d 73 74 61 74 75 73 20 23 66 -state-status #f
8b10: 29 29 0a 20 20 28 6c 65 74 2a 20 28 28 64 62 20 )). (let* ((db
8b20: 20 20 20 20 20 20 20 20 20 20 23 66 29 0a 09 20 #f)..
8b30: 28 6b 65 79 73 20 20 20 20 20 20 20 20 20 28 6f (keys (o
8b40: 70 65 6e 2d 72 75 6e 2d 63 6c 6f 73 65 20 64 62 pen-run-close db
8b50: 3a 67 65 74 2d 6b 65 79 73 20 64 62 29 29 0a 09 :get-keys db))..
8b60: 20 28 72 75 6e 64 61 74 20 20 20 20 20 20 20 28 (rundat (
8b70: 6f 70 65 6e 2d 72 75 6e 2d 63 6c 6f 73 65 20 72 open-run-close r
8b80: 75 6e 73 3a 67 65 74 2d 72 75 6e 73 2d 62 79 2d uns:get-runs-by-
8b90: 70 61 74 74 20 64 62 20 6b 65 79 73 20 72 75 6e patt db keys run
8ba0: 6e 61 6d 65 70 61 74 74 29 29 0a 09 20 28 68 65 namepatt)).. (he
8bb0: 61 64 65 72 20 20 20 20 20 20 20 28 76 65 63 74 ader (vect
8bc0: 6f 72 2d 72 65 66 20 72 75 6e 64 61 74 20 30 29 or-ref rundat 0)
8bd0: 29 0a 09 20 28 72 75 6e 73 20 20 20 20 20 20 20 ).. (runs
8be0: 20 20 28 76 65 63 74 6f 72 2d 72 65 66 20 72 75 (vector-ref ru
8bf0: 6e 64 61 74 20 31 29 29 0a 09 20 28 73 74 61 74 ndat 1)).. (stat
8c00: 65 73 20 20 20 20 20 20 20 28 69 66 20 73 74 61 es (if sta
8c10: 74 65 20 20 28 73 74 72 69 6e 67 2d 73 70 6c 69 te (string-spli
8c20: 74 20 73 74 61 74 65 20 20 22 2c 22 29 20 27 28 t state ",") '(
8c30: 29 29 29 0a 09 20 28 73 74 61 74 75 73 65 73 20 ))).. (statuses
8c40: 20 20 20 20 28 69 66 20 73 74 61 74 75 73 20 28 (if status (
8c50: 73 74 72 69 6e 67 2d 73 70 6c 69 74 20 73 74 61 string-split sta
8c60: 74 75 73 20 22 2c 22 29 20 27 28 29 29 29 0a 09 tus ",") '()))..
8c70: 20 28 73 74 61 74 65 2d 73 74 61 74 75 73 20 28 (state-status (
8c80: 69 66 20 28 73 74 72 69 6e 67 3f 20 6e 65 77 2d if (string? new-
8c90: 73 74 61 74 65 2d 73 74 61 74 75 73 29 20 28 73 state-status) (s
8ca0: 74 72 69 6e 67 2d 73 70 6c 69 74 20 6e 65 77 2d tring-split new-
8cb0: 73 74 61 74 65 2d 73 74 61 74 75 73 20 22 2c 22 state-status ","
8cc0: 29 20 27 28 23 66 20 23 66 29 29 29 29 0a 20 20 ) '(#f #f)))).
8cd0: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 (debug:print-i
8ce0: 6e 66 6f 20 34 20 22 72 75 6e 73 3a 6f 70 65 72 nfo 4 "runs:oper
8cf0: 61 74 65 2d 6f 6e 20 3d 3e 20 48 65 61 64 65 72 ate-on => Header
8d00: 3a 20 22 20 68 65 61 64 65 72 20 22 20 61 63 74 : " header " act
8d10: 69 6f 6e 3a 20 22 20 61 63 74 69 6f 6e 20 22 20 ion: " action "
8d20: 6e 65 77 2d 73 74 61 74 65 2d 73 74 61 74 75 73 new-state-status
8d30: 3a 20 22 20 6e 65 77 2d 73 74 61 74 65 2d 73 74 : " new-state-st
8d40: 61 74 75 73 29 0a 20 20 20 20 28 69 66 20 28 3e atus). (if (>
8d50: 20 32 20 28 6c 65 6e 67 74 68 20 73 74 61 74 65 2 (length state
8d60: 2d 73 74 61 74 75 73 29 29 0a 09 28 62 65 67 69 -status))..(begi
8d70: 6e 0a 09 20 20 28 64 65 62 75 67 3a 70 72 69 6e n.. (debug:prin
8d80: 74 20 30 20 22 45 52 52 4f 52 3a 20 74 68 65 20 t 0 "ERROR: the
8d90: 70 61 72 61 6d 65 74 65 72 20 74 6f 20 2d 73 65 parameter to -se
8da0: 74 2d 73 74 61 74 65 2d 73 74 61 74 75 73 20 69 t-state-status i
8db0: 73 20 61 20 63 6f 6d 6d 61 20 64 65 6c 69 6d 69 s a comma delimi
8dc0: 74 65 64 20 73 74 72 69 6e 67 2e 20 45 2e 67 2e ted string. E.g.
8dd0: 20 43 4f 4d 50 4c 45 54 45 44 2c 46 41 49 4c 22 COMPLETED,FAIL"
8de0: 29 0a 09 20 20 28 65 78 69 74 29 29 29 0a 20 20 ).. (exit))).
8df0: 20 20 28 66 6f 72 2d 65 61 63 68 0a 20 20 20 20 (for-each.
8e00: 20 28 6c 61 6d 62 64 61 20 28 72 75 6e 29 0a 20 (lambda (run).
8e10: 20 20 20 20 20 20 28 6c 65 74 20 28 28 72 75 6e (let ((run
8e20: 6b 65 79 20 28 73 74 72 69 6e 67 2d 69 6e 74 65 key (string-inte
8e30: 72 73 70 65 72 73 65 20 28 6d 61 70 20 28 6c 61 rsperse (map (la
8e40: 6d 62 64 61 20 28 6b 29 0a 09 09 09 09 09 09 28 mbda (k).......(
8e50: 64 62 3a 67 65 74 2d 76 61 6c 75 65 2d 62 79 2d db:get-value-by-
8e60: 68 65 61 64 65 72 20 72 75 6e 20 68 65 61 64 65 header run heade
8e70: 72 20 28 76 65 63 74 6f 72 2d 72 65 66 20 6b 20 r (vector-ref k
8e80: 30 29 29 29 20 6b 65 79 73 29 20 22 2f 22 29 29 0))) keys) "/"))
8e90: 0a 09 20 20 20 20 20 28 64 69 72 73 2d 74 6f 2d .. (dirs-to-
8ea0: 72 65 6d 6f 76 65 20 28 6d 61 6b 65 2d 68 61 73 remove (make-has
8eb0: 68 2d 74 61 62 6c 65 29 29 29 0a 09 20 28 6c 65 h-table))).. (le
8ec0: 74 2a 20 28 28 72 75 6e 2d 69 64 20 20 20 20 28 t* ((run-id (
8ed0: 64 62 3a 67 65 74 2d 76 61 6c 75 65 2d 62 79 2d db:get-value-by-
8ee0: 68 65 61 64 65 72 20 72 75 6e 20 68 65 61 64 65 header run heade
8ef0: 72 20 22 69 64 22 29 29 0a 09 09 28 72 75 6e 2d r "id"))...(run-
8f00: 73 74 61 74 65 20 28 64 62 3a 67 65 74 2d 76 61 state (db:get-va
8f10: 6c 75 65 2d 62 79 2d 68 65 61 64 65 72 20 72 75 lue-by-header ru
8f20: 6e 20 68 65 61 64 65 72 20 22 73 74 61 74 65 22 n header "state"
8f30: 29 29 0a 09 09 28 74 65 73 74 73 20 20 20 20 20 ))...(tests
8f40: 28 69 66 20 28 6e 6f 74 20 28 65 71 75 61 6c 3f (if (not (equal?
8f50: 20 72 75 6e 2d 73 74 61 74 65 20 22 6c 6f 63 6b run-state "lock
8f60: 65 64 22 29 29 0a 09 09 09 20 20 20 20 20 20 20 ed"))....
8f70: 28 6f 70 65 6e 2d 72 75 6e 2d 63 6c 6f 73 65 20 (open-run-close
8f80: 64 62 3a 67 65 74 2d 74 65 73 74 73 2d 66 6f 72 db:get-tests-for
8f90: 2d 72 75 6e 20 64 62 20 72 75 6e 2d 69 64 0a 09 -run db run-id..
8fa0: 09 09 09 09 09 20 20 20 20 20 20 74 65 73 74 70 ..... testp
8fb0: 61 74 74 20 73 74 61 74 65 73 20 73 74 61 74 75 att states statu
8fc0: 73 65 73 0a 09 09 09 09 09 09 20 20 20 20 20 20 ses.......
8fd0: 6e 6f 74 2d 69 6e 3a 20 20 23 66 0a 09 09 09 09 not-in: #f.....
8fe0: 09 09 20 20 20 20 20 20 73 6f 72 74 2d 62 79 3a .. sort-by:
8ff0: 20 28 63 61 73 65 20 61 63 74 69 6f 6e 0a 09 09 (case action...
9000: 09 09 09 09 09 09 20 28 28 72 65 6d 6f 76 65 2d ...... ((remove-
9010: 72 75 6e 73 29 20 27 72 75 6e 64 69 72 29 0a 09 runs) 'rundir)..
9020: 09 09 09 09 09 09 09 20 28 65 6c 73 65 20 20 20 ....... (else
9030: 20 20 20 20 20 20 20 27 65 76 65 6e 74 5f 74 69 'event_ti
9040: 6d 65 29 29 29 0a 09 09 09 20 20 20 20 20 20 20 me)))....
9050: 27 28 29 29 29 0a 09 09 28 6c 61 73 74 74 70 61 '()))...(lasttpa
9060: 74 68 20 22 2f 64 6f 65 73 2f 6e 6f 74 2f 65 78 th "/does/not/ex
9070: 69 73 74 2f 49 2f 68 6f 70 65 22 29 29 0a 09 20 ist/I/hope"))..
9080: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 (debug:print-i
9090: 6e 66 6f 20 34 20 22 72 75 6e 73 3a 6f 70 65 72 nfo 4 "runs:oper
90a0: 61 74 65 2d 6f 6e 20 72 75 6e 3d 22 20 72 75 6e ate-on run=" run
90b0: 20 22 2c 20 68 65 61 64 65 72 3d 22 20 68 65 61 ", header=" hea
90c0: 64 65 72 29 0a 09 20 20 20 28 69 66 20 28 6e 6f der).. (if (no
90d0: 74 20 28 6e 75 6c 6c 3f 20 74 65 73 74 73 29 29 t (null? tests))
90e0: 0a 09 20 20 20 20 20 20 20 28 62 65 67 69 6e 0a .. (begin.
90f0: 09 09 20 28 63 61 73 65 20 61 63 74 69 6f 6e 0a .. (case action.
9100: 09 09 20 20 20 28 28 72 65 6d 6f 76 65 2d 72 75 .. ((remove-ru
9110: 6e 73 29 0a 09 09 20 20 20 20 28 64 65 62 75 67 ns)... (debug
9120: 3a 70 72 69 6e 74 20 31 20 22 52 65 6d 6f 76 69 :print 1 "Removi
9130: 6e 67 20 74 65 73 74 73 20 66 6f 72 20 72 75 6e ng tests for run
9140: 3a 20 22 20 72 75 6e 6b 65 79 20 22 20 22 20 28 : " runkey " " (
9150: 64 62 3a 67 65 74 2d 76 61 6c 75 65 2d 62 79 2d db:get-value-by-
9160: 68 65 61 64 65 72 20 72 75 6e 20 68 65 61 64 65 header run heade
9170: 72 20 22 72 75 6e 6e 61 6d 65 22 29 29 29 0a 09 r "runname")))..
9180: 09 20 20 20 28 28 73 65 74 2d 73 74 61 74 65 2d . ((set-state-
9190: 73 74 61 74 75 73 29 0a 09 09 20 20 20 20 28 64 status)... (d
91a0: 65 62 75 67 3a 70 72 69 6e 74 20 31 20 22 4d 6f ebug:print 1 "Mo
91b0: 64 69 66 79 69 6e 67 20 73 74 61 74 65 20 61 6e difying state an
91c0: 64 20 73 74 61 75 73 20 66 6f 72 20 74 65 73 74 d staus for test
91d0: 73 20 66 6f 72 20 72 75 6e 3a 20 22 20 72 75 6e s for run: " run
91e0: 6b 65 79 20 22 20 22 20 28 64 62 3a 67 65 74 2d key " " (db:get-
91f0: 76 61 6c 75 65 2d 62 79 2d 68 65 61 64 65 72 20 value-by-header
9200: 72 75 6e 20 68 65 61 64 65 72 20 22 72 75 6e 6e run header "runn
9210: 61 6d 65 22 29 29 29 0a 09 09 20 20 20 28 28 70 ame")))... ((p
9220: 72 69 6e 74 2d 72 75 6e 29 0a 09 09 20 20 20 20 rint-run)...
9230: 28 64 65 62 75 67 3a 70 72 69 6e 74 20 31 20 22 (debug:print 1 "
9240: 50 72 69 6e 74 69 6e 67 20 69 6e 66 6f 20 66 6f Printing info fo
9250: 72 20 72 75 6e 20 22 20 72 75 6e 6b 65 79 20 22 r run " runkey "
9260: 2c 20 72 75 6e 3d 22 20 72 75 6e 20 22 2c 20 74 , run=" run ", t
9270: 65 73 74 73 3d 22 20 74 65 73 74 73 20 22 2c 20 ests=" tests ",
9280: 68 65 61 64 65 72 3d 22 20 68 65 61 64 65 72 29 header=" header)
9290: 0a 09 09 20 20 20 20 61 63 74 69 6f 6e 29 0a 09 ... action)..
92a0: 09 20 20 20 28 65 6c 73 65 0a 09 09 20 20 20 20 . (else...
92b0: 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 (debug:print-inf
92c0: 6f 20 30 20 22 61 63 74 69 6f 6e 20 6e 6f 74 20 o 0 "action not
92d0: 72 65 63 6f 67 6e 69 73 65 64 20 22 20 61 63 74 recognised " act
92e0: 69 6f 6e 29 29 29 0a 09 09 20 28 66 6f 72 2d 65 ion)))... (for-e
92f0: 61 63 68 0a 09 09 20 20 28 6c 61 6d 62 64 61 20 ach... (lambda
9300: 28 74 65 73 74 29 0a 09 09 20 20 20 20 28 6c 65 (test)... (le
9310: 74 2a 20 28 28 69 74 65 6d 2d 70 61 74 68 20 28 t* ((item-path (
9320: 64 62 3a 74 65 73 74 2d 67 65 74 2d 69 74 65 6d db:test-get-item
9330: 2d 70 61 74 68 20 74 65 73 74 29 29 0a 09 09 09 -path test))....
9340: 20 20 20 28 74 65 73 74 2d 6e 61 6d 65 20 28 64 (test-name (d
9350: 62 3a 74 65 73 74 2d 67 65 74 2d 74 65 73 74 6e b:test-get-testn
9360: 61 6d 65 20 74 65 73 74 29 29 0a 09 09 09 20 20 ame test))....
9370: 20 28 72 75 6e 2d 64 69 72 20 20 20 28 64 62 3a (run-dir (db:
9380: 74 65 73 74 2d 67 65 74 2d 72 75 6e 64 69 72 20 test-get-rundir
9390: 74 65 73 74 29 29 20 20 20 20 3b 3b 20 72 75 6e test)) ;; run
93a0: 20 64 69 72 20 69 73 20 66 72 6f 6d 20 74 68 65 dir is from the
93b0: 20 6c 69 6e 6b 20 74 72 65 65 0a 09 09 09 20 20 link tree....
93c0: 20 28 72 65 61 6c 2d 64 69 72 20 20 28 69 66 20 (real-dir (if
93d0: 28 66 69 6c 65 2d 65 78 69 73 74 73 3f 20 72 75 (file-exists? ru
93e0: 6e 2d 64 69 72 29 0a 09 09 09 09 09 20 20 28 72 n-dir)...... (r
93f0: 65 73 6f 6c 76 65 2d 70 61 74 68 6e 61 6d 65 20 esolve-pathname
9400: 72 75 6e 2d 64 69 72 29 0a 09 09 09 09 09 20 20 run-dir)......
9410: 23 66 29 29 0a 09 09 09 20 20 20 28 74 65 73 74 #f)).... (test
9420: 2d 69 64 20 20 20 28 64 62 3a 74 65 73 74 2d 67 -id (db:test-g
9430: 65 74 2d 69 64 20 74 65 73 74 29 29 29 0a 09 09 et-id test)))...
9440: 20 20 20 20 20 20 3b 3b 20 20 20 28 74 64 62 20 ;; (tdb
9450: 20 20 20 20 20 20 28 64 62 3a 6f 70 65 6e 2d 74 (db:open-t
9460: 65 73 74 2d 64 62 20 72 75 6e 2d 64 69 72 29 29 est-db run-dir))
9470: 29 0a 09 09 20 20 20 20 20 20 28 64 65 62 75 67 )... (debug
9480: 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 34 20 22 74 :print-info 4 "t
9490: 65 73 74 3d 22 20 74 65 73 74 29 20 3b 3b 20 20 est=" test) ;;
94a0: 20 22 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d " (db:test-get-
94b0: 74 65 73 74 6e 61 6d 65 20 74 65 73 74 29 20 22 testname test) "
94c0: 20 69 64 3a 20 22 20 28 64 62 3a 74 65 73 74 2d id: " (db:test-
94d0: 67 65 74 2d 69 64 20 74 65 73 74 29 20 22 20 22 get-id test) " "
94e0: 20 69 74 65 6d 2d 70 61 74 68 20 22 20 61 63 74 item-path " act
94f0: 69 6f 6e 3a 20 22 20 61 63 74 69 6f 6e 29 0a 09 ion: " action)..
9500: 09 20 20 20 20 20 20 28 63 61 73 65 20 61 63 74 . (case act
9510: 69 6f 6e 0a 09 09 09 28 28 72 65 6d 6f 76 65 2d ion....((remove-
9520: 72 75 6e 73 29 20 3b 3b 20 74 68 65 20 74 64 62 runs) ;; the tdb
9530: 20 69 73 20 66 6f 72 20 66 75 74 75 72 65 20 70 is for future p
9540: 6f 73 73 69 62 6c 65 2e 20 0a 09 09 09 20 28 6f ossible. .... (o
9550: 70 65 6e 2d 72 75 6e 2d 63 6c 6f 73 65 20 64 62 pen-run-close db
9560: 3a 64 65 6c 65 74 65 2d 74 65 73 74 2d 72 65 63 :delete-test-rec
9570: 6f 72 64 73 20 64 62 20 23 66 20 28 64 62 3a 74 ords db #f (db:t
9580: 65 73 74 2d 67 65 74 2d 69 64 20 74 65 73 74 29 est-get-id test)
9590: 29 0a 09 09 09 20 28 64 65 62 75 67 3a 70 72 69 ).... (debug:pri
95a0: 6e 74 2d 69 6e 66 6f 20 31 20 22 41 74 74 65 6d nt-info 1 "Attem
95b0: 70 74 69 6e 67 20 74 6f 20 72 65 6d 6f 76 65 20 pting to remove
95c0: 22 20 28 69 66 20 72 65 61 6c 2d 64 69 72 20 28 " (if real-dir (
95d0: 63 6f 6e 63 20 22 20 64 69 72 20 22 20 72 65 61 conc " dir " rea
95e0: 6c 2d 64 69 72 20 22 20 61 6e 64 20 22 29 20 22 l-dir " and ") "
95f0: 22 29 20 22 20 6c 69 6e 6b 20 22 20 72 75 6e 2d ") " link " run-
9600: 64 69 72 29 0a 09 09 09 20 28 69 66 20 28 61 6e dir).... (if (an
9610: 64 20 72 65 61 6c 2d 64 69 72 20 0a 09 09 09 09 d real-dir .....
9620: 20 20 28 3e 20 28 73 74 72 69 6e 67 2d 6c 65 6e (> (string-len
9630: 67 74 68 20 72 65 61 6c 2d 64 69 72 29 20 35 29 gth real-dir) 5)
9640: 0a 09 09 09 09 20 20 28 66 69 6c 65 2d 65 78 69 ..... (file-exi
9650: 73 74 73 3f 20 72 65 61 6c 2d 64 69 72 29 29 20 sts? real-dir))
9660: 3b 3b 20 62 61 64 20 68 65 75 72 69 73 74 69 63 ;; bad heuristic
9670: 20 62 75 74 20 73 68 6f 75 6c 64 20 70 72 65 76 but should prev
9680: 65 6e 74 20 2f 74 6d 70 20 2f 68 6f 6d 65 20 65 ent /tmp /home e
9690: 74 63 2e 0a 09 09 09 20 20 20 20 20 28 62 65 67 tc..... (beg
96a0: 69 6e 20 3b 3b 20 6c 65 74 2a 20 28 28 72 65 61 in ;; let* ((rea
96b0: 6c 70 61 74 68 20 28 72 65 73 6f 6c 76 65 2d 70 lpath (resolve-p
96c0: 61 74 68 6e 61 6d 65 20 72 75 6e 2d 64 69 72 29 athname run-dir)
96d0: 29 29 0a 09 09 09 20 20 20 20 20 20 20 28 64 65 )).... (de
96e0: 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 31 bug:print-info 1
96f0: 20 22 52 65 63 75 72 73 69 76 65 6c 79 20 72 65 "Recursively re
9700: 6d 6f 76 69 6e 67 20 22 20 72 65 61 6c 2d 64 69 moving " real-di
9710: 72 29 0a 09 09 09 20 20 20 20 20 20 20 28 69 66 r).... (if
9720: 20 28 66 69 6c 65 2d 65 78 69 73 74 73 3f 20 72 (file-exists? r
9730: 65 61 6c 2d 64 69 72 29 0a 09 09 09 09 20 20 20 eal-dir).....
9740: 28 69 66 20 28 3e 20 28 73 79 73 74 65 6d 20 28 (if (> (system (
9750: 63 6f 6e 63 20 22 72 6d 20 2d 72 66 20 22 20 72 conc "rm -rf " r
9760: 65 61 6c 2d 64 69 72 29 29 20 30 29 0a 09 09 09 eal-dir)) 0)....
9770: 09 20 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 . (debug:p
9780: 72 69 6e 74 20 30 20 22 45 52 52 4f 52 3a 20 54 rint 0 "ERROR: T
9790: 68 65 72 65 20 77 61 73 20 61 20 70 72 6f 62 6c here was a probl
97a0: 65 6d 20 72 65 6d 6f 76 69 6e 67 20 22 20 72 65 em removing " re
97b0: 61 6c 2d 64 69 72 20 22 20 77 69 74 68 20 72 6d al-dir " with rm
97c0: 20 2d 66 22 29 29 0a 09 09 09 09 20 20 20 28 64 -f"))..... (d
97d0: 65 62 75 67 3a 70 72 69 6e 74 20 30 20 22 57 41 ebug:print 0 "WA
97e0: 52 4e 49 4e 47 3a 20 74 65 73 74 20 64 69 72 20 RNING: test dir
97f0: 22 20 72 65 61 6c 2d 64 69 72 20 22 20 61 70 70 " real-dir " app
9800: 65 61 72 73 20 74 6f 20 6e 6f 74 20 65 78 69 73 ears to not exis
9810: 74 20 6f 72 20 69 73 20 6e 6f 74 20 72 65 61 64 t or is not read
9820: 61 62 6c 65 22 29 29 29 0a 09 09 09 20 20 20 20 able")))....
9830: 20 28 69 66 20 72 65 61 6c 2d 64 69 72 20 0a 09 (if real-dir ..
9840: 09 09 09 20 28 64 65 62 75 67 3a 70 72 69 6e 74 ... (debug:print
9850: 20 30 20 22 57 41 52 4e 49 4e 47 3a 20 64 69 72 0 "WARNING: dir
9860: 65 63 74 6f 72 79 20 22 20 72 65 61 6c 2d 64 69 ectory " real-di
9870: 72 20 22 20 64 6f 65 73 20 6e 6f 74 20 65 78 69 r " does not exi
9880: 73 74 22 29 0a 09 09 09 09 20 28 64 65 62 75 67 st")..... (debug
9890: 3a 70 72 69 6e 74 20 30 20 22 57 41 52 4e 49 4e :print 0 "WARNIN
98a0: 47 3a 20 6e 6f 20 72 65 61 6c 20 64 69 72 65 63 G: no real direc
98b0: 74 6f 72 79 20 63 6f 72 72 6f 73 70 6f 6e 64 69 tory corrospondi
98c0: 6e 67 20 74 6f 20 6c 69 6e 6b 20 22 20 72 75 6e ng to link " run
98d0: 2d 64 69 72 20 22 2c 20 6e 6f 74 68 69 6e 67 20 -dir ", nothing
98e0: 64 6f 6e 65 22 29 29 29 0a 09 09 09 20 28 69 66 done"))).... (if
98f0: 20 28 73 79 6d 62 6f 6c 69 63 2d 6c 69 6e 6b 3f (symbolic-link?
9900: 20 72 75 6e 2d 64 69 72 29 0a 09 09 09 20 20 20 run-dir)....
9910: 20 20 28 62 65 67 69 6e 0a 09 09 09 20 20 20 20 (begin....
9920: 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d (debug:print-
9930: 69 6e 66 6f 20 31 20 22 52 65 6d 6f 76 69 6e 67 info 1 "Removing
9940: 20 73 79 6d 6c 69 6e 6b 20 22 20 72 75 6e 2d 64 symlink " run-d
9950: 69 72 29 0a 09 09 09 20 20 20 20 20 20 20 28 64 ir).... (d
9960: 65 6c 65 74 65 2d 66 69 6c 65 20 72 75 6e 2d 64 elete-file run-d
9970: 69 72 29 29 0a 09 09 09 20 20 20 20 20 28 69 66 ir)).... (if
9980: 20 28 64 69 72 65 63 74 6f 72 79 3f 20 72 75 6e (directory? run
9990: 2d 64 69 72 29 0a 09 09 09 09 20 28 69 66 20 28 -dir)..... (if (
99a0: 3e 20 28 64 69 72 65 63 74 6f 72 79 2d 66 6f 6c > (directory-fol
99b0: 64 20 28 6c 61 6d 62 64 61 20 28 66 20 78 29 28 d (lambda (f x)(
99c0: 2b 20 31 20 78 29 29 20 30 20 72 75 6e 2d 64 69 + 1 x)) 0 run-di
99d0: 72 29 20 30 29 0a 09 09 09 09 20 20 20 20 20 28 r) 0)..... (
99e0: 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 22 57 debug:print 0 "W
99f0: 41 52 4e 49 4e 47 3a 20 72 65 66 75 73 69 6e 67 ARNING: refusing
9a00: 20 74 6f 20 72 65 6d 6f 76 65 20 22 20 72 75 6e to remove " run
9a10: 2d 64 69 72 20 22 20 61 73 20 69 74 20 69 73 20 -dir " as it is
9a20: 6e 6f 74 20 65 6d 70 74 79 22 29 0a 09 09 09 09 not empty").....
9a30: 20 20 20 20 20 28 64 65 6c 65 74 65 2d 64 69 72 (delete-dir
9a40: 65 63 74 6f 72 79 20 72 75 6e 2d 64 69 72 29 29 ectory run-dir))
9a50: 20 3b 3b 20 69 74 20 73 68 6f 75 6c 64 20 62 65 ;; it should be
9a60: 20 65 6d 70 74 79 20 62 79 20 68 65 72 65 20 42 empty by here B
9a70: 55 47 20 42 55 47 2c 20 61 64 64 20 65 72 72 6f UG BUG, add erro
9a80: 72 20 63 61 74 63 68 0a 09 09 09 09 20 28 69 66 r catch..... (if
9a90: 20 72 75 6e 2d 64 69 72 0a 09 09 09 09 20 20 20 run-dir.....
9aa0: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 (debug:print 0
9ab0: 20 22 57 41 52 4e 49 4e 47 3a 20 6e 6f 74 20 72 "WARNING: not r
9ac0: 65 6d 6f 76 69 6e 67 20 22 20 72 75 6e 2d 64 69 emoving " run-di
9ad0: 72 20 22 20 61 73 20 69 74 20 65 69 74 68 65 72 r " as it either
9ae0: 20 64 6f 65 73 6e 27 74 20 65 78 69 73 74 20 6f doesn't exist o
9af0: 72 20 69 73 20 6e 6f 74 20 61 20 73 79 6d 6c 69 r is not a symli
9b00: 6e 6b 22 29 0a 09 09 09 09 20 20 20 20 20 28 64 nk")..... (d
9b10: 65 62 75 67 3a 70 72 69 6e 74 20 30 20 22 4e 4f ebug:print 0 "NO
9b20: 54 45 3a 20 74 68 65 20 72 75 6e 20 64 69 72 20 TE: the run dir
9b30: 66 6f 72 20 74 68 69 73 20 74 65 73 74 20 69 73 for this test is
9b40: 20 75 6e 64 65 66 69 6e 65 64 2e 20 54 65 73 74 undefined. Test
9b50: 20 6d 61 79 20 68 61 76 65 20 61 6c 72 65 61 64 may have alread
9b60: 79 20 62 65 65 6e 20 64 65 6c 65 74 65 64 2e 22 y been deleted."
9b70: 29 29 0a 09 09 09 09 20 29 29 29 0a 09 09 09 28 ))..... )))....(
9b80: 28 73 65 74 2d 73 74 61 74 65 2d 73 74 61 74 75 (set-state-statu
9b90: 73 29 0a 09 09 09 20 28 64 65 62 75 67 3a 70 72 s).... (debug:pr
9ba0: 69 6e 74 2d 69 6e 66 6f 20 32 20 22 6e 65 77 20 int-info 2 "new
9bb0: 73 74 61 74 65 20 22 20 28 63 61 72 20 73 74 61 state " (car sta
9bc0: 74 65 2d 73 74 61 74 75 73 29 20 22 2c 20 6e 65 te-status) ", ne
9bd0: 77 20 73 74 61 74 75 73 20 22 20 28 63 61 64 72 w status " (cadr
9be0: 20 73 74 61 74 65 2d 73 74 61 74 75 73 29 29 0a state-status)).
9bf0: 09 09 09 20 28 6f 70 65 6e 2d 72 75 6e 2d 63 6c ... (open-run-cl
9c00: 6f 73 65 20 64 62 3a 74 65 73 74 2d 73 65 74 2d ose db:test-set-
9c10: 73 74 61 74 65 2d 73 74 61 74 75 73 2d 62 79 2d state-status-by-
9c20: 69 64 20 64 62 20 28 64 62 3a 74 65 73 74 2d 67 id db (db:test-g
9c30: 65 74 2d 69 64 20 74 65 73 74 29 20 28 63 61 72 et-id test) (car
9c40: 20 73 74 61 74 65 2d 73 74 61 74 75 73 29 28 63 state-status)(c
9c50: 61 64 72 20 73 74 61 74 65 2d 73 74 61 74 75 73 adr state-status
9c60: 29 20 23 66 29 29 29 29 29 0a 09 09 20 20 28 73 ) #f)))))... (s
9c70: 6f 72 74 20 74 65 73 74 73 20 28 6c 61 6d 62 64 ort tests (lambd
9c80: 61 20 28 61 20 62 29 28 6c 65 74 20 28 28 64 69 a (a b)(let ((di
9c90: 72 61 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d ra (db:test-get-
9ca0: 72 75 6e 64 69 72 20 61 29 29 0a 09 09 09 09 09 rundir a))......
9cb0: 09 20 28 64 69 72 62 20 28 64 62 3a 74 65 73 74 . (dirb (db:test
9cc0: 2d 67 65 74 2d 72 75 6e 64 69 72 20 62 29 29 29 -get-rundir b)))
9cd0: 0a 09 09 09 09 09 20 20 20 20 20 28 69 66 20 28 ...... (if (
9ce0: 61 6e 64 20 28 73 74 72 69 6e 67 3f 20 64 69 72 and (string? dir
9cf0: 61 29 28 73 74 72 69 6e 67 3f 20 64 69 72 62 29 a)(string? dirb)
9d00: 29 0a 09 09 09 09 09 09 20 28 3e 20 28 73 74 72 )....... (> (str
9d10: 69 6e 67 2d 6c 65 6e 67 74 68 20 64 69 72 61 29 ing-length dira)
9d20: 28 73 74 72 69 6e 67 2d 6c 65 6e 67 74 68 20 64 (string-length d
9d30: 69 72 62 29 29 0a 09 09 09 09 09 09 20 23 66 29 irb))....... #f)
9d40: 29 29 29 29 29 29 0a 09 20 20 20 3b 3b 20 72 65 )))))).. ;; re
9d50: 6d 6f 76 65 20 74 68 65 20 72 75 6e 20 69 66 20 move the run if
9d60: 7a 65 72 6f 20 74 65 73 74 73 20 72 65 6d 61 69 zero tests remai
9d70: 6e 0a 09 20 20 20 28 69 66 20 28 65 71 3f 20 61 n.. (if (eq? a
9d80: 63 74 69 6f 6e 20 27 72 65 6d 6f 76 65 2d 72 75 ction 'remove-ru
9d90: 6e 73 29 0a 09 20 20 20 20 20 20 20 28 6c 65 74 ns).. (let
9da0: 20 28 28 72 65 6d 74 65 73 74 73 20 28 6f 70 65 ((remtests (ope
9db0: 6e 2d 72 75 6e 2d 63 6c 6f 73 65 20 64 62 3a 67 n-run-close db:g
9dc0: 65 74 2d 74 65 73 74 73 2d 66 6f 72 2d 72 75 6e et-tests-for-run
9dd0: 20 64 62 20 28 64 62 3a 67 65 74 2d 76 61 6c 75 db (db:get-valu
9de0: 65 2d 62 79 2d 68 65 61 64 65 72 20 72 75 6e 20 e-by-header run
9df0: 68 65 61 64 65 72 20 22 69 64 22 29 20 23 66 20 header "id") #f
9e00: 27 28 22 44 45 4c 45 54 45 44 22 29 20 27 28 22 '("DELETED") '("
9e10: 6e 2f 61 22 29 20 6e 6f 74 2d 69 6e 3a 20 23 74 n/a") not-in: #t
9e20: 29 29 29 0a 09 09 20 28 69 66 20 28 6e 75 6c 6c )))... (if (null
9e30: 3f 20 72 65 6d 74 65 73 74 73 29 20 3b 3b 20 6e ? remtests) ;; n
9e40: 6f 20 6d 6f 72 65 20 74 65 73 74 73 20 72 65 6d o more tests rem
9e50: 61 69 6e 69 6e 67 0a 09 09 20 20 20 20 20 28 6c aining... (l
9e60: 65 74 2a 20 28 28 64 70 61 72 74 73 20 20 28 73 et* ((dparts (s
9e70: 74 72 69 6e 67 2d 73 70 6c 69 74 20 6c 61 73 74 tring-split last
9e80: 74 70 61 74 68 20 22 2f 22 29 29 0a 09 09 09 20 tpath "/"))....
9e90: 20 20 20 28 72 75 6e 70 61 74 68 20 28 63 6f 6e (runpath (con
9ea0: 63 20 22 2f 22 20 28 73 74 72 69 6e 67 2d 69 6e c "/" (string-in
9eb0: 74 65 72 73 70 65 72 73 65 20 0a 09 09 09 09 09 tersperse ......
9ec0: 09 28 74 61 6b 65 20 64 70 61 72 74 73 20 28 2d .(take dparts (-
9ed0: 20 28 6c 65 6e 67 74 68 20 64 70 61 72 74 73 29 (length dparts)
9ee0: 20 31 29 29 0a 09 09 09 09 09 09 22 2f 22 29 29 1))......."/"))
9ef0: 29 29 0a 09 09 20 20 20 20 20 20 20 28 64 65 62 ))... (deb
9f00: 75 67 3a 70 72 69 6e 74 20 31 20 22 52 65 6d 6f ug:print 1 "Remo
9f10: 76 69 6e 67 20 72 75 6e 3a 20 22 20 72 75 6e 6b ving run: " runk
9f20: 65 79 20 22 20 22 20 28 64 62 3a 67 65 74 2d 76 ey " " (db:get-v
9f30: 61 6c 75 65 2d 62 79 2d 68 65 61 64 65 72 20 72 alue-by-header r
9f40: 75 6e 20 68 65 61 64 65 72 20 22 72 75 6e 6e 61 un header "runna
9f50: 6d 65 22 29 20 22 20 61 6e 64 20 72 65 6c 61 74 me") " and relat
9f60: 65 64 20 72 65 63 6f 72 64 22 29 0a 09 09 20 20 ed record")...
9f70: 20 20 20 20 20 28 6f 70 65 6e 2d 72 75 6e 2d 63 (open-run-c
9f80: 6c 6f 73 65 20 64 62 3a 64 65 6c 65 74 65 2d 72 lose db:delete-r
9f90: 75 6e 20 64 62 20 72 75 6e 2d 69 64 29 0a 09 09 un db run-id)...
9fa0: 20 20 20 20 20 20 20 3b 3b 20 54 68 69 73 20 69 ;; This i
9fb0: 73 20 61 20 70 72 65 74 74 79 20 67 6f 6f 64 20 s a pretty good
9fc0: 70 6c 61 63 65 20 74 6f 20 70 75 72 67 65 20 6f place to purge o
9fd0: 6c 64 20 44 45 4c 45 54 45 44 20 74 65 73 74 73 ld DELETED tests
9fe0: 0a 09 09 20 20 20 20 20 20 20 28 6f 70 65 6e 2d ... (open-
9ff0: 72 75 6e 2d 63 6c 6f 73 65 20 64 62 3a 64 65 6c run-close db:del
a000: 65 74 65 2d 74 65 73 74 73 2d 66 6f 72 2d 72 75 ete-tests-for-ru
a010: 6e 20 64 62 20 72 75 6e 2d 69 64 29 0a 09 09 20 n db run-id)...
a020: 20 20 20 20 20 20 28 6f 70 65 6e 2d 72 75 6e 2d (open-run-
a030: 63 6c 6f 73 65 20 64 62 3a 64 65 6c 65 74 65 2d close db:delete-
a040: 6f 6c 64 2d 64 65 6c 65 74 65 64 2d 74 65 73 74 old-deleted-test
a050: 2d 72 65 63 6f 72 64 73 20 64 62 29 0a 09 09 20 -records db)...
a060: 20 20 20 20 20 20 28 6f 70 65 6e 2d 72 75 6e 2d (open-run-
a070: 63 6c 6f 73 65 20 64 62 3a 73 65 74 2d 76 61 72 close db:set-var
a080: 20 64 62 20 22 44 45 4c 45 54 45 44 5f 54 45 53 db "DELETED_TES
a090: 54 53 22 20 28 63 75 72 72 65 6e 74 2d 73 65 63 TS" (current-sec
a0a0: 6f 6e 64 73 29 29 0a 09 09 20 20 20 20 20 20 20 onds))...
a0b0: 3b 3b 20 6e 65 65 64 20 74 6f 20 66 69 67 75 72 ;; need to figur
a0c0: 65 20 6f 75 74 20 74 68 65 20 70 61 74 68 20 74 e out the path t
a0d0: 6f 20 74 68 65 20 72 75 6e 20 64 69 72 20 61 6e o the run dir an
a0e0: 64 20 72 65 6d 6f 76 65 20 69 74 20 69 66 20 65 d remove it if e
a0f0: 6d 70 74 79 0a 09 09 20 20 20 20 20 20 20 3b 3b mpty... ;;
a100: 20 20 20 20 28 69 66 20 28 6e 75 6c 6c 3f 20 28 (if (null? (
a110: 67 6c 6f 62 20 28 63 6f 6e 63 20 72 75 6e 70 61 glob (conc runpa
a120: 74 68 20 22 2f 2a 22 29 29 29 0a 09 09 20 20 20 th "/*")))...
a130: 20 20 20 20 3b 3b 20 20 20 20 20 20 20 20 28 62 ;; (b
a140: 65 67 69 6e 0a 09 09 20 20 20 20 20 20 20 3b 3b egin... ;;
a150: 20 09 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 . (debug:print
a160: 31 20 22 52 65 6d 6f 76 69 6e 67 20 72 75 6e 20 1 "Removing run
a170: 64 69 72 20 22 20 72 75 6e 70 61 74 68 29 0a 09 dir " runpath)..
a180: 09 20 20 20 20 20 20 20 3b 3b 20 09 20 28 73 79 . ;; . (sy
a190: 73 74 65 6d 20 28 63 6f 6e 63 20 22 72 6d 64 69 stem (conc "rmdi
a1a0: 72 20 2d 70 20 22 20 72 75 6e 70 61 74 68 29 29 r -p " runpath))
a1b0: 29 29 0a 09 09 20 20 20 20 20 20 20 29 29 29 29 ))... ))))
a1c0: 29 0a 09 20 29 29 0a 20 20 20 20 20 72 75 6e 73 ).. )). runs
a1d0: 29 29 0a 20 20 23 74 29 0a 0a 3b 3b 3d 3d 3d 3d )). #t)..;;====
a1e0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
a1f0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
a200: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
a210: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
a220: 3d 3d 0a 3b 3b 20 52 6f 75 74 69 6e 65 73 20 66 ==.;; Routines f
a230: 6f 72 20 6d 61 6e 69 70 75 6c 61 74 69 6e 67 20 or manipulating
a240: 72 75 6e 73 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d runs.;;=========
a250: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
a260: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
a270: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
a280: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 3b =============..;
a290: 3b 20 53 69 6e 63 65 20 6d 61 6e 79 20 63 61 6c ; Since many cal
a2a0: 6c 73 20 74 6f 20 61 20 72 75 6e 20 72 65 71 75 ls to a run requ
a2b0: 69 72 65 20 70 72 65 74 74 79 20 6d 75 63 68 20 ire pretty much
a2c0: 74 68 65 20 73 61 6d 65 20 73 65 74 75 70 20 0a the same setup .
a2d0: 3b 3b 20 74 68 69 73 20 77 72 61 70 70 65 72 20 ;; this wrapper
a2e0: 69 73 20 75 73 65 64 20 74 6f 20 72 65 64 75 63 is used to reduc
a2f0: 65 20 74 68 65 20 72 65 70 6c 69 63 61 74 69 6f e the replicatio
a300: 6e 20 6f 66 20 63 6f 64 65 0a 28 64 65 66 69 6e n of code.(defin
a310: 65 20 28 67 65 6e 65 72 61 6c 2d 72 75 6e 2d 63 e (general-run-c
a320: 61 6c 6c 20 73 77 69 74 63 68 6e 61 6d 65 20 61 all switchname a
a330: 63 74 69 6f 6e 2d 64 65 73 63 20 70 72 6f 63 29 ction-desc proc)
a340: 0a 20 20 28 6c 65 74 20 28 28 72 75 6e 6e 61 6d . (let ((runnam
a350: 65 20 28 61 72 67 73 3a 67 65 74 2d 61 72 67 20 e (args:get-arg
a360: 22 3a 72 75 6e 6e 61 6d 65 22 29 29 0a 09 28 74 ":runname"))..(t
a370: 61 72 67 65 74 20 20 28 69 66 20 28 61 72 67 73 arget (if (args
a380: 3a 67 65 74 2d 61 72 67 20 22 2d 74 61 72 67 65 :get-arg "-targe
a390: 74 22 29 0a 09 09 20 20 20 20 20 28 61 72 67 73 t")... (args
a3a0: 3a 67 65 74 2d 61 72 67 20 22 2d 74 61 72 67 65 :get-arg "-targe
a3b0: 74 22 29 0a 09 09 20 20 20 20 20 28 61 72 67 73 t")... (args
a3c0: 3a 67 65 74 2d 61 72 67 20 22 2d 72 65 71 74 61 :get-arg "-reqta
a3d0: 72 67 22 29 29 29 0a 09 28 74 68 31 20 20 20 20 rg")))..(th1
a3e0: 20 23 66 29 29 0a 20 20 20 20 28 63 6f 6e 64 0a #f)). (cond.
a3f0: 20 20 20 20 20 28 28 6e 6f 74 20 74 61 72 67 65 ((not targe
a400: 74 29 0a 20 20 20 20 20 20 28 64 65 62 75 67 3a t). (debug:
a410: 70 72 69 6e 74 20 30 20 22 45 52 52 4f 52 3a 20 print 0 "ERROR:
a420: 4d 69 73 73 69 6e 67 20 72 65 71 75 69 72 65 64 Missing required
a430: 20 70 61 72 61 6d 65 74 65 72 20 66 6f 72 20 22 parameter for "
a440: 20 73 77 69 74 63 68 6e 61 6d 65 20 22 2c 20 79 switchname ", y
a450: 6f 75 20 6d 75 73 74 20 73 70 65 63 69 66 79 20 ou must specify
a460: 74 68 65 20 74 61 72 67 65 74 20 77 69 74 68 20 the target with
a470: 2d 74 61 72 67 65 74 22 29 0a 20 20 20 20 20 20 -target").
a480: 28 65 78 69 74 20 33 29 29 0a 20 20 20 20 20 28 (exit 3)). (
a490: 28 6e 6f 74 20 72 75 6e 6e 61 6d 65 29 0a 20 20 (not runname).
a4a0: 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 (debug:print
a4b0: 20 30 20 22 45 52 52 4f 52 3a 20 4d 69 73 73 69 0 "ERROR: Missi
a4c0: 6e 67 20 72 65 71 75 69 72 65 64 20 70 61 72 61 ng required para
a4d0: 6d 65 74 65 72 20 66 6f 72 20 22 20 73 77 69 74 meter for " swit
a4e0: 63 68 6e 61 6d 65 20 22 2c 20 79 6f 75 20 6d 75 chname ", you mu
a4f0: 73 74 20 73 70 65 63 69 66 79 20 74 68 65 20 72 st specify the r
a500: 75 6e 20 6e 61 6d 65 20 77 69 74 68 20 3a 72 75 un name with :ru
a510: 6e 6e 61 6d 65 20 72 75 6e 6e 61 6d 65 22 29 0a nname runname").
a520: 20 20 20 20 20 20 28 65 78 69 74 20 33 29 29 0a (exit 3)).
a530: 20 20 20 20 20 28 65 6c 73 65 0a 20 20 20 20 20 (else.
a540: 20 28 6c 65 74 20 28 28 64 62 20 20 20 23 66 29 (let ((db #f)
a550: 0a 09 20 20 20 20 28 6b 65 79 73 20 23 66 29 29 .. (keys #f))
a560: 0a 09 28 69 66 20 28 6e 6f 74 20 28 73 65 74 75 ..(if (not (setu
a570: 70 2d 66 6f 72 2d 72 75 6e 29 29 0a 09 20 20 20 p-for-run))..
a580: 20 28 62 65 67 69 6e 20 0a 09 20 20 20 20 20 20 (begin ..
a590: 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 22 (debug:print 0 "
a5a0: 46 61 69 6c 65 64 20 74 6f 20 73 65 74 75 70 2c Failed to setup,
a5b0: 20 65 78 69 74 69 6e 67 22 29 0a 09 20 20 20 20 exiting")..
a5c0: 20 20 28 65 78 69 74 20 31 29 29 29 0a 09 28 69 (exit 1)))..(i
a5d0: 66 20 28 61 72 67 73 3a 67 65 74 2d 61 72 67 20 f (args:get-arg
a5e0: 22 2d 73 65 72 76 65 72 22 29 0a 09 20 20 20 20 "-server")..
a5f0: 28 6f 70 65 6e 2d 72 75 6e 2d 63 6c 6f 73 65 20 (open-run-close
a600: 73 65 72 76 65 72 3a 73 74 61 72 74 20 64 62 20 server:start db
a610: 28 61 72 67 73 3a 67 65 74 2d 61 72 67 20 22 2d (args:get-arg "-
a620: 73 65 72 76 65 72 22 29 29 0a 20 09 20 20 20 20 server")). .
a630: 28 69 66 20 28 6e 6f 74 20 28 6f 72 20 28 61 72 (if (not (or (ar
a640: 67 73 3a 67 65 74 2d 61 72 67 20 22 2d 72 75 6e gs:get-arg "-run
a650: 61 6c 6c 22 29 20 20 20 20 20 3b 3b 20 72 75 6e all") ;; run
a660: 61 6c 6c 20 61 6e 64 20 72 75 6e 74 65 73 74 73 all and runtests
a670: 20 61 72 65 20 61 6c 6c 6f 77 65 64 20 74 6f 20 are allowed to
a680: 62 65 20 73 65 72 76 65 72 73 0a 20 09 09 09 20 be servers. ...
a690: 28 61 72 67 73 3a 67 65 74 2d 61 72 67 20 22 2d (args:get-arg "-
a6a0: 72 75 6e 74 65 73 74 73 22 29 29 29 0a 09 09 28 runtests")))...(
a6b0: 73 65 72 76 65 72 3a 63 6c 69 65 6e 74 2d 73 65 server:client-se
a6c0: 74 75 70 29 20 3b 3b 20 54 68 69 73 20 69 73 20 tup) ;; This is
a6d0: 61 20 64 75 70 6c 69 63 61 74 65 20 73 74 61 72 a duplicate star
a6e0: 74 75 70 21 21 21 3f 3f 3f 20 42 55 47 3f 0a 09 tup!!!??? BUG?..
a6f0: 09 29 29 0a 09 28 73 65 74 21 20 6b 65 79 73 20 .))..(set! keys
a700: 28 6f 70 65 6e 2d 72 75 6e 2d 63 6c 6f 73 65 20 (open-run-close
a710: 64 62 3a 67 65 74 2d 6b 65 79 73 20 64 62 29 29 db:get-keys db))
a720: 0a 09 3b 3b 20 68 61 76 65 20 65 6e 6f 75 67 68 ..;; have enough
a730: 20 74 6f 20 70 72 6f 63 65 73 73 20 2d 74 61 72 to process -tar
a740: 67 65 74 20 6f 72 20 2d 72 65 71 74 61 72 67 20 get or -reqtarg
a750: 68 65 72 65 0a 09 28 69 66 20 28 61 72 67 73 3a here..(if (args:
a760: 67 65 74 2d 61 72 67 20 22 2d 72 65 71 74 61 72 get-arg "-reqtar
a770: 67 22 29 0a 09 20 20 20 20 28 6c 65 74 2a 20 28 g").. (let* (
a780: 28 72 75 6e 63 6f 6e 66 69 67 66 20 28 63 6f 6e (runconfigf (con
a790: 63 20 20 2a 74 6f 70 70 61 74 68 2a 20 22 2f 72 c *toppath* "/r
a7a0: 75 6e 63 6f 6e 66 69 67 73 2e 63 6f 6e 66 69 67 unconfigs.config
a7b0: 22 29 29 20 3b 3b 20 44 4f 20 4e 4f 54 20 45 56 ")) ;; DO NOT EV
a7c0: 41 4c 55 41 54 45 20 41 4c 4c 20 0a 09 09 20 20 ALUATE ALL ...
a7d0: 20 28 72 75 6e 63 6f 6e 66 69 67 20 20 28 72 65 (runconfig (re
a7e0: 61 64 2d 63 6f 6e 66 69 67 20 72 75 6e 63 6f 6e ad-config runcon
a7f0: 66 69 67 66 20 23 66 20 23 66 20 65 6e 76 69 72 figf #f #f envir
a800: 6f 6e 2d 70 61 74 74 3a 20 23 66 29 29 29 20 0a on-patt: #f))) .
a810: 09 20 20 20 20 20 20 28 69 66 20 28 68 61 73 68 . (if (hash
a820: 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 -table-ref/defau
a830: 6c 74 20 72 75 6e 63 6f 6e 66 69 67 20 28 61 72 lt runconfig (ar
a840: 67 73 3a 67 65 74 2d 61 72 67 20 22 2d 72 65 71 gs:get-arg "-req
a850: 74 61 72 67 22 29 20 23 66 29 0a 09 09 20 20 28 targ") #f)... (
a860: 6b 65 79 73 3a 74 61 72 67 65 74 2d 73 65 74 2d keys:target-set-
a870: 61 72 67 73 20 6b 65 79 73 20 28 61 72 67 73 3a args keys (args:
a880: 67 65 74 2d 61 72 67 20 22 2d 72 65 71 74 61 72 get-arg "-reqtar
a890: 67 22 29 20 61 72 67 73 3a 61 72 67 2d 68 61 73 g") args:arg-has
a8a0: 68 29 0a 09 09 20 20 28 62 65 67 69 6e 0a 09 09 h)... (begin...
a8b0: 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 (debug:print
a8c0: 20 30 20 22 45 52 52 4f 52 3a 20 5b 22 20 28 61 0 "ERROR: [" (a
a8d0: 72 67 73 3a 67 65 74 2d 61 72 67 20 22 2d 72 65 rgs:get-arg "-re
a8e0: 71 74 61 72 67 22 29 20 22 5d 20 6e 6f 74 20 66 qtarg") "] not f
a8f0: 6f 75 6e 64 20 69 6e 20 22 20 72 75 6e 63 6f 6e ound in " runcon
a900: 66 69 67 66 29 0a 09 09 20 20 20 20 28 69 66 20 figf)... (if
a910: 64 62 20 28 73 71 6c 69 74 65 33 3a 66 69 6e 61 db (sqlite3:fina
a920: 6c 69 7a 65 21 20 64 62 29 29 0a 09 09 20 20 20 lize! db))...
a930: 20 28 65 78 69 74 20 31 29 29 29 29 0a 09 20 20 (exit 1))))..
a940: 20 20 28 69 66 20 28 61 72 67 73 3a 67 65 74 2d (if (args:get-
a950: 61 72 67 20 22 2d 74 61 72 67 65 74 22 29 0a 09 arg "-target")..
a960: 09 28 6b 65 79 73 3a 74 61 72 67 65 74 2d 73 65 .(keys:target-se
a970: 74 2d 61 72 67 73 20 6b 65 79 73 20 28 61 72 67 t-args keys (arg
a980: 73 3a 67 65 74 2d 61 72 67 20 22 2d 74 61 72 67 s:get-arg "-targ
a990: 65 74 22 20 61 72 67 73 3a 61 72 67 2d 68 61 73 et" args:arg-has
a9a0: 68 29 20 61 72 67 73 3a 61 72 67 2d 68 61 73 68 h) args:arg-hash
a9b0: 29 29 29 0a 09 28 69 66 20 28 6e 6f 74 20 28 63 )))..(if (not (c
a9c0: 61 72 20 2a 63 6f 6e 66 69 67 69 6e 66 6f 2a 29 ar *configinfo*)
a9d0: 29 0a 09 20 20 20 20 28 62 65 67 69 6e 0a 09 20 ).. (begin..
a9e0: 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e (debug:prin
a9f0: 74 20 30 20 22 45 52 52 4f 52 3a 20 41 74 74 65 t 0 "ERROR: Atte
aa00: 6d 70 74 65 64 20 74 6f 20 22 20 61 63 74 69 6f mpted to " actio
aa10: 6e 2d 64 65 73 63 20 22 20 62 75 74 20 72 75 6e n-desc " but run
aa20: 20 61 72 65 61 20 63 6f 6e 66 69 67 20 66 69 6c area config fil
aa30: 65 20 6e 6f 74 20 66 6f 75 6e 64 22 29 0a 09 20 e not found")..
aa40: 20 20 20 20 20 28 65 78 69 74 20 31 29 29 0a 09 (exit 1))..
aa50: 20 20 20 20 3b 3b 20 45 78 74 72 61 63 74 20 6f ;; Extract o
aa60: 75 74 20 73 74 75 66 66 20 6e 65 65 64 65 64 20 ut stuff needed
aa70: 69 6e 20 6d 6f 73 74 20 6f 72 20 6d 61 6e 79 20 in most or many
aa80: 63 61 6c 6c 73 0a 09 20 20 20 20 3b 3b 20 68 65 calls.. ;; he
aa90: 72 65 20 74 68 65 6e 20 63 61 6c 6c 20 70 72 6f re then call pro
aaa0: 63 0a 09 20 20 20 20 28 6c 65 74 2a 20 28 28 6b c.. (let* ((k
aab0: 65 79 6e 61 6d 65 73 20 20 20 28 6d 61 70 20 6b eynames (map k
aac0: 65 79 3a 67 65 74 2d 66 69 65 6c 64 6e 61 6d 65 ey:get-fieldname
aad0: 20 6b 65 79 73 29 29 0a 09 09 20 20 20 28 6b 65 keys))... (ke
aae0: 79 76 61 6c 6c 73 74 20 20 28 6b 65 79 73 2d 3e yvallst (keys->
aaf0: 76 61 6c 6c 69 73 74 20 6b 65 79 73 20 23 74 29 vallist keys #t)
ab00: 29 29 0a 09 20 20 20 20 20 20 28 70 72 6f 63 20 )).. (proc
ab10: 74 61 72 67 65 74 20 72 75 6e 6e 61 6d 65 20 6b target runname k
ab20: 65 79 73 20 6b 65 79 6e 61 6d 65 73 20 6b 65 79 eys keynames key
ab30: 76 61 6c 6c 73 74 29 29 29 0a 09 28 69 66 20 74 vallst)))..(if t
ab40: 68 31 20 28 74 68 72 65 61 64 2d 6a 6f 69 6e 21 h1 (thread-join!
ab50: 20 74 68 31 29 29 0a 09 28 69 66 20 64 62 20 28 th1))..(if db (
ab60: 73 71 6c 69 74 65 33 3a 66 69 6e 61 6c 69 7a 65 sqlite3:finalize
ab70: 21 20 64 62 29 29 0a 09 28 73 65 74 21 20 2a 64 ! db))..(set! *d
ab80: 69 64 73 6f 6d 65 74 68 69 6e 67 2a 20 23 74 29 idsomething* #t)
ab90: 29 29 29 29 29 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d )))))..;;=======
aba0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
abb0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
abc0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
abd0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a ===============.
abe0: 3b 3b 20 4c 6f 63 6b 2f 75 6e 6c 6f 63 6b 20 72 ;; Lock/unlock r
abf0: 75 6e 73 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d uns.;;==========
ac00: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
ac10: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
ac20: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
ac30: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 28 64 ============..(d
ac40: 65 66 69 6e 65 20 28 72 75 6e 73 3a 68 61 6e 64 efine (runs:hand
ac50: 6c 65 2d 6c 6f 63 6b 69 6e 67 20 74 61 72 67 65 le-locking targe
ac60: 74 20 6b 65 79 73 20 72 75 6e 6e 61 6d 65 20 6c t keys runname l
ac70: 6f 63 6b 20 75 6e 6c 6f 63 6b 20 75 73 65 72 29 ock unlock user)
ac80: 0a 20 20 28 6c 65 74 2a 20 28 28 64 62 20 20 20 . (let* ((db
ac90: 20 20 20 20 23 66 29 0a 09 20 28 72 75 6e 64 61 #f).. (runda
aca0: 74 20 20 20 28 6f 70 65 6e 2d 72 75 6e 2d 63 6c t (open-run-cl
acb0: 6f 73 65 20 72 75 6e 73 3a 67 65 74 2d 72 75 6e ose runs:get-run
acc0: 73 2d 62 79 2d 70 61 74 74 20 64 62 20 6b 65 79 s-by-patt db key
acd0: 73 20 72 75 6e 6e 61 6d 65 29 29 0a 09 20 28 68 s runname)).. (h
ace0: 65 61 64 65 72 20 20 20 28 76 65 63 74 6f 72 2d eader (vector-
acf0: 72 65 66 20 72 75 6e 64 61 74 20 30 29 29 0a 09 ref rundat 0))..
ad00: 20 28 72 75 6e 73 20 20 20 20 20 28 76 65 63 74 (runs (vect
ad10: 6f 72 2d 72 65 66 20 72 75 6e 64 61 74 20 31 29 or-ref rundat 1)
ad20: 29 29 0a 20 20 20 20 28 66 6f 72 2d 65 61 63 68 )). (for-each
ad30: 20 28 6c 61 6d 62 64 61 20 28 72 75 6e 29 0a 09 (lambda (run)..
ad40: 09 28 6c 65 74 20 28 28 72 75 6e 2d 69 64 20 28 .(let ((run-id (
ad50: 64 62 3a 67 65 74 2d 76 61 6c 75 65 2d 62 79 2d db:get-value-by-
ad60: 68 65 61 64 65 72 20 72 75 6e 20 68 65 61 64 65 header run heade
ad70: 72 20 22 69 64 22 29 29 29 0a 09 09 20 20 28 69 r "id")))... (i
ad80: 66 20 28 6f 72 20 6c 6f 63 6b 0a 09 09 09 20 20 f (or lock....
ad90: 28 61 6e 64 20 75 6e 6c 6f 63 6b 0a 09 09 09 20 (and unlock....
ada0: 20 20 20 20 20 20 28 62 65 67 69 6e 0a 09 09 09 (begin....
adb0: 09 20 28 70 72 69 6e 74 20 22 44 6f 20 79 6f 75 . (print "Do you
adc0: 20 72 65 61 6c 6c 79 20 77 69 73 68 20 74 6f 20 really wish to
add0: 75 6e 6c 6f 63 6b 20 72 75 6e 20 22 20 72 75 6e unlock run " run
ade0: 2d 69 64 20 22 3f 5c 6e 20 20 20 79 2f 6e 3a 20 -id "?\n y/n:
adf0: 22 29 0a 09 09 09 09 20 28 65 71 75 61 6c 3f 20 ")..... (equal?
ae00: 22 79 22 20 28 72 65 61 64 2d 6c 69 6e 65 29 29 "y" (read-line))
ae10: 29 29 29 0a 09 09 20 20 20 20 20 20 28 6f 70 65 )))... (ope
ae20: 6e 2d 72 75 6e 2d 63 6c 6f 73 65 20 64 62 3a 6c n-run-close db:l
ae30: 6f 63 6b 2f 75 6e 6c 6f 63 6b 2d 72 75 6e 20 64 ock/unlock-run d
ae40: 62 20 72 75 6e 2d 69 64 20 6c 6f 63 6b 20 75 6e b run-id lock un
ae50: 6c 6f 63 6b 20 75 73 65 72 29 0a 09 09 20 20 20 lock user)...
ae60: 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d (debug:print-
ae70: 69 6e 66 6f 20 30 20 22 53 6b 69 70 70 69 6e 67 info 0 "Skipping
ae80: 20 6c 6f 63 6b 2f 75 6e 6c 6f 63 6b 20 6f 6e 20 lock/unlock on
ae90: 22 20 72 75 6e 2d 69 64 29 29 29 29 0a 09 20 20 " run-id))))..
aea0: 20 20 20 20 72 75 6e 73 29 29 29 0a 3b 3b 3d 3d runs))).;;==
aeb0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
aec0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
aed0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
aee0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
aef0: 3d 3d 3d 3d 0a 3b 3b 20 52 6f 6c 6c 75 70 20 72 ====.;; Rollup r
af00: 75 6e 73 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d uns.;;==========
af10: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
af20: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
af30: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
af40: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 3b 3b ============..;;
af50: 20 55 70 64 61 74 65 20 74 68 65 20 74 65 73 74 Update the test
af60: 5f 6d 65 74 61 20 74 61 62 6c 65 20 66 6f 72 20 _meta table for
af70: 74 68 69 73 20 74 65 73 74 0a 28 64 65 66 69 6e this test.(defin
af80: 65 20 28 72 75 6e 73 3a 75 70 64 61 74 65 2d 74 e (runs:update-t
af90: 65 73 74 5f 6d 65 74 61 20 64 62 20 74 65 73 74 est_meta db test
afa0: 2d 6e 61 6d 65 20 74 65 73 74 2d 63 6f 6e 66 29 -name test-conf)
afb0: 0a 20 20 28 6c 65 74 20 28 28 63 75 72 72 72 65 . (let ((currre
afc0: 63 6f 72 64 20 28 6f 70 65 6e 2d 72 75 6e 2d 63 cord (open-run-c
afd0: 6c 6f 73 65 20 64 62 3a 74 65 73 74 6d 65 74 61 lose db:testmeta
afe0: 2d 67 65 74 2d 72 65 63 6f 72 64 20 64 62 20 74 -get-record db t
aff0: 65 73 74 2d 6e 61 6d 65 29 29 29 0a 20 20 20 20 est-name))).
b000: 28 69 66 20 28 6e 6f 74 20 63 75 72 72 72 65 63 (if (not currrec
b010: 6f 72 64 29 0a 09 28 62 65 67 69 6e 0a 09 20 20 ord)..(begin..
b020: 28 73 65 74 21 20 63 75 72 72 72 65 63 6f 72 64 (set! currrecord
b030: 20 28 6d 61 6b 65 2d 76 65 63 74 6f 72 20 31 30 (make-vector 10
b040: 20 23 66 29 29 0a 09 20 20 28 6f 70 65 6e 2d 72 #f)).. (open-r
b050: 75 6e 2d 63 6c 6f 73 65 20 64 62 3a 74 65 73 74 un-close db:test
b060: 6d 65 74 61 2d 61 64 64 2d 72 65 63 6f 72 64 20 meta-add-record
b070: 64 62 20 74 65 73 74 2d 6e 61 6d 65 29 29 29 0a db test-name))).
b080: 20 20 20 20 28 66 6f 72 2d 65 61 63 68 20 0a 20 (for-each .
b090: 20 20 20 20 28 6c 61 6d 62 64 61 20 28 6b 65 79 (lambda (key
b0a0: 29 0a 20 20 20 20 20 20 20 28 6c 65 74 2a 20 28 ). (let* (
b0b0: 28 69 64 78 20 28 63 61 64 72 20 6b 65 79 29 29 (idx (cadr key))
b0c0: 0a 09 20 20 20 20 20 20 28 66 6c 64 20 28 63 61 .. (fld (ca
b0d0: 72 20 20 6b 65 79 29 29 0a 09 20 20 20 20 20 20 r key))..
b0e0: 28 76 61 6c 20 28 63 6f 6e 66 69 67 2d 6c 6f 6f (val (config-loo
b0f0: 6b 75 70 20 74 65 73 74 2d 63 6f 6e 66 20 22 74 kup test-conf "t
b100: 65 73 74 5f 6d 65 74 61 22 20 66 6c 64 29 29 29 est_meta" fld)))
b110: 0a 09 20 3b 3b 20 28 64 65 62 75 67 3a 70 72 69 .. ;; (debug:pri
b120: 6e 74 20 35 20 22 69 64 78 3a 20 22 20 69 64 78 nt 5 "idx: " idx
b130: 20 22 20 66 6c 64 3a 20 22 20 66 6c 64 20 22 20 " fld: " fld "
b140: 76 61 6c 3a 20 22 20 76 61 6c 29 0a 09 20 28 69 val: " val).. (i
b150: 66 20 28 61 6e 64 20 76 61 6c 20 28 6e 6f 74 20 f (and val (not
b160: 28 65 71 75 61 6c 3f 20 28 76 65 63 74 6f 72 2d (equal? (vector-
b170: 72 65 66 20 63 75 72 72 72 65 63 6f 72 64 20 69 ref currrecord i
b180: 64 78 29 20 76 61 6c 29 29 29 0a 09 20 20 20 20 dx) val)))..
b190: 20 28 62 65 67 69 6e 0a 09 20 20 20 20 20 20 20 (begin..
b1a0: 28 70 72 69 6e 74 20 22 55 70 64 61 74 69 6e 67 (print "Updating
b1b0: 20 22 20 74 65 73 74 2d 6e 61 6d 65 20 22 20 22 " test-name " "
b1c0: 20 66 6c 64 20 22 20 74 6f 20 22 20 76 61 6c 29 fld " to " val)
b1d0: 0a 09 20 20 20 20 20 20 20 28 6f 70 65 6e 2d 72 .. (open-r
b1e0: 75 6e 2d 63 6c 6f 73 65 20 64 62 3a 74 65 73 74 un-close db:test
b1f0: 6d 65 74 61 2d 75 70 64 61 74 65 2d 66 69 65 6c meta-update-fiel
b200: 64 20 64 62 20 74 65 73 74 2d 6e 61 6d 65 20 66 d db test-name f
b210: 6c 64 20 76 61 6c 29 29 29 29 29 0a 20 20 20 20 ld val))))).
b220: 20 27 28 28 22 61 75 74 68 6f 72 22 20 32 29 28 '(("author" 2)(
b230: 22 6f 77 6e 65 72 22 20 33 29 28 22 64 65 73 63 "owner" 3)("desc
b240: 72 69 70 74 69 6f 6e 22 20 34 29 28 22 72 65 76 ription" 4)("rev
b250: 69 65 77 65 64 22 20 35 29 28 22 74 61 67 73 22 iewed" 5)("tags"
b260: 20 39 29 29 29 29 29 0a 0a 3b 3b 20 55 70 64 61 9)))))..;; Upda
b270: 74 65 20 74 65 73 74 5f 6d 65 74 61 20 66 6f 72 te test_meta for
b280: 20 61 6c 6c 20 74 65 73 74 73 0a 28 64 65 66 69 all tests.(defi
b290: 6e 65 20 28 72 75 6e 73 3a 75 70 64 61 74 65 2d ne (runs:update-
b2a0: 61 6c 6c 2d 74 65 73 74 5f 6d 65 74 61 20 64 62 all-test_meta db
b2b0: 29 0a 20 20 28 6c 65 74 20 28 28 74 65 73 74 2d ). (let ((test-
b2c0: 6e 61 6d 65 73 20 28 67 65 74 2d 61 6c 6c 2d 6c names (get-all-l
b2d0: 65 67 61 6c 2d 74 65 73 74 73 29 29 29 0a 20 20 egal-tests))).
b2e0: 20 20 28 66 6f 72 2d 65 61 63 68 20 0a 20 20 20 (for-each .
b2f0: 20 20 28 6c 61 6d 62 64 61 20 28 74 65 73 74 2d (lambda (test-
b300: 6e 61 6d 65 29 0a 20 20 20 20 20 20 20 28 6c 65 name). (le
b310: 74 2a 20 28 28 74 65 73 74 2d 70 61 74 68 20 20 t* ((test-path
b320: 20 20 28 63 6f 6e 63 20 2a 74 6f 70 70 61 74 68 (conc *toppath
b330: 2a 20 22 2f 74 65 73 74 73 2f 22 20 74 65 73 74 * "/tests/" test
b340: 2d 6e 61 6d 65 29 29 0a 09 20 20 20 20 20 20 28 -name)).. (
b350: 74 65 73 74 2d 63 6f 6e 66 69 67 66 20 28 63 6f test-configf (co
b360: 6e 63 20 74 65 73 74 2d 70 61 74 68 20 22 2f 74 nc test-path "/t
b370: 65 73 74 63 6f 6e 66 69 67 22 29 29 0a 09 20 20 estconfig"))..
b380: 20 20 20 20 28 74 65 73 74 65 78 69 73 74 73 20 (testexists
b390: 20 20 28 61 6e 64 20 28 66 69 6c 65 2d 65 78 69 (and (file-exi
b3a0: 73 74 73 3f 20 74 65 73 74 2d 63 6f 6e 66 69 67 sts? test-config
b3b0: 66 29 28 66 69 6c 65 2d 72 65 61 64 2d 61 63 63 f)(file-read-acc
b3c0: 65 73 73 3f 20 74 65 73 74 2d 63 6f 6e 66 69 67 ess? test-config
b3d0: 66 29 29 29 0a 09 20 20 20 20 20 20 3b 3b 20 72 f))).. ;; r
b3e0: 65 61 64 20 63 6f 6e 66 69 67 73 20 77 69 74 68 ead configs with
b3f0: 20 74 72 69 63 6b 73 20 74 75 72 6e 65 64 20 6f tricks turned o
b400: 66 66 20 28 69 2e 65 2e 20 6e 6f 20 73 79 73 74 ff (i.e. no syst
b410: 65 6d 29 0a 09 20 20 20 20 20 20 28 74 65 73 74 em).. (test
b420: 2d 63 6f 6e 66 20 20 20 20 28 69 66 20 74 65 73 -conf (if tes
b430: 74 65 78 69 73 74 73 20 28 72 65 61 64 2d 63 6f texists (read-co
b440: 6e 66 69 67 20 74 65 73 74 2d 63 6f 6e 66 69 67 nfig test-config
b450: 66 20 23 66 20 23 66 29 28 6d 61 6b 65 2d 68 61 f #f #f)(make-ha
b460: 73 68 2d 74 61 62 6c 65 29 29 29 29 0a 09 20 3b sh-table)))).. ;
b470: 3b 20 75 73 65 20 74 68 65 20 6f 70 65 6e 2d 72 ; use the open-r
b480: 75 6e 2d 63 6c 6f 73 65 20 69 6e 73 74 65 61 64 un-close instead
b490: 20 6f 66 20 70 61 73 73 69 6e 67 20 69 6e 20 64 of passing in d
b4a0: 62 0a 09 20 28 72 75 6e 73 3a 75 70 64 61 74 65 b.. (runs:update
b4b0: 2d 74 65 73 74 5f 6d 65 74 61 20 23 66 20 74 65 -test_meta #f te
b4c0: 73 74 2d 6e 61 6d 65 20 74 65 73 74 2d 63 6f 6e st-name test-con
b4d0: 66 29 29 29 0a 20 20 20 20 20 74 65 73 74 2d 6e f))). test-n
b4e0: 61 6d 65 73 29 29 29 0a 0a 3b 3b 20 54 68 69 73 ames)))..;; This
b4f0: 20 63 6f 75 6c 64 20 70 72 6f 62 61 62 6c 79 20 could probably
b500: 62 65 20 72 65 66 61 63 74 6f 72 65 64 20 69 6e be refactored in
b510: 74 6f 20 6f 6e 65 20 63 6f 6d 70 6c 65 78 20 71 to one complex q
b520: 75 65 72 79 20 2e 2e 2e 0a 28 64 65 66 69 6e 65 uery ....(define
b530: 20 28 72 75 6e 73 3a 72 6f 6c 6c 75 70 2d 72 75 (runs:rollup-ru
b540: 6e 20 6b 65 79 73 20 6b 65 79 76 61 6c 6c 73 74 n keys keyvallst
b550: 20 72 75 6e 6e 61 6d 65 20 75 73 65 72 29 20 3b runname user) ;
b560: 3b 20 77 61 73 20 74 61 72 67 65 74 2c 20 6e 6f ; was target, no
b570: 77 20 6b 65 79 76 61 6c 6c 73 74 0a 20 20 28 64 w keyvallst. (d
b580: 65 62 75 67 3a 70 72 69 6e 74 20 34 20 22 72 75 ebug:print 4 "ru
b590: 6e 73 3a 72 6f 6c 6c 75 70 2d 72 75 6e 2c 20 6b ns:rollup-run, k
b5a0: 65 79 73 3a 20 22 20 6b 65 79 73 20 22 20 6b 65 eys: " keys " ke
b5b0: 79 76 61 6c 6c 73 74 3a 20 22 20 6b 65 79 76 61 yvallst: " keyva
b5c0: 6c 6c 73 74 20 22 20 3a 72 75 6e 6e 61 6d 65 20 llst " :runname
b5d0: 22 20 72 75 6e 6e 61 6d 65 20 22 20 75 73 65 72 " runname " user
b5e0: 3a 20 22 20 75 73 65 72 29 0a 20 20 28 6c 65 74 : " user). (let
b5f0: 2a 20 28 28 64 62 20 20 20 20 20 20 20 20 20 20 * ((db
b600: 20 20 20 20 23 66 29 20 3b 3b 20 28 6b 65 79 76 #f) ;; (keyv
b610: 61 6c 6c 6c 73 74 20 20 20 20 20 20 28 6b 65 79 alllst (key
b620: 73 3a 74 61 72 67 65 74 2d 3e 6b 65 79 76 61 6c s:target->keyval
b630: 20 6b 65 79 73 20 74 61 72 67 65 74 29 29 0a 09 keys target))..
b640: 20 28 6e 65 77 2d 72 75 6e 2d 69 64 20 20 20 20 (new-run-id
b650: 20 20 28 6f 70 65 6e 2d 72 75 6e 2d 63 6c 6f 73 (open-run-clos
b660: 65 20 72 75 6e 73 3a 72 65 67 69 73 74 65 72 2d e runs:register-
b670: 72 75 6e 20 64 62 20 6b 65 79 73 20 6b 65 79 76 run db keys keyv
b680: 61 6c 6c 73 74 20 72 75 6e 6e 61 6d 65 20 22 6e allst runname "n
b690: 65 77 22 20 22 6e 2f 61 22 20 75 73 65 72 29 29 ew" "n/a" user))
b6a0: 0a 09 20 28 70 72 65 76 2d 74 65 73 74 73 20 20 .. (prev-tests
b6b0: 20 20 20 20 28 6f 70 65 6e 2d 72 75 6e 2d 63 6c (open-run-cl
b6c0: 6f 73 65 20 74 65 73 74 3a 67 65 74 2d 6d 61 74 ose test:get-mat
b6d0: 63 68 69 6e 67 2d 70 72 65 76 69 6f 75 73 2d 74 ching-previous-t
b6e0: 65 73 74 2d 72 75 6e 2d 72 65 63 6f 72 64 73 20 est-run-records
b6f0: 64 62 20 6e 65 77 2d 72 75 6e 2d 69 64 20 22 25 db new-run-id "%
b700: 22 20 22 25 22 29 29 0a 09 20 28 63 75 72 72 2d " "%")).. (curr-
b710: 74 65 73 74 73 20 20 20 20 20 20 28 6f 70 65 6e tests (open
b720: 2d 72 75 6e 2d 63 6c 6f 73 65 20 64 62 3a 67 65 -run-close db:ge
b730: 74 2d 74 65 73 74 73 2d 66 6f 72 2d 72 75 6e 20 t-tests-for-run
b740: 64 62 20 6e 65 77 2d 72 75 6e 2d 69 64 20 22 25 db new-run-id "%
b750: 2f 25 22 20 27 28 29 20 27 28 29 29 29 0a 09 20 /%" '() '()))..
b760: 28 63 75 72 72 2d 74 65 73 74 73 2d 68 61 73 68 (curr-tests-hash
b770: 20 28 6d 61 6b 65 2d 68 61 73 68 2d 74 61 62 6c (make-hash-tabl
b780: 65 29 29 29 0a 20 20 20 20 28 6f 70 65 6e 2d 72 e))). (open-r
b790: 75 6e 2d 63 6c 6f 73 65 20 64 62 3a 75 70 64 61 un-close db:upda
b7a0: 74 65 2d 72 75 6e 2d 65 76 65 6e 74 5f 74 69 6d te-run-event_tim
b7b0: 65 20 64 62 20 6e 65 77 2d 72 75 6e 2d 69 64 29 e db new-run-id)
b7c0: 0a 20 20 20 20 3b 3b 20 69 6e 64 65 78 20 74 68 . ;; index th
b7d0: 65 20 61 6c 72 65 61 64 79 20 73 61 76 65 64 20 e already saved
b7e0: 74 65 73 74 73 20 62 79 20 74 65 73 74 6e 61 6d tests by testnam
b7f0: 65 20 61 6e 64 20 69 74 65 6d 64 61 74 20 69 6e e and itemdat in
b800: 20 63 75 72 72 2d 74 65 73 74 73 2d 68 61 73 68 curr-tests-hash
b810: 0a 20 20 20 20 28 66 6f 72 2d 65 61 63 68 0a 20 . (for-each.
b820: 20 20 20 20 28 6c 61 6d 62 64 61 20 28 74 65 73 (lambda (tes
b830: 74 64 61 74 29 0a 20 20 20 20 20 20 20 28 6c 65 tdat). (le
b840: 74 2a 20 28 28 74 65 73 74 6e 61 6d 65 20 20 28 t* ((testname (
b850: 64 62 3a 74 65 73 74 2d 67 65 74 2d 74 65 73 74 db:test-get-test
b860: 6e 61 6d 65 20 74 65 73 74 64 61 74 29 29 0a 09 name testdat))..
b870: 20 20 20 20 20 20 28 69 74 65 6d 2d 70 61 74 68 (item-path
b880: 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 69 74 (db:test-get-it
b890: 65 6d 2d 70 61 74 68 20 74 65 73 74 64 61 74 29 em-path testdat)
b8a0: 29 0a 09 20 20 20 20 20 20 28 66 75 6c 6c 2d 6e ).. (full-n
b8b0: 61 6d 65 20 28 63 6f 6e 63 20 74 65 73 74 6e 61 ame (conc testna
b8c0: 6d 65 20 22 2f 22 20 69 74 65 6d 2d 70 61 74 68 me "/" item-path
b8d0: 29 29 29 0a 09 20 28 68 61 73 68 2d 74 61 62 6c ))).. (hash-tabl
b8e0: 65 2d 73 65 74 21 20 63 75 72 72 2d 74 65 73 74 e-set! curr-test
b8f0: 73 2d 68 61 73 68 20 66 75 6c 6c 2d 6e 61 6d 65 s-hash full-name
b900: 20 74 65 73 74 64 61 74 29 29 29 0a 20 20 20 20 testdat))).
b910: 20 63 75 72 72 2d 74 65 73 74 73 29 0a 20 20 20 curr-tests).
b920: 20 3b 3b 20 4e 4f 50 45 3a 20 4e 6f 6e 2d 6f 70 ;; NOPE: Non-op
b930: 74 69 6d 61 6c 20 61 70 70 72 6f 61 63 68 2e 20 timal approach.
b940: 54 72 79 20 74 68 69 73 20 69 6e 73 74 65 61 64 Try this instead
b950: 2e 0a 20 20 20 20 3b 3b 20 20 20 31 2e 20 74 65 .. ;; 1. te
b960: 73 74 73 20 61 72 65 20 72 65 63 65 69 76 65 64 sts are received
b970: 20 69 6e 20 61 20 6c 69 73 74 2c 20 6d 6f 73 74 in a list, most
b980: 20 72 65 63 65 6e 74 20 66 69 72 73 74 0a 20 20 recent first.
b990: 20 20 3b 3b 20 20 20 32 2e 20 72 65 70 6c 61 63 ;; 2. replac
b9a0: 65 20 74 68 65 20 72 6f 6c 6c 75 70 20 74 65 73 e the rollup tes
b9b0: 74 20 77 69 74 68 20 74 68 65 20 6e 65 77 20 2a t with the new *
b9c0: 61 6c 77 61 79 73 2a 0a 20 20 20 20 28 66 6f 72 always*. (for
b9d0: 2d 65 61 63 68 20 0a 20 20 20 20 20 28 6c 61 6d -each . (lam
b9e0: 62 64 61 20 28 74 65 73 74 64 61 74 29 0a 20 20 bda (testdat).
b9f0: 20 20 20 20 20 28 6c 65 74 2a 20 28 28 74 65 73 (let* ((tes
ba00: 74 6e 61 6d 65 20 20 28 64 62 3a 74 65 73 74 2d tname (db:test-
ba10: 67 65 74 2d 74 65 73 74 6e 61 6d 65 20 74 65 73 get-testname tes
ba20: 74 64 61 74 29 29 0a 09 20 20 20 20 20 20 28 69 tdat)).. (i
ba30: 74 65 6d 2d 70 61 74 68 20 28 64 62 3a 74 65 73 tem-path (db:tes
ba40: 74 2d 67 65 74 2d 69 74 65 6d 2d 70 61 74 68 20 t-get-item-path
ba50: 74 65 73 74 64 61 74 29 29 0a 09 20 20 20 20 20 testdat))..
ba60: 20 28 66 75 6c 6c 2d 6e 61 6d 65 20 28 63 6f 6e (full-name (con
ba70: 63 20 74 65 73 74 6e 61 6d 65 20 22 2f 22 20 69 c testname "/" i
ba80: 74 65 6d 2d 70 61 74 68 29 29 0a 09 20 20 20 20 tem-path))..
ba90: 20 20 28 70 72 65 76 2d 74 65 73 74 2d 64 61 74 (prev-test-dat
baa0: 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 (hash-table-ref
bab0: 2f 64 65 66 61 75 6c 74 20 63 75 72 72 2d 74 65 /default curr-te
bac0: 73 74 73 2d 68 61 73 68 20 66 75 6c 6c 2d 6e 61 sts-hash full-na
bad0: 6d 65 20 23 66 29 29 0a 09 20 20 20 20 20 20 28 me #f)).. (
bae0: 74 65 73 74 2d 73 74 65 70 73 20 20 20 20 20 20 test-steps
baf0: 28 6f 70 65 6e 2d 72 75 6e 2d 63 6c 6f 73 65 20 (open-run-close
bb00: 64 62 3a 67 65 74 2d 73 74 65 70 73 2d 66 6f 72 db:get-steps-for
bb10: 2d 74 65 73 74 20 64 62 20 28 64 62 3a 74 65 73 -test db (db:tes
bb20: 74 2d 67 65 74 2d 69 64 20 74 65 73 74 64 61 74 t-get-id testdat
bb30: 29 29 29 0a 09 20 20 20 20 20 20 28 6e 65 77 2d ))).. (new-
bb40: 74 65 73 74 2d 72 65 63 6f 72 64 20 23 66 29 29 test-record #f))
bb50: 0a 09 20 3b 3b 20 72 65 70 6c 61 63 65 20 74 68 .. ;; replace th
bb60: 65 73 65 20 77 69 74 68 20 69 6e 73 65 72 74 20 ese with insert
bb70: 2e 2e 2e 20 73 65 6c 65 63 74 0a 09 20 28 61 70 ... select.. (ap
bb80: 70 6c 79 20 73 71 6c 69 74 65 33 3a 65 78 65 63 ply sqlite3:exec
bb90: 75 74 65 20 0a 09 09 64 62 20 0a 09 09 28 63 6f ute ...db ...(co
bba0: 6e 63 20 22 49 4e 53 45 52 54 20 4f 52 20 52 45 nc "INSERT OR RE
bbb0: 50 4c 41 43 45 20 49 4e 54 4f 20 74 65 73 74 73 PLACE INTO tests
bbc0: 20 28 72 75 6e 5f 69 64 2c 74 65 73 74 6e 61 6d (run_id,testnam
bbd0: 65 2c 73 74 61 74 65 2c 73 74 61 74 75 73 2c 65 e,state,status,e
bbe0: 76 65 6e 74 5f 74 69 6d 65 2c 68 6f 73 74 2c 63 vent_time,host,c
bbf0: 70 75 6c 6f 61 64 2c 64 69 73 6b 66 72 65 65 2c puload,diskfree,
bc00: 75 6e 61 6d 65 2c 72 75 6e 64 69 72 2c 69 74 65 uname,rundir,ite
bc10: 6d 5f 70 61 74 68 2c 72 75 6e 5f 64 75 72 61 74 m_path,run_durat
bc20: 69 6f 6e 2c 66 69 6e 61 6c 5f 6c 6f 67 66 2c 63 ion,final_logf,c
bc30: 6f 6d 6d 65 6e 74 29 20 22 0a 09 09 20 20 20 20 omment) "...
bc40: 20 20 22 56 41 4c 55 45 53 20 28 3f 2c 3f 2c 3f "VALUES (?,?,?
bc50: 2c 3f 2c 3f 2c 3f 2c 3f 2c 3f 2c 3f 2c 3f 2c 3f ,?,?,?,?,?,?,?,?
bc60: 2c 3f 2c 3f 2c 3f 29 3b 22 29 0a 09 09 6e 65 77 ,?,?,?);")...new
bc70: 2d 72 75 6e 2d 69 64 20 28 63 64 64 72 20 28 76 -run-id (cddr (v
bc80: 65 63 74 6f 72 2d 3e 6c 69 73 74 20 74 65 73 74 ector->list test
bc90: 64 61 74 29 29 29 0a 09 20 28 73 65 74 21 20 6e dat))).. (set! n
bca0: 65 77 2d 74 65 73 74 64 61 74 20 28 63 61 72 20 ew-testdat (car
bcb0: 28 6f 70 65 6e 2d 72 75 6e 2d 63 6c 6f 73 65 20 (open-run-close
bcc0: 64 62 3a 67 65 74 2d 74 65 73 74 73 2d 66 6f 72 db:get-tests-for
bcd0: 2d 72 75 6e 20 64 62 20 6e 65 77 2d 72 75 6e 2d -run db new-run-
bce0: 69 64 20 28 63 6f 6e 63 20 74 65 73 74 6e 61 6d id (conc testnam
bcf0: 65 20 22 2f 22 20 69 74 65 6d 2d 70 61 74 68 29 e "/" item-path)
bd00: 20 27 28 29 20 27 28 29 29 29 29 0a 09 20 28 68 '() '()))).. (h
bd10: 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 63 ash-table-set! c
bd20: 75 72 72 2d 74 65 73 74 73 2d 68 61 73 68 20 66 urr-tests-hash f
bd30: 75 6c 6c 2d 6e 61 6d 65 20 6e 65 77 2d 74 65 73 ull-name new-tes
bd40: 74 64 61 74 29 20 3b 3b 20 74 68 69 73 20 63 6f tdat) ;; this co
bd50: 75 6c 64 20 62 65 20 63 6f 6e 66 75 73 69 6e 67 uld be confusing
bd60: 2c 20 77 68 69 63 68 20 72 65 63 6f 72 64 20 73 , which record s
bd70: 68 6f 75 6c 64 20 67 6f 20 69 6e 74 6f 20 74 68 hould go into th
bd80: 65 20 6c 6f 6f 6b 75 70 20 74 61 62 6c 65 3f 0a e lookup table?.
bd90: 09 20 3b 3b 20 4e 6f 77 20 64 75 70 6c 69 63 61 . ;; Now duplica
bda0: 74 65 20 74 68 65 20 74 65 73 74 20 73 74 65 70 te the test step
bdb0: 73 0a 09 20 28 64 65 62 75 67 3a 70 72 69 6e 74 s.. (debug:print
bdc0: 20 34 20 22 43 6f 70 79 69 6e 67 20 72 65 63 6f 4 "Copying reco
bdd0: 72 64 73 20 69 6e 20 74 65 73 74 5f 73 74 65 70 rds in test_step
bde0: 73 20 66 72 6f 6d 20 74 65 73 74 5f 69 64 3d 22 s from test_id="
bdf0: 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 69 64 (db:test-get-id
be00: 20 74 65 73 74 64 61 74 29 20 22 20 74 6f 20 22 testdat) " to "
be10: 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 69 64 (db:test-get-id
be20: 20 6e 65 77 2d 74 65 73 74 64 61 74 29 29 0a 09 new-testdat))..
be30: 20 28 6f 70 65 6e 2d 72 75 6e 2d 63 6c 6f 73 65 (open-run-close
be40: 20 0a 09 20 20 28 6c 61 6d 62 64 61 20 28 29 0a .. (lambda ().
be50: 09 20 20 20 20 28 73 71 6c 69 74 65 33 3a 65 78 . (sqlite3:ex
be60: 65 63 75 74 65 20 0a 09 20 20 20 20 20 64 62 20 ecute .. db
be70: 0a 09 20 20 20 20 20 28 63 6f 6e 63 20 22 49 4e .. (conc "IN
be80: 53 45 52 54 20 4f 52 20 52 45 50 4c 41 43 45 20 SERT OR REPLACE
be90: 49 4e 54 4f 20 74 65 73 74 5f 73 74 65 70 73 20 INTO test_steps
bea0: 28 74 65 73 74 5f 69 64 2c 73 74 65 70 6e 61 6d (test_id,stepnam
beb0: 65 2c 73 74 61 74 65 2c 73 74 61 74 75 73 2c 65 e,state,status,e
bec0: 76 65 6e 74 5f 74 69 6d 65 2c 63 6f 6d 6d 65 6e vent_time,commen
bed0: 74 29 20 22 0a 09 09 20 20 20 22 53 45 4c 45 43 t) "... "SELEC
bee0: 54 20 22 20 28 64 62 3a 74 65 73 74 2d 67 65 74 T " (db:test-get
bef0: 2d 69 64 20 6e 65 77 2d 74 65 73 74 64 61 74 29 -id new-testdat)
bf00: 20 22 2c 73 74 65 70 6e 61 6d 65 2c 73 74 61 74 ",stepname,stat
bf10: 65 2c 73 74 61 74 75 73 2c 65 76 65 6e 74 5f 74 e,status,event_t
bf20: 69 6d 65 2c 63 6f 6d 6d 65 6e 74 20 46 52 4f 4d ime,comment FROM
bf30: 20 74 65 73 74 5f 73 74 65 70 73 20 57 48 45 52 test_steps WHER
bf40: 45 20 74 65 73 74 5f 69 64 3d 3f 3b 22 29 0a 09 E test_id=?;")..
bf50: 20 20 20 20 20 28 64 62 3a 74 65 73 74 2d 67 65 (db:test-ge
bf60: 74 2d 69 64 20 74 65 73 74 64 61 74 29 29 0a 09 t-id testdat))..
bf70: 20 20 20 20 3b 3b 20 4e 6f 77 20 64 75 70 6c 69 ;; Now dupli
bf80: 63 61 74 65 20 74 68 65 20 74 65 73 74 20 64 61 cate the test da
bf90: 74 61 0a 09 20 20 20 20 28 64 65 62 75 67 3a 70 ta.. (debug:p
bfa0: 72 69 6e 74 20 34 20 22 43 6f 70 79 69 6e 67 20 rint 4 "Copying
bfb0: 72 65 63 6f 72 64 73 20 69 6e 20 74 65 73 74 5f records in test_
bfc0: 64 61 74 61 20 66 72 6f 6d 20 74 65 73 74 5f 69 data from test_i
bfd0: 64 3d 22 20 28 64 62 3a 74 65 73 74 2d 67 65 74 d=" (db:test-get
bfe0: 2d 69 64 20 74 65 73 74 64 61 74 29 20 22 20 74 -id testdat) " t
bff0: 6f 20 22 20 28 64 62 3a 74 65 73 74 2d 67 65 74 o " (db:test-get
c000: 2d 69 64 20 6e 65 77 2d 74 65 73 74 64 61 74 29 -id new-testdat)
c010: 29 0a 09 20 20 20 20 28 73 71 6c 69 74 65 33 3a ).. (sqlite3:
c020: 65 78 65 63 75 74 65 20 0a 09 20 20 20 20 20 64 execute .. d
c030: 62 20 0a 09 20 20 20 20 20 28 63 6f 6e 63 20 22 b .. (conc "
c040: 49 4e 53 45 52 54 20 4f 52 20 52 45 50 4c 41 43 INSERT OR REPLAC
c050: 45 20 49 4e 54 4f 20 74 65 73 74 5f 64 61 74 61 E INTO test_data
c060: 20 28 74 65 73 74 5f 69 64 2c 63 61 74 65 67 6f (test_id,catego
c070: 72 79 2c 76 61 72 69 61 62 6c 65 2c 76 61 6c 75 ry,variable,valu
c080: 65 2c 65 78 70 65 63 74 65 64 2c 74 6f 6c 2c 75 e,expected,tol,u
c090: 6e 69 74 73 2c 63 6f 6d 6d 65 6e 74 29 20 22 0a nits,comment) ".
c0a0: 09 09 20 20 20 22 53 45 4c 45 43 54 20 22 20 28 .. "SELECT " (
c0b0: 64 62 3a 74 65 73 74 2d 67 65 74 2d 69 64 20 6e db:test-get-id n
c0c0: 65 77 2d 74 65 73 74 64 61 74 29 20 22 2c 63 61 ew-testdat) ",ca
c0d0: 74 65 67 6f 72 79 2c 76 61 72 69 61 62 6c 65 2c tegory,variable,
c0e0: 76 61 6c 75 65 2c 65 78 70 65 63 74 65 64 2c 74 value,expected,t
c0f0: 6f 6c 2c 75 6e 69 74 73 2c 63 6f 6d 6d 65 6e 74 ol,units,comment
c100: 20 46 52 4f 4d 20 74 65 73 74 5f 64 61 74 61 20 FROM test_data
c110: 57 48 45 52 45 20 74 65 73 74 5f 69 64 3d 3f 3b WHERE test_id=?;
c120: 22 29 0a 09 20 20 20 20 20 28 64 62 3a 74 65 73 ").. (db:tes
c130: 74 2d 67 65 74 2d 69 64 20 74 65 73 74 64 61 74 t-get-id testdat
c140: 29 29 29 29 0a 09 20 29 29 0a 20 20 20 20 20 70 )))).. )). p
c150: 72 65 76 2d 74 65 73 74 73 29 29 29 0a 09 20 0a rev-tests))).. .
c160: 20 20 20 20 20 0a .