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 31 2c 20 4d 61 74 74 68 65 77 06-2011, 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 20 34 20 22 49 4e 46 4f 3a 20 72 75 6e int 4 "INFO: run
07c0: 73 3a 67 65 74 2d 72 75 6e 73 2d 62 79 2d 70 61 s:get-runs-by-pa
07d0: 74 74 20 71 72 79 3d 22 20 71 72 79 2d 73 74 72 tt qry=" qry-str
07e0: 20 22 20 22 20 72 75 6e 6e 61 6d 65 70 61 74 74 " " runnamepatt
07f0: 29 0a 20 20 20 20 28 73 71 6c 69 74 65 33 3a 66 ). (sqlite3:f
0800: 6f 72 2d 65 61 63 68 2d 72 6f 77 20 0a 20 20 20 or-each-row .
0810: 20 20 28 6c 61 6d 62 64 61 20 28 61 20 2e 20 72 (lambda (a . r
0820: 29 0a 20 20 20 20 20 20 20 28 73 65 74 21 20 72 ). (set! r
0830: 65 73 20 28 63 6f 6e 73 20 28 6c 69 73 74 2d 3e es (cons (list->
0840: 76 65 63 74 6f 72 20 28 63 6f 6e 73 20 61 20 72 vector (cons a r
0850: 29 29 20 72 65 73 29 29 29 0a 20 20 20 20 20 64 )) res))). d
0860: 62 20 0a 20 20 20 20 20 71 72 79 2d 73 74 72 0a b . qry-str.
0870: 20 20 20 20 20 72 75 6e 6e 61 6d 65 70 61 74 74 runnamepatt
0880: 29 0a 20 20 20 20 28 76 65 63 74 6f 72 20 68 65 ). (vector he
0890: 61 64 65 72 20 72 65 73 29 29 29 0a 0a 28 64 65 ader res)))..(de
08a0: 66 69 6e 65 20 28 72 75 6e 73 3a 74 65 73 74 2d fine (runs:test-
08b0: 67 65 74 2d 66 75 6c 6c 2d 70 61 74 68 20 74 65 get-full-path te
08c0: 73 74 29 0a 20 20 28 6c 65 74 2a 20 28 28 74 65 st). (let* ((te
08d0: 73 74 6e 61 6d 65 20 28 64 62 3a 74 65 73 74 2d stname (db:test-
08e0: 67 65 74 2d 74 65 73 74 6e 61 6d 65 20 20 20 74 get-testname t
08f0: 65 73 74 29 29 0a 09 20 28 69 74 65 6d 70 61 74 est)).. (itempat
0900: 68 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 69 h (db:test-get-i
0910: 74 65 6d 2d 70 61 74 68 20 74 65 73 74 29 29 29 tem-path test)))
0920: 0a 20 20 20 20 28 63 6f 6e 63 20 74 65 73 74 6e . (conc testn
0930: 61 6d 65 20 28 69 66 20 28 65 71 75 61 6c 3f 20 ame (if (equal?
0940: 69 74 65 6d 70 61 74 68 20 22 22 29 20 22 22 20 itempath "") ""
0950: 28 63 6f 6e 63 20 22 28 22 20 69 74 65 6d 70 61 (conc "(" itempa
0960: 74 68 20 22 29 22 29 29 29 29 29 0a 0a 3b 3b 20 th ")")))))..;;
0970: 41 77 66 75 6c 2e 20 50 6c 65 61 73 65 20 46 49 Awful. Please FI
0980: 58 4d 45 0a 28 64 65 66 69 6e 65 20 2a 65 6e 76 XME.(define *env
0990: 2d 76 61 72 73 2d 62 79 2d 72 75 6e 2d 69 64 2a -vars-by-run-id*
09a0: 20 28 6d 61 6b 65 2d 68 61 73 68 2d 74 61 62 6c (make-hash-tabl
09b0: 65 29 29 0a 28 64 65 66 69 6e 65 20 2a 63 75 72 e)).(define *cur
09c0: 72 65 6e 74 2d 72 75 6e 2d 6e 61 6d 65 2a 20 20 rent-run-name*
09d0: 20 23 66 29 0a 0a 28 64 65 66 69 6e 65 20 28 73 #f)..(define (s
09e0: 65 74 2d 6d 65 67 61 74 65 73 74 2d 65 6e 76 2d et-megatest-env-
09f0: 76 61 72 73 20 64 62 20 72 75 6e 2d 69 64 29 0a vars db run-id).
0a00: 20 20 28 6c 65 74 20 28 28 6b 65 79 73 20 28 64 (let ((keys (d
0a10: 62 3a 67 65 74 2d 6b 65 79 73 20 64 62 29 29 0a b:get-keys db)).
0a20: 09 28 76 61 6c 73 20 28 68 61 73 68 2d 74 61 62 .(vals (hash-tab
0a30: 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 2a le-ref/default *
0a40: 65 6e 76 2d 76 61 72 73 2d 62 79 2d 72 75 6e 2d env-vars-by-run-
0a50: 69 64 2a 20 72 75 6e 2d 69 64 20 23 66 29 29 29 id* run-id #f)))
0a60: 0a 20 20 20 20 3b 3b 20 67 65 74 20 74 68 65 20 . ;; get the
0a70: 69 6e 66 6f 20 66 72 6f 6d 20 74 68 65 20 64 62 info from the db
0a80: 20 61 6e 64 20 70 75 74 20 69 74 20 69 6e 20 74 and put it in t
0a90: 68 65 20 63 61 63 68 65 0a 20 20 20 20 28 69 66 he cache. (if
0aa0: 20 28 6e 6f 74 20 76 61 6c 73 29 0a 09 28 6c 65 (not vals)..(le
0ab0: 74 20 28 28 68 74 20 28 6d 61 6b 65 2d 68 61 73 t ((ht (make-has
0ac0: 68 2d 74 61 62 6c 65 29 29 29 0a 09 20 20 28 68 h-table))).. (h
0ad0: 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 2a ash-table-set! *
0ae0: 65 6e 76 2d 76 61 72 73 2d 62 79 2d 72 75 6e 2d env-vars-by-run-
0af0: 69 64 2a 20 72 75 6e 2d 69 64 20 68 74 29 0a 09 id* run-id ht)..
0b00: 20 20 28 73 65 74 21 20 76 61 6c 73 20 68 74 29 (set! vals ht)
0b10: 0a 09 20 20 28 66 6f 72 2d 65 61 63 68 0a 09 20 .. (for-each..
0b20: 20 20 28 6c 61 6d 62 64 61 20 28 6b 65 79 29 0a (lambda (key).
0b30: 09 20 20 20 20 20 28 73 71 6c 69 74 65 33 3a 66 . (sqlite3:f
0b40: 6f 72 2d 65 61 63 68 2d 72 6f 77 0a 09 20 20 20 or-each-row..
0b50: 20 20 20 28 6c 61 6d 62 64 61 20 28 76 61 6c 29 (lambda (val)
0b60: 0a 09 09 28 68 61 73 68 2d 74 61 62 6c 65 2d 73 ...(hash-table-s
0b70: 65 74 21 20 76 61 6c 73 20 6b 65 79 20 76 61 6c et! vals key val
0b80: 29 29 0a 09 20 20 20 20 20 20 64 62 20 0a 09 20 )).. db ..
0b90: 20 20 20 20 20 28 63 6f 6e 63 20 22 53 45 4c 45 (conc "SELE
0ba0: 43 54 20 22 20 28 6b 65 79 3a 67 65 74 2d 66 69 CT " (key:get-fi
0bb0: 65 6c 64 6e 61 6d 65 20 6b 65 79 29 20 22 20 46 eldname key) " F
0bc0: 52 4f 4d 20 72 75 6e 73 20 57 48 45 52 45 20 69 ROM runs WHERE i
0bd0: 64 3d 3f 3b 22 29 0a 09 20 20 20 20 20 20 72 75 d=?;").. ru
0be0: 6e 2d 69 64 29 29 0a 09 20 20 20 6b 65 79 73 29 n-id)).. keys)
0bf0: 29 29 0a 20 20 20 20 3b 3b 20 66 72 6f 6d 20 74 )). ;; from t
0c00: 68 65 20 63 61 63 68 65 64 20 64 61 74 61 20 73 he cached data s
0c10: 65 74 20 74 68 65 20 76 61 72 73 0a 20 20 20 20 et the vars.
0c20: 28 68 61 73 68 2d 74 61 62 6c 65 2d 66 6f 72 2d (hash-table-for-
0c30: 65 61 63 68 0a 20 20 20 20 20 76 61 6c 73 0a 20 each. vals.
0c40: 20 20 20 20 28 6c 61 6d 62 64 61 20 28 6b 65 79 (lambda (key
0c50: 20 76 61 6c 29 0a 20 20 20 20 20 20 20 28 64 65 val). (de
0c60: 62 75 67 3a 70 72 69 6e 74 20 32 20 22 73 65 74 bug:print 2 "set
0c70: 65 6e 76 20 22 20 28 6b 65 79 3a 67 65 74 2d 66 env " (key:get-f
0c80: 69 65 6c 64 6e 61 6d 65 20 6b 65 79 29 20 22 20 ieldname key) "
0c90: 22 20 76 61 6c 29 0a 20 20 20 20 20 20 20 28 73 " val). (s
0ca0: 65 74 65 6e 76 20 28 6b 65 79 3a 67 65 74 2d 66 etenv (key:get-f
0cb0: 69 65 6c 64 6e 61 6d 65 20 6b 65 79 29 20 76 61 ieldname key) va
0cc0: 6c 29 29 29 0a 20 20 20 20 28 61 6c 69 73 74 2d l))). (alist-
0cd0: 3e 65 6e 76 2d 76 61 72 73 20 28 68 61 73 68 2d >env-vars (hash-
0ce0: 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c table-ref/defaul
0cf0: 74 20 2a 63 6f 6e 66 69 67 64 61 74 2a 20 22 65 t *configdat* "e
0d00: 6e 76 2d 6f 76 65 72 72 69 64 65 22 20 27 28 29 nv-override" '()
0d10: 29 29 0a 20 20 20 20 3b 3b 20 4c 65 74 73 20 75 )). ;; Lets u
0d20: 73 65 20 74 68 69 73 20 61 73 20 61 6e 20 6f 70 se this as an op
0d30: 70 6f 72 74 75 6e 69 74 79 20 74 6f 20 70 75 74 portunity to put
0d40: 20 4d 54 5f 52 55 4e 4e 41 4d 45 20 69 6e 20 74 MT_RUNNAME in t
0d50: 68 65 20 65 6e 76 69 72 6f 6e 6d 65 6e 74 0a 20 he environment.
0d60: 20 20 20 28 69 66 20 28 6e 6f 74 20 2a 63 75 72 (if (not *cur
0d70: 72 65 6e 74 2d 72 75 6e 2d 6e 61 6d 65 2a 29 0a rent-run-name*).
0d80: 09 28 73 71 6c 69 74 65 33 3a 66 6f 72 2d 65 61 .(sqlite3:for-ea
0d90: 63 68 2d 72 6f 77 0a 09 20 28 6c 61 6d 62 64 61 ch-row.. (lambda
0da0: 20 28 72 75 6e 6e 61 6d 65 29 0a 09 20 20 20 28 (runname).. (
0db0: 73 65 74 21 20 2a 63 75 72 72 65 6e 74 2d 72 75 set! *current-ru
0dc0: 6e 2d 6e 61 6d 65 2a 20 72 75 6e 6e 61 6d 65 29 n-name* runname)
0dd0: 29 0a 0a 09 20 64 62 0a 09 20 22 53 45 4c 45 43 )... db.. "SELEC
0de0: 54 20 72 75 6e 6e 61 6d 65 20 46 52 4f 4d 20 72 T runname FROM r
0df0: 75 6e 73 20 57 48 45 52 45 20 69 64 3d 3f 3b 22 uns WHERE id=?;"
0e00: 0a 09 20 72 75 6e 2d 69 64 29 29 0a 20 20 20 20 .. run-id)).
0e10: 28 73 65 74 65 6e 76 20 22 4d 54 5f 52 55 4e 4e (setenv "MT_RUNN
0e20: 41 4d 45 22 20 2a 63 75 72 72 65 6e 74 2d 72 75 AME" *current-ru
0e30: 6e 2d 6e 61 6d 65 2a 29 0a 20 20 20 20 28 73 65 n-name*). (se
0e40: 74 65 6e 76 20 22 4d 54 5f 52 55 4e 5f 41 52 45 tenv "MT_RUN_ARE
0e50: 41 5f 48 4f 4d 45 22 20 2a 74 6f 70 70 61 74 68 A_HOME" *toppath
0e60: 2a 29 0a 20 20 20 20 29 29 0a 0a 28 64 65 66 69 *). ))..(defi
0e70: 6e 65 20 28 73 65 74 2d 69 74 65 6d 2d 65 6e 76 ne (set-item-env
0e80: 2d 76 61 72 73 20 69 74 65 6d 64 61 74 29 0a 20 -vars itemdat).
0e90: 20 28 66 6f 72 2d 65 61 63 68 20 28 6c 61 6d 62 (for-each (lamb
0ea0: 64 61 20 28 69 74 65 6d 29 0a 09 20 20 20 20 20 da (item)..
0eb0: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 32 20 (debug:print 2
0ec0: 22 73 65 74 65 6e 76 20 22 20 28 63 61 72 20 69 "setenv " (car i
0ed0: 74 65 6d 29 20 22 20 22 20 28 63 61 64 72 20 69 tem) " " (cadr i
0ee0: 74 65 6d 29 29 0a 09 20 20 20 20 20 20 28 73 65 tem)).. (se
0ef0: 74 65 6e 76 20 28 63 61 72 20 69 74 65 6d 29 20 tenv (car item)
0f00: 28 63 61 64 72 20 69 74 65 6d 29 29 29 0a 09 20 (cadr item)))..
0f10: 20 20 20 69 74 65 6d 64 61 74 29 29 0a 0a 28 64 itemdat))..(d
0f20: 65 66 69 6e 65 20 2a 6c 61 73 74 2d 6e 75 6d 2d efine *last-num-
0f30: 72 75 6e 6e 69 6e 67 2d 74 65 73 74 73 2a 20 30 running-tests* 0
0f40: 29 0a 28 64 65 66 69 6e 65 20 28 72 75 6e 73 3a ).(define (runs:
0f50: 63 61 6e 2d 72 75 6e 2d 6d 6f 72 65 2d 74 65 73 can-run-more-tes
0f60: 74 73 20 64 62 20 74 65 73 74 2d 72 65 63 6f 72 ts db test-recor
0f70: 64 29 0a 20 20 28 6c 65 74 2a 20 28 28 74 63 6f d). (let* ((tco
0f80: 6e 66 69 67 20 20 20 20 20 20 20 20 20 20 20 20 nfig
0f90: 20 20 20 20 20 28 74 65 73 74 73 3a 74 65 73 74 (tests:test
0fa0: 71 75 65 75 65 2d 67 65 74 2d 74 65 73 74 63 6f queue-get-testco
0fb0: 6e 66 69 67 20 74 65 73 74 2d 72 65 63 6f 72 64 nfig test-record
0fc0: 29 29 0a 09 20 28 6a 6f 62 67 72 6f 75 70 20 20 )).. (jobgroup
0fd0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 63 (c
0fe0: 6f 6e 66 69 67 2d 6c 6f 6f 6b 75 70 20 74 63 6f onfig-lookup tco
0ff0: 6e 66 69 67 20 22 72 65 71 75 69 72 65 6d 65 6e nfig "requiremen
1000: 74 73 22 20 22 6a 6f 62 67 72 6f 75 70 22 29 29 ts" "jobgroup"))
1010: 0a 09 20 28 6e 75 6d 2d 72 75 6e 6e 69 6e 67 20 .. (num-running
1020: 20 20 20 20 20 20 20 20 20 20 20 20 28 64 62 3a (db:
1030: 67 65 74 2d 63 6f 75 6e 74 2d 74 65 73 74 73 2d get-count-tests-
1040: 72 75 6e 6e 69 6e 67 20 64 62 29 29 0a 09 20 28 running db)).. (
1050: 6e 75 6d 2d 72 75 6e 6e 69 6e 67 2d 69 6e 2d 6a num-running-in-j
1060: 6f 62 67 72 6f 75 70 20 28 64 62 3a 67 65 74 2d obgroup (db:get-
1070: 63 6f 75 6e 74 2d 74 65 73 74 73 2d 72 75 6e 6e count-tests-runn
1080: 69 6e 67 2d 69 6e 2d 6a 6f 62 67 72 6f 75 70 20 ing-in-jobgroup
1090: 64 62 20 6a 6f 62 67 72 6f 75 70 29 29 0a 09 20 db jobgroup))..
10a0: 28 6d 61 78 2d 63 6f 6e 63 75 72 72 65 6e 74 2d (max-concurrent-
10b0: 6a 6f 62 73 20 20 20 20 20 28 6c 65 74 20 28 28 jobs (let ((
10c0: 6d 63 6a 20 28 63 6f 6e 66 69 67 2d 6c 6f 6f 6b mcj (config-look
10d0: 75 70 20 2a 63 6f 6e 66 69 67 64 61 74 2a 20 22 up *configdat* "
10e0: 73 65 74 75 70 22 20 20 20 20 20 22 6d 61 78 5f setup" "max_
10f0: 63 6f 6e 63 75 72 72 65 6e 74 5f 6a 6f 62 73 22 concurrent_jobs"
1100: 29 29 29 0a 09 09 09 09 20 20 20 20 28 69 66 20 )))..... (if
1110: 28 61 6e 64 20 6d 63 6a 20 28 73 74 72 69 6e 67 (and mcj (string
1120: 2d 3e 6e 75 6d 62 65 72 20 6d 63 6a 29 29 0a 09 ->number mcj))..
1130: 09 09 09 09 28 73 74 72 69 6e 67 2d 3e 6e 75 6d ....(string->num
1140: 62 65 72 20 6d 63 6a 29 0a 09 09 09 09 09 23 66 ber mcj)......#f
1150: 29 29 29 0a 09 20 28 6a 6f 62 2d 67 72 6f 75 70 ))).. (job-group
1160: 2d 6c 69 6d 69 74 20 20 20 20 20 20 20 20 20 28 -limit (
1170: 63 6f 6e 66 69 67 2d 6c 6f 6f 6b 75 70 20 2a 63 config-lookup *c
1180: 6f 6e 66 69 67 64 61 74 2a 20 22 6a 6f 62 67 72 onfigdat* "jobgr
1190: 6f 75 70 73 22 20 6a 6f 62 67 72 6f 75 70 29 29 oups" jobgroup))
11a0: 29 0a 20 20 20 20 28 69 66 20 28 6e 6f 74 20 28 ). (if (not (
11b0: 65 71 3f 20 2a 6c 61 73 74 2d 6e 75 6d 2d 72 75 eq? *last-num-ru
11c0: 6e 6e 69 6e 67 2d 74 65 73 74 73 2a 20 6e 75 6d nning-tests* num
11d0: 2d 72 75 6e 6e 69 6e 67 29 29 0a 09 28 62 65 67 -running))..(beg
11e0: 69 6e 0a 09 20 20 28 64 65 62 75 67 3a 70 72 69 in.. (debug:pri
11f0: 6e 74 20 32 20 22 6d 61 78 2d 63 6f 6e 63 75 72 nt 2 "max-concur
1200: 72 65 6e 74 2d 6a 6f 62 73 3a 20 22 20 6d 61 78 rent-jobs: " max
1210: 2d 63 6f 6e 63 75 72 72 65 6e 74 2d 6a 6f 62 73 -concurrent-jobs
1220: 20 22 2c 20 6e 75 6d 2d 72 75 6e 6e 69 6e 67 3a ", num-running:
1230: 20 22 20 6e 75 6d 2d 72 75 6e 6e 69 6e 67 29 0a " num-running).
1240: 09 20 20 28 73 65 74 21 20 2a 6c 61 73 74 2d 6e . (set! *last-n
1250: 75 6d 2d 72 75 6e 6e 69 6e 67 2d 74 65 73 74 73 um-running-tests
1260: 2a 20 6e 75 6d 2d 72 75 6e 6e 69 6e 67 29 29 29 * num-running)))
1270: 0a 20 20 20 20 28 69 66 20 28 6e 6f 74 20 28 65 . (if (not (e
1280: 71 3f 20 30 20 2a 67 6c 6f 62 61 6c 65 78 69 74 q? 0 *globalexit
1290: 73 74 61 74 75 73 2a 29 29 0a 09 28 6c 69 73 74 status*))..(list
12a0: 20 23 66 20 6e 75 6d 2d 72 75 6e 6e 69 6e 67 20 #f num-running
12b0: 6e 75 6d 2d 72 75 6e 6e 69 6e 67 2d 69 6e 2d 6a num-running-in-j
12c0: 6f 62 67 72 6f 75 70 20 6d 61 78 2d 63 6f 6e 63 obgroup max-conc
12d0: 75 72 72 65 6e 74 2d 6a 6f 62 73 20 6a 6f 62 2d urrent-jobs job-
12e0: 67 72 6f 75 70 2d 6c 69 6d 69 74 29 0a 09 28 6c group-limit)..(l
12f0: 65 74 20 28 28 63 61 6e 2d 6e 6f 74 2d 72 75 6e et ((can-not-run
1300: 2d 6d 6f 72 65 20 28 63 6f 6e 64 0a 09 09 09 09 -more (cond.....
1310: 20 3b 3b 20 69 66 20 6d 61 78 2d 63 6f 6e 63 75 ;; if max-concu
1320: 72 72 65 6e 74 2d 6a 6f 62 73 20 69 73 20 73 65 rrent-jobs is se
1330: 74 20 61 6e 64 20 74 68 65 20 6e 75 6d 62 65 72 t and the number
1340: 20 72 75 6e 6e 69 6e 67 20 69 73 20 67 72 65 61 running is grea
1350: 74 65 72 20 0a 09 09 09 09 20 3b 3b 20 74 68 61 ter ..... ;; tha
1360: 6e 20 69 74 20 74 68 61 6e 20 63 61 6e 6e 6f 74 n it than cannot
1370: 20 72 75 6e 20 6d 6f 72 65 20 6a 6f 62 73 0a 09 run more jobs..
1380: 09 09 09 20 28 28 61 6e 64 20 6d 61 78 2d 63 6f ... ((and max-co
1390: 6e 63 75 72 72 65 6e 74 2d 6a 6f 62 73 20 28 3e ncurrent-jobs (>
13a0: 3d 20 6e 75 6d 2d 72 75 6e 6e 69 6e 67 20 6d 61 = num-running ma
13b0: 78 2d 63 6f 6e 63 75 72 72 65 6e 74 2d 6a 6f 62 x-concurrent-job
13c0: 73 29 29 0a 09 09 09 09 20 20 28 64 65 62 75 67 s))..... (debug
13d0: 3a 70 72 69 6e 74 20 30 20 22 57 41 52 4e 49 4e :print 0 "WARNIN
13e0: 47 3a 20 4d 61 78 20 72 75 6e 6e 69 6e 67 20 6a G: Max running j
13f0: 6f 62 73 20 65 78 63 65 65 64 65 64 2c 20 63 75 obs exceeded, cu
1400: 72 72 65 6e 74 20 6e 75 6d 62 65 72 20 72 75 6e rrent number run
1410: 6e 69 6e 67 3a 20 22 20 6e 75 6d 2d 72 75 6e 6e ning: " num-runn
1420: 69 6e 67 20 0a 09 09 09 09 09 20 20 20 20 20 20 ing ......
1430: 20 22 2c 20 6d 61 78 5f 63 6f 6e 63 75 72 72 65 ", max_concurre
1440: 6e 74 5f 6a 6f 62 73 3a 20 22 20 6d 61 78 2d 63 nt_jobs: " max-c
1450: 6f 6e 63 75 72 72 65 6e 74 2d 6a 6f 62 73 29 0a oncurrent-jobs).
1460: 09 09 09 09 20 20 23 74 29 0a 09 09 09 09 20 3b .... #t)..... ;
1470: 3b 20 69 66 20 6a 6f 62 2d 67 72 6f 75 70 2d 6c ; if job-group-l
1480: 69 6d 69 74 20 69 73 20 73 65 74 20 61 6e 64 20 imit is set and
1490: 6e 75 6d 62 65 72 20 6f 66 20 6a 6f 62 73 20 69 number of jobs i
14a0: 6e 20 74 68 65 20 67 72 6f 75 70 20 69 73 20 67 n the group is g
14b0: 72 65 61 74 65 72 0a 09 09 09 09 20 3b 3b 20 74 reater..... ;; t
14c0: 68 61 6e 20 74 68 65 20 6c 69 6d 69 74 20 74 68 han the limit th
14d0: 65 6e 20 63 61 6e 6e 6f 74 20 72 75 6e 20 6d 6f en cannot run mo
14e0: 72 65 20 6a 6f 62 73 20 6f 66 20 74 68 69 73 20 re jobs of this
14f0: 6b 69 6e 64 0a 09 09 09 09 20 28 28 61 6e 64 20 kind..... ((and
1500: 6a 6f 62 2d 67 72 6f 75 70 2d 6c 69 6d 69 74 0a job-group-limit.
1510: 09 09 09 09 20 20 20 20 20 20 20 28 3e 3d 20 6e .... (>= n
1520: 75 6d 2d 72 75 6e 6e 69 6e 67 2d 69 6e 2d 6a 6f um-running-in-jo
1530: 62 67 72 6f 75 70 20 6a 6f 62 2d 67 72 6f 75 70 bgroup job-group
1540: 2d 6c 69 6d 69 74 29 29 0a 09 09 09 09 20 20 28 -limit))..... (
1550: 64 65 62 75 67 3a 70 72 69 6e 74 20 31 20 22 57 debug:print 1 "W
1560: 41 52 4e 49 4e 47 3a 20 6e 75 6d 62 65 72 20 6f ARNING: number o
1570: 66 20 6a 6f 62 73 20 22 20 6e 75 6d 2d 72 75 6e f jobs " num-run
1580: 6e 69 6e 67 2d 69 6e 2d 6a 6f 62 67 72 6f 75 70 ning-in-jobgroup
1590: 20 0a 09 09 09 09 09 20 20 20 20 20 20 20 22 20 ...... "
15a0: 69 6e 20 22 20 6a 6f 62 67 72 6f 75 70 20 22 20 in " jobgroup "
15b0: 65 78 63 65 65 64 65 64 2c 20 77 69 6c 6c 20 6e exceeded, will n
15c0: 6f 74 20 72 75 6e 20 22 20 28 74 65 73 74 73 3a ot run " (tests:
15d0: 74 65 73 74 71 75 65 75 65 2d 67 65 74 2d 74 65 testqueue-get-te
15e0: 73 74 6e 61 6d 65 20 74 65 73 74 2d 72 65 63 6f stname test-reco
15f0: 72 64 29 29 0a 09 09 09 09 20 20 23 74 29 0a 09 rd))..... #t)..
1600: 09 09 09 20 28 65 6c 73 65 20 23 66 29 29 29 29 ... (else #f))))
1610: 0a 09 20 20 28 6c 69 73 74 20 28 6e 6f 74 20 63 .. (list (not c
1620: 61 6e 2d 6e 6f 74 2d 72 75 6e 2d 6d 6f 72 65 29 an-not-run-more)
1630: 20 6e 75 6d 2d 72 75 6e 6e 69 6e 67 20 6e 75 6d num-running num
1640: 2d 72 75 6e 6e 69 6e 67 2d 69 6e 2d 6a 6f 62 67 -running-in-jobg
1650: 72 6f 75 70 20 6d 61 78 2d 63 6f 6e 63 75 72 72 roup max-concurr
1660: 65 6e 74 2d 6a 6f 62 73 20 6a 6f 62 2d 67 72 6f ent-jobs job-gro
1670: 75 70 2d 6c 69 6d 69 74 29 29 29 29 29 0a 0a 3b up-limit)))))..;
1680: 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;===============
1690: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
16a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
16b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
16c0: 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 4e 65 77 20 6d =======.;; New m
16d0: 65 74 68 6f 64 6f 6c 6f 67 79 2e 20 54 68 65 73 ethodology. Thes
16e0: 65 20 72 6f 75 74 69 6e 65 73 20 77 69 6c 6c 20 e routines will
16f0: 72 65 70 6c 61 63 65 20 74 68 65 20 61 62 6f 76 replace the abov
1700: 65 20 69 6e 20 74 69 6d 65 2e 20 46 6f 72 0a 3b e in time. For.;
1710: 3b 20 6e 6f 77 20 74 68 65 20 63 6f 64 65 20 69 ; now the code i
1720: 73 20 64 75 70 6c 69 63 61 74 65 64 2e 20 54 68 s duplicated. Th
1730: 69 73 20 73 74 75 66 66 20 69 73 20 69 6e 69 74 is stuff is init
1740: 69 61 6c 6c 79 20 75 73 65 64 20 69 6e 20 74 68 ially used in th
1750: 65 20 6d 6f 6e 69 74 6f 72 0a 3b 3b 20 62 61 73 e monitor.;; bas
1760: 65 64 20 63 6f 64 65 2e 0a 3b 3b 3d 3d 3d 3d 3d ed code..;;=====
1770: 3d 3d 3d 3d 3d 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 0a 0a 3b 3b 20 72 65 67 69 73 74 65 72 20 61 =..;; register a
17c0: 20 74 65 73 74 20 72 75 6e 20 77 69 74 68 20 74 test run with t
17d0: 68 65 20 64 62 0a 28 64 65 66 69 6e 65 20 28 72 he db.(define (r
17e0: 75 6e 73 3a 72 65 67 69 73 74 65 72 2d 72 75 6e uns:register-run
17f0: 20 64 62 20 6b 65 79 73 20 6b 65 79 76 61 6c 6c db keys keyvall
1800: 73 74 20 72 75 6e 6e 61 6d 65 20 73 74 61 74 65 st runname state
1810: 20 73 74 61 74 75 73 20 75 73 65 72 29 0a 20 20 status user).
1820: 28 64 65 62 75 67 3a 70 72 69 6e 74 20 33 20 22 (debug:print 3 "
1830: 72 75 6e 73 3a 72 65 67 69 73 74 65 72 2d 72 75 runs:register-ru
1840: 6e 2c 20 6b 65 79 73 3a 20 22 20 6b 65 79 73 20 n, keys: " keys
1850: 22 20 6b 65 79 76 61 6c 6c 73 74 3a 20 22 20 6b " keyvallst: " k
1860: 65 79 76 61 6c 6c 73 74 20 22 20 72 75 6e 6e 61 eyvallst " runna
1870: 6d 65 3a 20 22 20 72 75 6e 6e 61 6d 65 20 22 20 me: " runname "
1880: 73 74 61 74 65 3a 20 22 20 73 74 61 74 65 20 22 state: " state "
1890: 20 73 74 61 74 75 73 3a 20 22 20 73 74 61 74 75 status: " statu
18a0: 73 20 22 20 75 73 65 72 3a 20 22 20 75 73 65 72 s " user: " user
18b0: 29 0a 20 20 28 6c 65 74 2a 20 28 28 6b 65 79 73 ). (let* ((keys
18c0: 74 72 20 20 20 20 28 6b 65 79 73 2d 3e 6b 65 79 tr (keys->key
18d0: 73 74 72 20 6b 65 79 73 29 29 0a 09 20 28 63 6f str keys)).. (co
18e0: 6d 6d 61 20 20 20 20 20 28 69 66 20 28 3e 20 28 mma (if (> (
18f0: 6c 65 6e 67 74 68 20 6b 65 79 73 29 20 30 29 20 length keys) 0)
1900: 22 2c 22 20 22 22 29 29 0a 09 20 28 61 6e 64 73 "," "")).. (ands
1910: 74 72 20 20 20 20 28 69 66 20 28 3e 20 28 6c 65 tr (if (> (le
1920: 6e 67 74 68 20 6b 65 79 73 29 20 30 29 20 22 20 ngth keys) 0) "
1930: 41 4e 44 20 22 20 22 22 29 29 0a 09 20 28 76 61 AND " "")).. (va
1940: 6c 73 6c 6f 74 73 20 20 28 6b 65 79 73 2d 3e 76 lslots (keys->v
1950: 61 6c 73 6c 6f 74 73 20 6b 65 79 73 29 29 20 3b alslots keys)) ;
1960: 3b 20 3f 2c 3f 2c 3f 20 2e 2e 2e 0a 09 20 28 6b ; ?,?,? ..... (k
1970: 65 79 76 61 6c 73 20 20 20 28 6d 61 70 20 63 61 eyvals (map ca
1980: 64 72 20 6b 65 79 76 61 6c 6c 73 74 29 29 0a 09 dr keyvallst))..
1990: 20 28 61 6c 6c 76 61 6c 73 20 20 20 28 61 70 70 (allvals (app
19a0: 65 6e 64 20 28 6c 69 73 74 20 72 75 6e 6e 61 6d end (list runnam
19b0: 65 20 73 74 61 74 65 20 73 74 61 74 75 73 20 75 e state status u
19c0: 73 65 72 29 20 6b 65 79 76 61 6c 73 29 29 0a 09 ser) keyvals))..
19d0: 20 28 71 72 79 76 61 6c 73 20 20 20 28 61 70 70 (qryvals (app
19e0: 65 6e 64 20 28 6c 69 73 74 20 72 75 6e 6e 61 6d end (list runnam
19f0: 65 29 20 6b 65 79 76 61 6c 73 29 29 0a 09 20 28 e) keyvals)).. (
1a00: 6b 65 79 3d 3f 73 74 72 20 20 28 73 74 72 69 6e key=?str (strin
1a10: 67 2d 69 6e 74 65 72 73 70 65 72 73 65 20 28 6d g-intersperse (m
1a20: 61 70 20 28 6c 61 6d 62 64 61 20 28 6b 29 28 63 ap (lambda (k)(c
1a30: 6f 6e 63 20 28 6b 65 79 3a 67 65 74 2d 66 69 65 onc (key:get-fie
1a40: 6c 64 6e 61 6d 65 20 6b 29 20 22 3d 3f 22 29 29 ldname k) "=?"))
1a50: 20 6b 65 79 73 29 20 22 20 41 4e 44 20 22 29 29 keys) " AND "))
1a60: 29 0a 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 ). (debug:pri
1a70: 6e 74 20 33 20 22 6b 65 79 73 3a 20 22 20 6b 65 nt 3 "keys: " ke
1a80: 79 73 20 22 20 61 6c 6c 76 61 6c 73 3a 20 22 20 ys " allvals: "
1a90: 61 6c 6c 76 61 6c 73 20 22 20 6b 65 79 76 61 6c allvals " keyval
1aa0: 73 3a 20 22 20 6b 65 79 76 61 6c 73 29 0a 20 20 s: " keyvals).
1ab0: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 32 (debug:print 2
1ac0: 20 22 4e 4f 54 45 3a 20 75 73 69 6e 67 20 74 61 "NOTE: using ta
1ad0: 72 67 65 74 20 22 20 28 73 74 72 69 6e 67 2d 69 rget " (string-i
1ae0: 6e 74 65 72 73 70 65 72 73 65 20 6b 65 79 76 61 ntersperse keyva
1af0: 6c 73 20 22 2f 22 29 20 22 20 66 6f 72 20 74 68 ls "/") " for th
1b00: 69 73 20 72 75 6e 22 29 0a 20 20 20 20 28 69 66 is run"). (if
1b10: 20 28 61 6e 64 20 72 75 6e 6e 61 6d 65 20 28 6e (and runname (n
1b20: 75 6c 6c 3f 20 28 66 69 6c 74 65 72 20 28 6c 61 ull? (filter (la
1b30: 6d 62 64 61 20 28 78 29 28 6e 6f 74 20 78 29 29 mbda (x)(not x))
1b40: 20 6b 65 79 76 61 6c 73 29 29 29 20 3b 3b 20 74 keyvals))) ;; t
1b50: 68 65 72 65 20 6d 75 73 74 20 62 65 20 61 20 62 here must be a b
1b60: 65 74 74 65 72 20 77 61 79 20 74 6f 20 22 61 70 etter way to "ap
1b70: 70 6c 79 20 61 6e 64 22 0a 09 28 6c 65 74 20 28 ply and"..(let (
1b80: 28 72 65 73 20 23 66 29 29 0a 09 20 20 28 61 70 (res #f)).. (ap
1b90: 70 6c 79 20 73 71 6c 69 74 65 33 3a 65 78 65 63 ply sqlite3:exec
1ba0: 75 74 65 20 64 62 20 28 63 6f 6e 63 20 22 49 4e ute db (conc "IN
1bb0: 53 45 52 54 20 4f 52 20 49 47 4e 4f 52 45 20 49 SERT OR IGNORE I
1bc0: 4e 54 4f 20 72 75 6e 73 20 28 72 75 6e 6e 61 6d NTO runs (runnam
1bd0: 65 2c 73 74 61 74 65 2c 73 74 61 74 75 73 2c 6f e,state,status,o
1be0: 77 6e 65 72 2c 65 76 65 6e 74 5f 74 69 6d 65 22 wner,event_time"
1bf0: 20 63 6f 6d 6d 61 20 6b 65 79 73 74 72 20 22 29 comma keystr ")
1c00: 20 56 41 4c 55 45 53 20 28 3f 2c 3f 2c 3f 2c 3f VALUES (?,?,?,?
1c10: 2c 73 74 72 66 74 69 6d 65 28 27 25 73 27 2c 27 ,strftime('%s','
1c20: 6e 6f 77 27 29 22 20 63 6f 6d 6d 61 20 76 61 6c now')" comma val
1c30: 73 6c 6f 74 73 20 22 29 3b 22 29 0a 09 09 20 61 slots ");")... a
1c40: 6c 6c 76 61 6c 73 29 0a 09 20 20 28 61 70 70 6c llvals).. (appl
1c50: 79 20 73 71 6c 69 74 65 33 3a 66 6f 72 2d 65 61 y sqlite3:for-ea
1c60: 63 68 2d 72 6f 77 20 0a 09 20 20 20 28 6c 61 6d ch-row .. (lam
1c70: 62 64 61 20 28 69 64 29 0a 09 20 20 20 20 20 28 bda (id).. (
1c80: 73 65 74 21 20 72 65 73 20 69 64 29 29 0a 09 20 set! res id))..
1c90: 20 20 64 62 0a 09 20 20 20 28 6c 65 74 20 28 28 db.. (let ((
1ca0: 71 72 79 20 28 63 6f 6e 63 20 22 53 45 4c 45 43 qry (conc "SELEC
1cb0: 54 20 69 64 20 46 52 4f 4d 20 72 75 6e 73 20 57 T id FROM runs W
1cc0: 48 45 52 45 20 28 72 75 6e 6e 61 6d 65 3d 3f 20 HERE (runname=?
1cd0: 22 20 61 6e 64 73 74 72 20 6b 65 79 3d 3f 73 74 " andstr key=?st
1ce0: 72 20 22 29 3b 22 29 29 29 0a 09 20 20 20 20 20 r ");")))..
1cf0: 3b 28 64 65 62 75 67 3a 70 72 69 6e 74 20 34 20 ;(debug:print 4
1d00: 22 71 72 79 3a 20 22 20 71 72 79 29 20 0a 09 20 "qry: " qry) ..
1d10: 20 20 20 20 71 72 79 29 0a 09 20 20 20 71 72 79 qry).. qry
1d20: 76 61 6c 73 29 0a 09 20 20 28 73 71 6c 69 74 65 vals).. (sqlite
1d30: 33 3a 65 78 65 63 75 74 65 20 64 62 20 22 55 50 3:execute db "UP
1d40: 44 41 54 45 20 72 75 6e 73 20 53 45 54 20 73 74 DATE runs SET st
1d50: 61 74 65 3d 3f 2c 73 74 61 74 75 73 3d 3f 20 57 ate=?,status=? W
1d60: 48 45 52 45 20 69 64 3d 3f 3b 22 20 73 74 61 74 HERE id=?;" stat
1d70: 65 20 73 74 61 74 75 73 20 72 65 73 29 0a 09 20 e status res)..
1d80: 20 72 65 73 29 20 0a 09 28 62 65 67 69 6e 0a 09 res) ..(begin..
1d90: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 (debug:print 0
1da0: 20 22 45 52 52 4f 52 3a 20 43 61 6c 6c 65 64 20 "ERROR: Called
1db0: 77 69 74 68 6f 75 74 20 61 6c 6c 20 6e 65 63 65 without all nece
1dc0: 73 73 61 72 79 20 6b 65 79 73 22 29 0a 09 20 20 ssary keys")..
1dd0: 23 66 29 29 29 29 0a 0a 3b 3b 20 54 68 69 73 20 #f))))..;; This
1de0: 69 73 20 61 20 64 75 70 6c 69 63 61 74 65 20 6f is a duplicate o
1df0: 66 20 72 75 6e 2d 74 65 73 74 73 20 28 77 68 69 f run-tests (whi
1e00: 63 68 20 68 61 73 20 62 65 65 6e 20 64 65 70 72 ch has been depr
1e10: 65 63 61 74 65 64 29 2e 20 55 73 65 20 74 68 69 ecated). Use thi
1e20: 73 20 6f 6e 65 20 69 6e 73 74 65 61 64 20 6f 66 s one instead of
1e30: 20 72 75 6e 20 74 65 73 74 73 2e 0a 3b 3b 20 6b run tests..;; k
1e40: 65 79 76 61 6c 73 0a 28 64 65 66 69 6e 65 20 28 eyvals.(define (
1e50: 72 75 6e 73 3a 72 75 6e 2d 74 65 73 74 73 20 74 runs:run-tests t
1e60: 61 72 67 65 74 20 72 75 6e 6e 61 6d 65 20 74 65 arget runname te
1e70: 73 74 2d 70 61 74 74 73 20 75 73 65 72 20 66 6c st-patts user fl
1e80: 61 67 73 29 0a 20 20 28 6c 65 74 2a 20 28 28 64 ags). (let* ((d
1e90: 62 20 20 20 20 20 20 20 20 20 20 23 66 29 0a 09 b #f)..
1ea0: 20 28 6b 65 79 73 20 20 20 20 20 20 20 20 28 6f (keys (o
1eb0: 70 65 6e 2d 72 75 6e 2d 63 6c 6f 73 65 20 64 62 pen-run-close db
1ec0: 3a 67 65 74 2d 6b 65 79 73 20 64 62 29 29 0a 09 :get-keys db))..
1ed0: 20 28 6b 65 79 76 61 6c 6c 73 74 20 20 20 28 6b (keyvallst (k
1ee0: 65 79 73 3a 74 61 72 67 65 74 2d 3e 6b 65 79 76 eys:target->keyv
1ef0: 61 6c 20 6b 65 79 73 20 74 61 72 67 65 74 29 29 al keys target))
1f00: 0a 09 20 28 72 75 6e 2d 69 64 20 20 20 20 20 20 .. (run-id
1f10: 28 6f 70 65 6e 2d 72 75 6e 2d 63 6c 6f 73 65 20 (open-run-close
1f20: 72 75 6e 73 3a 72 65 67 69 73 74 65 72 2d 72 75 runs:register-ru
1f30: 6e 20 64 62 20 6b 65 79 73 20 6b 65 79 76 61 6c n db keys keyval
1f40: 6c 73 74 20 72 75 6e 6e 61 6d 65 20 22 6e 65 77 lst runname "new
1f50: 22 20 22 6e 2f 61 22 20 75 73 65 72 29 29 20 20 " "n/a" user))
1f60: 3b 3b 20 20 74 65 73 74 2d 6e 61 6d 65 29 29 29 ;; test-name)))
1f70: 0a 09 20 28 64 65 66 65 72 72 65 64 20 20 20 20 .. (deferred
1f80: 27 28 29 29 20 3b 3b 20 64 65 6c 61 79 20 72 75 '()) ;; delay ru
1f90: 6e 6e 69 6e 67 20 74 68 65 73 65 20 73 69 6e 63 nning these sinc
1fa0: 65 20 74 68 65 79 20 68 61 76 65 20 61 20 77 61 e they have a wa
1fb0: 69 74 6f 6e 20 63 6c 61 75 73 65 0a 09 20 3b 3b iton clause.. ;;
1fc0: 20 6b 65 65 70 67 6f 69 6e 67 20 69 73 20 74 68 keepgoing is th
1fd0: 65 20 64 65 66 61 63 74 6f 20 6d 6f 64 61 6c 69 e defacto modali
1fe0: 74 79 20 6e 6f 77 2c 20 77 69 6c 6c 20 61 64 64 ty now, will add
1ff0: 20 68 69 74 2d 6e 2d 72 75 6e 20 61 20 62 69 74 hit-n-run a bit
2000: 20 6c 61 74 65 72 0a 09 20 3b 3b 20 28 6b 65 65 later.. ;; (kee
2010: 70 67 6f 69 6e 67 20 20 20 28 68 61 73 68 2d 74 pgoing (hash-t
2020: 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 able-ref/default
2030: 20 66 6c 61 67 73 20 22 2d 6b 65 65 70 67 6f 69 flags "-keepgoi
2040: 6e 67 22 20 23 66 29 29 0a 09 20 28 74 65 73 74 ng" #f)).. (test
2050: 2d 6e 61 6d 65 73 20 20 27 28 29 29 0a 09 20 28 -names '()).. (
2060: 72 75 6e 63 6f 6e 66 69 67 66 20 20 20 28 63 6f runconfigf (co
2070: 6e 63 20 20 2a 74 6f 70 70 61 74 68 2a 20 22 2f nc *toppath* "/
2080: 72 75 6e 63 6f 6e 66 69 67 73 2e 63 6f 6e 66 69 runconfigs.confi
2090: 67 22 29 29 0a 09 20 28 72 65 71 75 69 72 65 64 g")).. (required
20a0: 2d 74 65 73 74 73 20 27 28 29 29 0a 09 20 28 74 -tests '()).. (t
20b0: 65 73 74 2d 72 65 63 6f 72 64 73 20 28 6d 61 6b est-records (mak
20c0: 65 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 29 0a e-hash-table))).
20d0: 0a 20 20 20 20 28 6f 70 65 6e 2d 72 75 6e 2d 63 . (open-run-c
20e0: 6c 6f 73 65 20 73 65 74 2d 6d 65 67 61 74 65 73 lose set-megates
20f0: 74 2d 65 6e 76 2d 76 61 72 73 20 64 62 20 72 75 t-env-vars db ru
2100: 6e 2d 69 64 29 20 3b 3b 20 74 68 65 73 65 20 6d n-id) ;; these m
2110: 61 79 20 62 65 20 6e 65 65 64 65 64 20 62 79 20 ay be needed by
2120: 74 68 65 20 6c 61 75 6e 63 68 69 6e 67 20 70 72 the launching pr
2130: 6f 63 65 73 73 0a 0a 20 20 20 20 28 69 66 20 28 ocess.. (if (
2140: 66 69 6c 65 2d 65 78 69 73 74 73 3f 20 72 75 6e file-exists? run
2150: 63 6f 6e 66 69 67 66 29 0a 09 28 6f 70 65 6e 2d configf)..(open-
2160: 72 75 6e 2d 63 6c 6f 73 65 20 73 65 74 75 70 2d run-close setup-
2170: 65 6e 76 2d 64 65 66 61 75 6c 74 73 20 64 62 20 env-defaults db
2180: 72 75 6e 63 6f 6e 66 69 67 66 20 72 75 6e 2d 69 runconfigf run-i
2190: 64 20 2a 61 6c 72 65 61 64 79 2d 73 65 65 6e 2d d *already-seen-
21a0: 72 75 6e 63 6f 6e 66 69 67 2d 69 6e 66 6f 2a 20 runconfig-info*
21b0: 22 70 72 65 2d 6c 61 75 6e 63 68 2d 65 6e 76 2d "pre-launch-env-
21c0: 76 61 72 73 22 29 0a 09 28 64 65 62 75 67 3a 70 vars")..(debug:p
21d0: 72 69 6e 74 20 30 20 22 57 41 52 4e 49 4e 47 3a rint 0 "WARNING:
21e0: 20 59 6f 75 20 64 6f 20 6e 6f 74 20 68 61 76 65 You do not have
21f0: 20 61 20 72 75 6e 20 63 6f 6e 66 69 67 20 66 69 a run config fi
2200: 6c 65 3a 20 22 20 72 75 6e 63 6f 6e 66 69 67 66 le: " runconfigf
2210: 29 29 0a 20 20 20 20 0a 20 20 20 20 3b 3b 20 6c )). . ;; l
2220: 6f 6f 6b 20 75 70 20 61 6c 6c 20 74 65 73 74 73 ook up all tests
2230: 20 6d 61 74 63 68 69 6e 67 20 74 68 65 20 63 6f matching the co
2240: 6d 6d 61 20 73 65 70 61 72 61 74 65 64 20 6c 69 mma separated li
2250: 73 74 20 6f 66 20 67 6c 6f 62 73 20 69 6e 0a 20 st of globs in.
2260: 20 20 20 3b 3b 20 74 65 73 74 2d 70 61 74 74 73 ;; test-patts
2270: 20 28 75 73 69 6e 67 20 25 20 61 73 20 77 69 6c (using % as wil
2280: 64 63 61 72 64 29 0a 20 20 20 20 28 66 6f 72 2d dcard). (for-
2290: 65 61 63 68 20 0a 20 20 20 20 20 28 6c 61 6d 62 each . (lamb
22a0: 64 61 20 28 70 61 74 74 29 0a 20 20 20 20 20 20 da (patt).
22b0: 20 28 6c 65 74 20 28 28 74 65 73 74 73 20 28 67 (let ((tests (g
22c0: 6c 6f 62 20 28 63 6f 6e 63 20 2a 74 6f 70 70 61 lob (conc *toppa
22d0: 74 68 2a 20 22 2f 74 65 73 74 73 2f 22 20 28 73 th* "/tests/" (s
22e0: 74 72 69 6e 67 2d 74 72 61 6e 73 6c 61 74 65 20 tring-translate
22f0: 70 61 74 74 20 22 25 22 20 22 2a 22 29 29 29 29 patt "%" "*"))))
2300: 29 0a 09 20 28 73 65 74 21 20 74 65 73 74 73 20 ).. (set! tests
2310: 28 66 69 6c 74 65 72 20 28 6c 61 6d 62 64 61 20 (filter (lambda
2320: 28 74 65 73 74 29 28 66 69 6c 65 2d 65 78 69 73 (test)(file-exis
2330: 74 73 3f 20 28 63 6f 6e 63 20 74 65 73 74 20 22 ts? (conc test "
2340: 2f 74 65 73 74 63 6f 6e 66 69 67 22 29 29 29 20 /testconfig")))
2350: 74 65 73 74 73 29 29 0a 09 20 28 73 65 74 21 20 tests)).. (set!
2360: 74 65 73 74 2d 6e 61 6d 65 73 20 28 61 70 70 65 test-names (appe
2370: 6e 64 20 74 65 73 74 2d 6e 61 6d 65 73 20 0a 09 nd test-names ..
2380: 09 09 09 20 20 28 6d 61 70 20 28 6c 61 6d 62 64 ... (map (lambd
2390: 61 20 28 74 65 73 74 70 29 0a 09 09 09 09 09 20 a (testp)......
23a0: 28 6c 61 73 74 20 28 73 74 72 69 6e 67 2d 73 70 (last (string-sp
23b0: 6c 69 74 20 74 65 73 74 70 20 22 2f 22 29 29 29 lit testp "/")))
23c0: 0a 09 09 09 09 20 20 20 20 20 20 20 74 65 73 74 ..... test
23d0: 73 29 29 29 29 29 0a 20 20 20 20 20 28 69 66 20 s))))). (if
23e0: 74 65 73 74 2d 70 61 74 74 73 20 28 73 74 72 69 test-patts (stri
23f0: 6e 67 2d 73 70 6c 69 74 20 74 65 73 74 2d 70 61 ng-split test-pa
2400: 74 74 73 20 22 2c 22 29 28 6c 69 73 74 20 22 25 tts ",")(list "%
2410: 22 29 29 29 0a 0a 20 20 20 20 20 3b 3b 20 6e 6f "))).. ;; no
2420: 77 20 72 65 6d 6f 76 65 20 64 75 70 6c 69 63 61 w remove duplica
2430: 74 65 73 0a 20 20 20 20 28 73 65 74 21 20 74 65 tes. (set! te
2440: 73 74 2d 6e 61 6d 65 73 20 28 64 65 6c 65 74 65 st-names (delete
2450: 2d 64 75 70 6c 69 63 61 74 65 73 20 74 65 73 74 -duplicates test
2460: 2d 6e 61 6d 65 73 29 29 0a 0a 20 20 20 20 28 64 -names)).. (d
2470: 65 62 75 67 3a 70 72 69 6e 74 20 30 20 22 49 4e ebug:print 0 "IN
2480: 46 4f 3a 20 74 65 73 74 20 6e 61 6d 65 73 20 22 FO: test names "
2490: 20 74 65 73 74 2d 6e 61 6d 65 73 29 0a 0a 20 20 test-names)..
24a0: 20 20 3b 3b 20 6f 6e 20 74 68 65 20 66 69 72 73 ;; on the firs
24b0: 74 20 70 61 73 73 20 6f 72 20 63 61 6c 6c 20 74 t pass or call t
24c0: 6f 20 72 75 6e 2d 74 65 73 74 73 20 73 65 74 20 o run-tests set
24d0: 46 41 49 4c 53 20 74 6f 20 4e 4f 54 5f 53 54 41 FAILS to NOT_STA
24e0: 52 54 45 44 20 69 66 0a 20 20 20 20 3b 3b 20 2d RTED if. ;; -
24f0: 6b 65 65 70 67 6f 69 6e 67 20 69 73 20 73 70 65 keepgoing is spe
2500: 63 69 66 69 65 64 0a 20 20 20 20 28 69 66 20 28 cified. (if (
2510: 65 71 3f 20 2a 70 61 73 73 6e 75 6d 2a 20 30 29 eq? *passnum* 0)
2520: 0a 09 28 62 65 67 69 6e 0a 09 20 20 3b 3b 20 68 ..(begin.. ;; h
2530: 61 76 65 20 74 6f 20 64 65 6c 65 74 65 20 74 65 ave to delete te
2540: 73 74 20 72 65 63 6f 72 64 73 20 77 68 65 72 65 st records where
2550: 20 4e 4f 54 5f 53 54 41 52 54 45 44 20 73 69 6e NOT_STARTED sin
2560: 63 65 20 74 68 65 79 20 63 61 6e 20 63 61 75 73 ce they can caus
2570: 65 20 2d 6b 65 65 70 67 6f 69 6e 67 20 74 6f 20 e -keepgoing to
2580: 0a 09 20 20 3b 3b 20 67 65 74 20 73 74 75 63 6b .. ;; get stuck
2590: 20 64 75 65 20 74 6f 20 62 65 63 6f 6d 69 6e 67 due to becoming
25a0: 20 69 6e 61 63 63 65 73 73 69 62 6c 65 20 66 72 inaccessible fr
25b0: 6f 6d 20 61 20 66 61 69 6c 65 64 20 74 65 73 74 om a failed test
25c0: 2e 20 49 2e 65 2e 20 69 66 20 74 65 73 74 20 42 . I.e. if test B
25d0: 20 64 65 70 65 6e 64 73 20 0a 09 20 20 3b 3b 20 depends .. ;;
25e0: 6f 6e 20 74 65 73 74 20 41 20 62 75 74 20 74 65 on test A but te
25f0: 73 74 20 42 20 72 65 61 63 68 65 64 20 74 68 65 st B reached the
2600: 20 70 6f 69 6e 74 20 6f 6e 20 62 65 69 6e 67 20 point on being
2610: 72 65 67 69 73 74 65 72 65 64 20 61 73 20 4e 4f registered as NO
2620: 54 5f 53 54 41 52 54 45 44 20 61 6e 64 20 74 65 T_STARTED and te
2630: 73 74 0a 09 20 20 3b 3b 20 41 20 66 61 69 6c 65 st.. ;; A faile
2640: 64 20 66 6f 72 20 73 6f 6d 65 20 72 65 61 73 6f d for some reaso
2650: 6e 20 74 68 65 6e 20 6f 6e 20 72 65 2d 72 75 6e n then on re-run
2660: 20 75 73 69 6e 67 20 2d 6b 65 65 70 67 6f 69 6e using -keepgoin
2670: 67 20 74 68 65 20 72 75 6e 20 63 61 6e 20 6e 65 g the run can ne
2680: 76 65 72 20 63 6f 6d 70 6c 65 74 65 2e 0a 09 20 ver complete...
2690: 20 28 6f 70 65 6e 2d 72 75 6e 2d 63 6c 6f 73 65 (open-run-close
26a0: 20 64 62 3a 64 65 6c 65 74 65 2d 74 65 73 74 73 db:delete-tests
26b0: 2d 69 6e 2d 73 74 61 74 65 20 64 62 20 72 75 6e -in-state db run
26c0: 2d 69 64 20 22 4e 4f 54 5f 53 54 41 52 54 45 44 -id "NOT_STARTED
26d0: 22 29 0a 09 20 20 28 6f 70 65 6e 2d 72 75 6e 2d ").. (open-run-
26e0: 63 6c 6f 73 65 20 64 62 3a 73 65 74 2d 74 65 73 close db:set-tes
26f0: 74 73 2d 73 74 61 74 65 2d 73 74 61 74 75 73 20 ts-state-status
2700: 64 62 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 6e db run-id test-n
2710: 61 6d 65 73 20 23 66 20 22 46 41 49 4c 22 20 22 ames #f "FAIL" "
2720: 4e 4f 54 5f 53 54 41 52 54 45 44 22 20 22 46 41 NOT_STARTED" "FA
2730: 49 4c 22 29 29 29 0a 0a 20 20 20 20 3b 3b 20 66 IL"))).. ;; f
2740: 72 6f 6d 20 68 65 72 65 20 6f 6e 20 6f 75 74 20 rom here on out
2750: 74 68 65 20 64 62 20 77 69 6c 6c 20 62 65 20 6f the db will be o
2760: 70 65 6e 65 64 20 61 6e 64 20 63 6c 6f 73 65 64 pened and closed
2770: 20 6f 6e 20 65 76 65 72 79 20 63 61 6c 6c 20 72 on every call r
2780: 75 6e 73 3a 72 75 6e 2d 74 65 73 74 73 2d 71 75 uns:run-tests-qu
2790: 65 75 65 0a 20 20 20 20 3b 3b 20 28 73 71 6c 69 eue. ;; (sqli
27a0: 74 65 33 3a 66 69 6e 61 6c 69 7a 65 21 20 64 62 te3:finalize! db
27b0: 29 20 0a 20 20 20 20 3b 3b 20 6e 6f 77 20 61 64 ) . ;; now ad
27c0: 64 20 6e 6f 6e 2d 64 69 72 65 63 74 6c 79 20 72 d non-directly r
27d0: 65 66 65 72 65 6e 63 65 64 20 64 65 70 65 6e 64 eferenced depend
27e0: 65 6e 63 69 65 73 20 28 69 2e 65 2e 20 77 61 69 encies (i.e. wai
27f0: 74 6f 6e 29 0a 20 20 20 20 28 69 66 20 28 6e 6f ton). (if (no
2800: 74 20 28 6e 75 6c 6c 3f 20 74 65 73 74 2d 6e 61 t (null? test-na
2810: 6d 65 73 29 29 0a 09 28 6c 65 74 20 6c 6f 6f 70 mes))..(let loop
2820: 20 28 28 68 65 64 20 28 63 61 72 20 74 65 73 74 ((hed (car test
2830: 2d 6e 61 6d 65 73 29 29 0a 09 09 20 20 20 28 74 -names))... (t
2840: 61 6c 20 28 63 64 72 20 74 65 73 74 2d 6e 61 6d al (cdr test-nam
2850: 65 73 29 29 29 20 20 20 20 20 20 20 20 20 3b 3b es))) ;;
2860: 20 27 72 65 74 75 72 6e 2d 70 72 6f 63 73 20 74 'return-procs t
2870: 65 6c 6c 73 20 74 68 65 20 63 6f 6e 66 69 67 20 ells the config
2880: 72 65 61 64 65 72 20 74 6f 20 70 72 65 70 20 72 reader to prep r
2890: 75 6e 6e 69 6e 67 20 73 79 73 74 65 6d 20 62 75 unning system bu
28a0: 74 20 72 65 74 75 72 6e 20 61 20 70 72 6f 63 0a t return a proc.
28b0: 09 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 . (debug:print
28c0: 34 20 22 49 4e 46 4f 3a 20 68 65 64 3d 22 20 68 4 "INFO: hed=" h
28d0: 65 64 20 22 20 61 74 20 74 6f 70 20 6f 66 20 6c ed " at top of l
28e0: 6f 6f 70 22 29 0a 09 20 20 28 6c 65 74 2a 20 28 oop").. (let* (
28f0: 28 63 6f 6e 66 69 67 20 20 28 74 65 73 74 73 3a (config (tests:
2900: 67 65 74 2d 74 65 73 74 63 6f 6e 66 69 67 20 68 get-testconfig h
2910: 65 64 20 27 72 65 74 75 72 6e 2d 70 72 6f 63 73 ed 'return-procs
2920: 29 29 0a 09 09 20 28 77 61 69 74 6f 6e 73 20 28 ))... (waitons (
2930: 69 66 20 63 6f 6e 66 69 67 20 28 73 74 72 69 6e if config (strin
2940: 67 2d 73 70 6c 69 74 20 28 6c 65 74 20 28 28 77 g-split (let ((w
2950: 20 28 63 6f 6e 66 69 67 2d 6c 6f 6f 6b 75 70 20 (config-lookup
2960: 63 6f 6e 66 69 67 20 22 72 65 71 75 69 72 65 6d config "requirem
2970: 65 6e 74 73 22 20 22 77 61 69 74 6f 6e 22 29 29 ents" "waiton"))
2980: 29 0a 09 09 09 09 09 09 20 20 20 20 20 28 69 66 )....... (if
2990: 20 77 20 77 20 22 22 29 29 29 0a 09 09 09 20 20 w w "")))....
29a0: 20 20 20 20 28 62 65 67 69 6e 0a 09 09 09 09 28 (begin.....(
29b0: 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 22 45 debug:print 0 "E
29c0: 52 52 4f 52 3a 20 6e 6f 6e 2d 65 78 69 73 74 65 RROR: non-existe
29d0: 6e 74 20 72 65 71 75 69 72 65 64 20 74 65 73 74 nt required test
29e0: 20 5c 22 22 20 68 65 64 20 22 5c 22 22 29 0a 20 \"" hed "\"").
29f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2a00: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
2a10: 69 66 20 64 62 20 28 73 71 6c 69 74 65 33 3a 66 if db (sqlite3:f
2a20: 69 6e 61 6c 69 7a 65 21 20 64 62 29 29 0a 09 09 inalize! db))...
2a30: 09 09 28 65 78 69 74 20 31 29 29 29 29 29 0a 09 ..(exit 1)))))..
2a40: 20 20 20 20 3b 3b 20 63 68 65 63 6b 20 66 6f 72 ;; check for
2a50: 20 68 65 64 20 69 6e 20 77 61 69 74 6f 6e 73 20 hed in waitons
2a60: 3d 3e 20 74 68 69 73 20 77 6f 75 6c 64 20 62 65 => this would be
2a70: 20 63 69 72 63 75 6c 61 72 2c 20 72 65 6d 6f 76 circular, remov
2a80: 65 20 69 74 20 61 6e 64 20 69 73 73 75 65 20 61 e it and issue a
2a90: 6e 0a 09 20 20 20 20 3b 3b 20 65 72 72 6f 72 0a n.. ;; error.
2aa0: 09 20 20 20 20 28 69 66 20 28 6d 65 6d 62 65 72 . (if (member
2ab0: 20 68 65 64 20 77 61 69 74 6f 6e 73 29 0a 09 09 hed waitons)...
2ac0: 28 62 65 67 69 6e 0a 09 09 20 20 28 64 65 62 75 (begin... (debu
2ad0: 67 3a 70 72 69 6e 74 20 30 20 22 45 52 52 4f 52 g:print 0 "ERROR
2ae0: 3a 20 74 65 73 74 20 22 20 68 65 64 20 22 20 68 : test " hed " h
2af0: 61 73 20 6c 69 73 74 65 64 20 69 74 73 65 6c 66 as listed itself
2b00: 20 61 73 20 61 20 77 61 69 74 6f 6e 2c 20 70 6c as a waiton, pl
2b10: 65 61 73 65 20 63 6f 72 72 65 63 74 20 74 68 69 ease correct thi
2b20: 73 21 22 29 0a 09 09 20 20 28 73 65 74 21 20 77 s!")... (set! w
2b30: 61 69 74 6f 6e 73 20 28 66 69 6c 74 65 72 20 28 aitons (filter (
2b40: 6c 61 6d 62 64 61 20 28 78 29 28 6e 6f 74 20 28 lambda (x)(not (
2b50: 65 71 75 61 6c 3f 20 78 20 68 65 64 29 29 29 20 equal? x hed)))
2b60: 77 61 69 74 6f 6e 73 29 29 29 29 0a 09 20 20 20 waitons))))..
2b70: 20 0a 09 20 20 20 20 3b 3b 20 28 69 74 65 6d 73 .. ;; (items
2b80: 20 20 20 28 69 74 65 6d 73 3a 67 65 74 2d 69 74 (items:get-it
2b90: 65 6d 73 2d 66 72 6f 6d 2d 63 6f 6e 66 69 67 20 ems-from-config
2ba0: 63 6f 6e 66 69 67 29 29 29 0a 09 20 20 20 20 28 config))).. (
2bb0: 69 66 20 28 6e 6f 74 20 28 68 61 73 68 2d 74 61 if (not (hash-ta
2bc0: 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 ble-ref/default
2bd0: 74 65 73 74 2d 72 65 63 6f 72 64 73 20 68 65 64 test-records hed
2be0: 20 23 66 29 29 0a 09 09 28 68 61 73 68 2d 74 61 #f))...(hash-ta
2bf0: 62 6c 65 2d 73 65 74 21 20 74 65 73 74 2d 72 65 ble-set! test-re
2c00: 63 6f 72 64 73 0a 09 09 09 09 20 68 65 64 20 28 cords..... hed (
2c10: 76 65 63 74 6f 72 20 68 65 64 20 20 20 20 20 3b vector hed ;
2c20: 3b 20 30 0a 09 09 09 09 09 20 20 20 20 20 63 6f ; 0...... co
2c30: 6e 66 69 67 20 20 3b 3b 20 31 0a 09 09 09 09 09 nfig ;; 1......
2c40: 20 20 20 20 20 77 61 69 74 6f 6e 73 20 3b 3b 20 waitons ;;
2c50: 32 0a 09 09 09 09 09 20 20 20 20 20 28 63 6f 6e 2...... (con
2c60: 66 69 67 2d 6c 6f 6f 6b 75 70 20 63 6f 6e 66 69 fig-lookup confi
2c70: 67 20 22 72 65 71 75 69 72 65 6d 65 6e 74 73 22 g "requirements"
2c80: 20 22 70 72 69 6f 72 69 74 79 22 29 20 20 20 20 "priority")
2c90: 20 3b 3b 20 70 72 69 6f 72 69 74 79 20 33 0a 09 ;; priority 3..
2ca0: 09 09 09 09 20 20 20 20 20 28 6c 65 74 20 28 28 .... (let ((
2cb0: 69 74 65 6d 73 20 20 20 20 20 20 28 68 61 73 68 items (hash
2cc0: 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 -table-ref/defau
2cd0: 6c 74 20 63 6f 6e 66 69 67 20 22 69 74 65 6d 73 lt config "items
2ce0: 22 20 23 66 29 29 20 3b 3b 20 69 74 65 6d 73 20 " #f)) ;; items
2cf0: 34 0a 09 09 09 09 09 09 20 20 20 28 69 74 65 6d 4....... (item
2d00: 73 74 61 62 6c 65 20 28 68 61 73 68 2d 74 61 62 stable (hash-tab
2d10: 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 63 le-ref/default c
2d20: 6f 6e 66 69 67 20 22 69 74 65 6d 73 74 61 62 6c onfig "itemstabl
2d30: 65 22 20 23 66 29 29 29 20 0a 09 09 09 09 09 20 e" #f))) ......
2d40: 20 20 20 20 20 20 3b 3b 20 69 66 20 65 69 74 68 ;; if eith
2d50: 65 72 20 69 74 65 6d 73 20 6f 72 20 69 74 65 6d er items or item
2d60: 73 20 74 61 62 6c 65 20 69 73 20 61 20 70 72 6f s table is a pro
2d70: 63 20 72 65 74 75 72 6e 20 69 74 20 73 6f 20 74 c return it so t
2d80: 65 73 74 20 72 75 6e 6e 69 6e 67 0a 09 09 09 09 est running.....
2d90: 09 20 20 20 20 20 20 20 3b 3b 20 70 72 6f 63 65 . ;; proce
2da0: 73 73 20 63 61 6e 20 6b 6e 6f 77 20 74 6f 20 63 ss can know to c
2db0: 61 6c 6c 20 69 74 65 6d 73 3a 67 65 74 2d 69 74 all items:get-it
2dc0: 65 6d 73 2d 66 72 6f 6d 2d 63 6f 6e 66 69 67 0a ems-from-config.
2dd0: 09 09 09 09 09 20 20 20 20 20 20 20 3b 3b 20 69 ..... ;; i
2de0: 66 20 65 69 74 68 65 72 20 69 73 20 61 20 6c 69 f either is a li
2df0: 73 74 20 61 6e 64 20 6e 6f 6e 65 20 69 73 20 61 st and none is a
2e00: 20 70 72 6f 63 20 67 6f 20 61 68 65 61 64 20 61 proc go ahead a
2e10: 6e 64 20 63 61 6c 6c 20 67 65 74 2d 69 74 65 6d nd call get-item
2e20: 73 0a 09 09 09 09 09 20 20 20 20 20 20 20 3b 3b s...... ;;
2e30: 20 6f 74 68 65 72 77 69 73 65 20 72 65 74 75 72 otherwise retur
2e40: 6e 20 23 66 20 2d 20 74 68 69 73 20 69 73 20 6e n #f - this is n
2e50: 6f 74 20 61 6e 20 69 74 65 72 61 74 65 64 20 74 ot an iterated t
2e60: 65 73 74 0a 09 09 09 09 09 20 20 20 20 20 20 20 est......
2e70: 28 63 6f 6e 64 0a 09 09 09 09 09 09 28 28 70 72 (cond.......((pr
2e80: 6f 63 65 64 75 72 65 3f 20 69 74 65 6d 73 29 20 ocedure? items)
2e90: 20 20 20 20 20 0a 09 09 09 09 09 09 20 28 64 65 ....... (de
2ea0: 62 75 67 3a 70 72 69 6e 74 20 34 20 22 49 4e 46 bug:print 4 "INF
2eb0: 4f 3a 20 69 74 65 6d 73 20 69 73 20 61 20 70 72 O: items is a pr
2ec0: 6f 63 65 64 75 72 65 2c 20 77 69 6c 6c 20 63 61 ocedure, will ca
2ed0: 6c 63 20 6c 61 74 65 72 22 29 0a 09 09 09 09 09 lc later")......
2ee0: 09 20 69 74 65 6d 73 29 20 20 20 20 20 20 20 20 . items)
2ef0: 20 20 20 20 3b 3b 20 63 61 6c 63 20 6c 61 74 65 ;; calc late
2f00: 72 0a 09 09 09 09 09 09 28 28 70 72 6f 63 65 64 r.......((proced
2f10: 75 72 65 3f 20 69 74 65 6d 73 74 61 62 6c 65 29 ure? itemstable)
2f20: 0a 09 09 09 09 09 09 20 28 64 65 62 75 67 3a 70 ....... (debug:p
2f30: 72 69 6e 74 20 34 20 22 49 4e 46 4f 3a 20 69 74 rint 4 "INFO: it
2f40: 65 6d 73 74 61 62 6c 65 20 69 73 20 61 20 70 72 emstable is a pr
2f50: 6f 63 65 64 75 72 65 2c 20 77 69 6c 6c 20 63 61 ocedure, will ca
2f60: 6c 63 20 6c 61 74 65 72 22 29 0a 09 09 09 09 09 lc later")......
2f70: 09 20 69 74 65 6d 73 74 61 62 6c 65 29 20 20 20 . itemstable)
2f80: 20 20 20 20 3b 3b 20 63 61 6c 63 20 6c 61 74 65 ;; calc late
2f90: 72 0a 09 09 09 09 09 09 28 28 66 69 6c 74 65 72 r.......((filter
2fa0: 20 28 6c 61 6d 62 64 61 20 28 78 29 0a 09 09 09 (lambda (x)....
2fb0: 09 09 09 09 20 20 20 28 6c 65 74 20 28 28 76 61 .... (let ((va
2fc0: 6c 20 28 63 61 72 20 78 29 29 29 0a 09 09 09 09 l (car x))).....
2fd0: 09 09 09 20 20 20 20 20 28 69 66 20 28 70 72 6f ... (if (pro
2fe0: 63 65 64 75 72 65 3f 20 76 61 6c 29 20 76 61 6c cedure? val) val
2ff0: 20 23 66 29 29 29 0a 09 09 09 09 09 09 09 20 28 #f)))........ (
3000: 61 70 70 65 6e 64 20 28 69 66 20 28 6c 69 73 74 append (if (list
3010: 3f 20 69 74 65 6d 73 29 20 69 74 65 6d 73 20 27 ? items) items '
3020: 28 29 29 0a 09 09 09 09 09 09 09 09 20 28 69 66 ())......... (if
3030: 20 28 6c 69 73 74 3f 20 69 74 65 6d 73 74 61 62 (list? itemstab
3040: 6c 65 29 20 69 74 65 6d 73 74 61 62 6c 65 20 27 le) itemstable '
3050: 28 29 29 29 29 0a 09 09 09 09 09 09 20 27 68 61 ())))....... 'ha
3060: 76 65 2d 70 72 6f 63 65 64 75 72 65 29 0a 09 09 ve-procedure)...
3070: 09 09 09 09 28 28 6f 72 20 28 6c 69 73 74 3f 20 ....((or (list?
3080: 69 74 65 6d 73 29 28 6c 69 73 74 3f 20 69 74 65 items)(list? ite
3090: 6d 73 74 61 62 6c 65 29 29 20 3b 3b 20 63 61 6c mstable)) ;; cal
30a0: 63 20 6e 6f 77 0a 09 09 09 09 09 09 20 28 64 65 c now....... (de
30b0: 62 75 67 3a 70 72 69 6e 74 20 34 20 22 49 4e 46 bug:print 4 "INF
30c0: 4f 3a 20 69 74 65 6d 73 20 61 6e 64 20 69 74 65 O: items and ite
30d0: 6d 73 74 61 62 6c 65 20 61 72 65 20 6c 69 73 74 mstable are list
30e0: 73 2c 20 63 61 6c 63 20 6e 6f 77 5c 6e 22 0a 09 s, calc now\n"..
30f0: 09 09 09 09 09 09 20 20 20 20 20 20 22 20 20 20 ...... "
3100: 20 69 74 65 6d 73 3a 20 22 20 69 74 65 6d 73 20 items: " items
3110: 22 20 69 74 65 6d 73 74 61 62 6c 65 3a 20 22 20 " itemstable: "
3120: 69 74 65 6d 73 74 61 62 6c 65 29 0a 09 09 09 09 itemstable).....
3130: 09 09 20 28 69 74 65 6d 73 3a 67 65 74 2d 69 74 .. (items:get-it
3140: 65 6d 73 2d 66 72 6f 6d 2d 63 6f 6e 66 69 67 20 ems-from-config
3150: 63 6f 6e 66 69 67 29 29 0a 09 09 09 09 09 09 28 config)).......(
3160: 65 6c 73 65 20 23 66 29 29 29 20 20 20 20 20 20 else #f)))
3170: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3180: 20 20 20 20 20 3b 3b 20 6e 6f 74 20 69 74 65 72 ;; not iter
3190: 61 74 65 64 0a 09 09 09 09 09 20 20 20 20 20 23 ated...... #
31a0: 66 20 20 20 20 20 20 3b 3b 20 69 74 65 6d 73 64 f ;; itemsd
31b0: 61 74 20 35 0a 09 09 09 09 09 20 20 20 20 20 23 at 5...... #
31c0: 66 20 20 20 20 20 20 3b 3b 20 73 70 61 72 65 20 f ;; spare
31d0: 2d 20 75 73 65 64 20 66 6f 72 20 69 74 65 6d 2d - used for item-
31e0: 70 61 74 68 0a 09 09 09 09 09 20 20 20 20 20 29 path...... )
31f0: 29 29 0a 09 20 20 20 20 28 66 6f 72 2d 65 61 63 )).. (for-eac
3200: 68 20 0a 09 20 20 20 20 20 28 6c 61 6d 62 64 61 h .. (lambda
3210: 20 28 77 61 69 74 6f 6e 29 0a 09 20 20 20 20 20 (waiton)..
3220: 20 20 28 69 66 20 28 61 6e 64 20 77 61 69 74 6f (if (and waito
3230: 6e 20 28 6e 6f 74 20 28 6d 65 6d 62 65 72 20 77 n (not (member w
3240: 61 69 74 6f 6e 20 74 65 73 74 2d 6e 61 6d 65 73 aiton test-names
3250: 29 29 29 0a 09 09 20 20 20 28 62 65 67 69 6e 0a )))... (begin.
3260: 09 09 20 20 20 20 20 28 73 65 74 21 20 72 65 71 .. (set! req
3270: 75 69 72 65 64 2d 74 65 73 74 73 20 28 63 6f 6e uired-tests (con
3280: 73 20 77 61 69 74 6f 6e 20 72 65 71 75 69 72 65 s waiton require
3290: 64 2d 74 65 73 74 73 29 29 0a 09 09 20 20 20 20 d-tests))...
32a0: 20 28 73 65 74 21 20 74 65 73 74 2d 6e 61 6d 65 (set! test-name
32b0: 73 20 28 63 6f 6e 73 20 77 61 69 74 6f 6e 20 74 s (cons waiton t
32c0: 65 73 74 2d 6e 61 6d 65 73 29 29 29 29 29 20 3b est-names))))) ;
32d0: 3b 20 77 61 73 20 61 6e 20 61 70 70 65 6e 64 2c ; was an append,
32e0: 20 6e 6f 77 20 61 20 63 6f 6e 73 0a 09 20 20 20 now a cons..
32f0: 20 20 77 61 69 74 6f 6e 73 29 0a 09 20 20 20 20 waitons)..
3300: 28 6c 65 74 20 28 28 72 65 6d 74 65 73 74 73 20 (let ((remtests
3310: 28 64 65 6c 65 74 65 2d 64 75 70 6c 69 63 61 74 (delete-duplicat
3320: 65 73 20 28 61 70 70 65 6e 64 20 77 61 69 74 6f es (append waito
3330: 6e 73 20 74 61 6c 29 29 29 29 0a 09 20 20 20 20 ns tal))))..
3340: 20 20 28 69 66 20 28 6e 6f 74 20 28 6e 75 6c 6c (if (not (null
3350: 3f 20 72 65 6d 74 65 73 74 73 29 29 0a 09 09 20 ? remtests))...
3360: 20 28 6c 6f 6f 70 20 28 63 61 72 20 72 65 6d 74 (loop (car remt
3370: 65 73 74 73 29 28 63 64 72 20 72 65 6d 74 65 73 ests)(cdr remtes
3380: 74 73 29 29 29 29 29 29 29 0a 0a 20 20 20 20 28 ts))))))).. (
3390: 69 66 20 28 6e 6f 74 20 28 6e 75 6c 6c 3f 20 72 if (not (null? r
33a0: 65 71 75 69 72 65 64 2d 74 65 73 74 73 29 29 0a equired-tests)).
33b0: 09 28 64 65 62 75 67 3a 70 72 69 6e 74 20 31 20 .(debug:print 1
33c0: 22 49 4e 46 4f 3a 20 41 64 64 69 6e 67 20 22 20 "INFO: Adding "
33d0: 72 65 71 75 69 72 65 64 2d 74 65 73 74 73 20 22 required-tests "
33e0: 20 74 6f 20 74 68 65 20 72 75 6e 20 71 75 65 75 to the run queu
33f0: 65 22 29 29 0a 20 20 20 20 3b 3b 20 4e 4f 54 45 e")). ;; NOTE
3400: 3a 20 74 68 65 73 65 20 61 72 65 20 61 6c 6c 20 : these are all
3410: 70 61 72 65 6e 74 20 74 65 73 74 73 2c 20 69 74 parent tests, it
3420: 65 6d 73 20 61 72 65 20 6e 6f 74 20 65 78 70 61 ems are not expa
3430: 6e 64 65 64 20 79 65 74 2e 0a 20 20 20 20 28 64 nded yet.. (d
3440: 65 62 75 67 3a 70 72 69 6e 74 20 34 20 22 49 4e ebug:print 4 "IN
3450: 46 4f 3a 20 74 65 73 74 2d 72 65 63 6f 72 64 73 FO: test-records
3460: 3d 22 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 3e =" (hash-table->
3470: 61 6c 69 73 74 20 74 65 73 74 2d 72 65 63 6f 72 alist test-recor
3480: 64 73 29 29 0a 20 20 20 20 28 72 75 6e 73 3a 72 ds)). (runs:r
3490: 75 6e 2d 74 65 73 74 73 2d 71 75 65 75 65 20 72 un-tests-queue r
34a0: 75 6e 2d 69 64 20 72 75 6e 6e 61 6d 65 20 74 65 un-id runname te
34b0: 73 74 2d 72 65 63 6f 72 64 73 20 6b 65 79 76 61 st-records keyva
34c0: 6c 6c 73 74 20 66 6c 61 67 73 29 0a 20 20 20 20 llst flags).
34d0: 28 64 65 62 75 67 3a 70 72 69 6e 74 20 34 20 22 (debug:print 4 "
34e0: 49 4e 46 4f 3a 20 41 6c 6c 20 64 6f 6e 65 20 62 INFO: All done b
34f0: 79 20 68 65 72 65 22 29 29 29 0a 0a 28 64 65 66 y here")))..(def
3500: 69 6e 65 20 28 72 75 6e 73 3a 63 61 6c 63 2d 66 ine (runs:calc-f
3510: 61 69 6c 73 20 70 72 65 72 65 71 73 2d 6e 6f 74 ails prereqs-not
3520: 2d 6d 65 74 29 0a 20 20 28 66 69 6c 74 65 72 20 -met). (filter
3530: 28 6c 61 6d 62 64 61 20 28 74 65 73 74 29 0a 09 (lambda (test)..
3540: 20 20 20 20 28 61 6e 64 20 28 76 65 63 74 6f 72 (and (vector
3550: 3f 20 74 65 73 74 29 20 3b 3b 20 6e 6f 74 20 28 ? test) ;; not (
3560: 73 74 72 69 6e 67 3f 20 74 65 73 74 29 29 0a 09 string? test))..
3570: 09 20 28 65 71 75 61 6c 3f 20 28 64 62 3a 74 65 . (equal? (db:te
3580: 73 74 2d 67 65 74 2d 73 74 61 74 65 20 74 65 73 st-get-state tes
3590: 74 29 20 22 43 4f 4d 50 4c 45 54 45 44 22 29 0a t) "COMPLETED").
35a0: 09 09 20 28 6e 6f 74 20 28 6d 65 6d 62 65 72 20 .. (not (member
35b0: 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 73 74 61 (db:test-get-sta
35c0: 74 75 73 20 74 65 73 74 29 0a 09 09 09 20 20 20 tus test)....
35d0: 20 20 20 27 28 22 50 41 53 53 22 20 22 57 41 52 '("PASS" "WAR
35e0: 4e 22 20 22 43 48 45 43 4b 22 20 22 57 41 49 56 N" "CHECK" "WAIV
35f0: 45 44 22 29 29 29 29 29 0a 09 20 20 70 72 65 72 ED"))))).. prer
3600: 65 71 73 2d 6e 6f 74 2d 6d 65 74 29 29 0a 0a 28 eqs-not-met))..(
3610: 64 65 66 69 6e 65 20 28 72 75 6e 73 3a 63 61 6c define (runs:cal
3620: 63 2d 6e 6f 74 2d 63 6f 6d 70 6c 65 74 65 64 20 c-not-completed
3630: 70 72 65 72 65 71 73 2d 6e 6f 74 2d 6d 65 74 29 prereqs-not-met)
3640: 0a 20 20 28 66 69 6c 74 65 72 0a 20 20 20 28 6c . (filter. (l
3650: 61 6d 62 64 61 20 28 74 29 0a 20 20 20 20 20 28 ambda (t). (
3660: 6f 72 20 28 6e 6f 74 20 28 76 65 63 74 6f 72 3f or (not (vector?
3670: 20 74 29 29 0a 09 20 28 6e 6f 74 20 28 65 71 75 t)).. (not (equ
3680: 61 6c 3f 20 22 43 4f 4d 50 4c 45 54 45 44 22 20 al? "COMPLETED"
3690: 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 73 74 61 (db:test-get-sta
36a0: 74 65 20 74 29 29 29 29 29 0a 20 20 20 70 72 65 te t))))). pre
36b0: 72 65 71 73 2d 6e 6f 74 2d 6d 65 74 29 29 0a 0a reqs-not-met))..
36c0: 28 64 65 66 69 6e 65 20 28 72 75 6e 73 3a 70 72 (define (runs:pr
36d0: 65 74 74 79 2d 73 74 72 69 6e 67 20 6c 73 74 29 etty-string lst)
36e0: 0a 20 20 28 6d 61 70 20 28 6c 61 6d 62 64 61 20 . (map (lambda
36f0: 28 74 29 0a 09 20 28 69 66 20 28 6e 6f 74 20 28 (t).. (if (not (
3700: 76 65 63 74 6f 72 3f 20 74 29 29 0a 09 20 20 20 vector? t))..
3710: 20 20 28 63 6f 6e 63 20 74 29 0a 09 20 20 20 20 (conc t)..
3720: 20 28 63 6f 6e 63 20 28 64 62 3a 74 65 73 74 2d (conc (db:test-
3730: 67 65 74 2d 74 65 73 74 6e 61 6d 65 20 74 29 20 get-testname t)
3740: 22 3a 22 20 28 64 62 3a 74 65 73 74 2d 67 65 74 ":" (db:test-get
3750: 2d 73 74 61 74 65 20 74 29 20 22 2f 22 20 28 64 -state t) "/" (d
3760: 62 3a 74 65 73 74 2d 67 65 74 2d 73 74 61 74 75 b:test-get-statu
3770: 73 20 74 29 29 29 29 0a 20 20 20 20 20 20 20 6c s t)))). l
3780: 73 74 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 72 st))..(define (r
3790: 75 6e 73 3a 6d 61 6b 65 2d 66 75 6c 6c 2d 74 65 uns:make-full-te
37a0: 73 74 2d 6e 61 6d 65 20 74 65 73 74 6e 61 6d 65 st-name testname
37b0: 20 69 74 65 6d 70 61 74 68 29 0a 20 20 28 69 66 itempath). (if
37c0: 20 28 65 71 75 61 6c 3f 20 69 74 65 6d 70 61 74 (equal? itempat
37d0: 68 20 22 22 29 20 74 65 73 74 6e 61 6d 65 20 28 h "") testname (
37e0: 63 6f 6e 63 20 74 65 73 74 6e 61 6d 65 20 22 2f conc testname "/
37f0: 22 20 69 74 65 6d 70 61 74 68 29 29 29 0a 0a 3b " itempath)))..;
3800: 3b 20 74 65 73 74 2d 72 65 63 6f 72 64 73 20 69 ; test-records i
3810: 73 20 61 20 68 61 73 68 20 74 61 62 6c 65 20 74 s a hash table t
3820: 65 73 74 6e 61 6d 65 3a 69 74 65 6d 5f 70 61 74 estname:item_pat
3830: 68 20 3d 3e 20 76 65 63 74 6f 72 20 3c 20 74 65 h => vector < te
3840: 73 74 6e 61 6d 65 20 74 65 73 74 63 6f 6e 66 69 stname testconfi
3850: 67 20 77 61 69 74 6f 6e 73 20 70 72 69 6f 72 69 g waitons priori
3860: 74 79 20 69 74 65 6d 73 2d 69 6e 66 6f 20 2e 2e ty items-info ..
3870: 2e 20 3e 0a 28 64 65 66 69 6e 65 20 28 72 75 6e . >.(define (run
3880: 73 3a 72 75 6e 2d 74 65 73 74 73 2d 71 75 65 75 s:run-tests-queu
3890: 65 20 72 75 6e 2d 69 64 20 72 75 6e 6e 61 6d 65 e run-id runname
38a0: 20 74 65 73 74 2d 72 65 63 6f 72 64 73 20 6b 65 test-records ke
38b0: 79 76 61 6c 6c 73 74 20 66 6c 61 67 73 29 0a 20 yvallst flags).
38c0: 20 20 20 3b 3b 20 41 74 20 74 68 69 73 20 70 6f ;; At this po
38d0: 69 6e 74 20 74 68 65 20 6c 69 73 74 20 6f 66 20 int the list of
38e0: 70 61 72 65 6e 74 20 74 65 73 74 73 20 69 73 20 parent tests is
38f0: 65 78 70 61 6e 64 65 64 20 0a 20 20 20 20 3b 3b expanded . ;;
3900: 20 4e 42 2f 2f 20 53 68 6f 75 6c 64 20 65 78 70 NB// Should exp
3910: 61 6e 64 20 69 74 65 6d 73 20 68 65 72 65 20 61 and items here a
3920: 6e 64 20 74 68 65 6e 20 69 6e 73 65 72 74 20 69 nd then insert i
3930: 6e 74 6f 20 74 68 65 20 72 75 6e 20 71 75 65 75 nto the run queu
3940: 65 2e 0a 20 20 28 64 65 62 75 67 3a 70 72 69 6e e.. (debug:prin
3950: 74 20 35 20 22 74 65 73 74 2d 72 65 63 6f 72 64 t 5 "test-record
3960: 73 3a 20 22 20 74 65 73 74 2d 72 65 63 6f 72 64 s: " test-record
3970: 73 20 22 2c 20 6b 65 79 76 61 6c 6c 73 74 3a 20 s ", keyvallst:
3980: 22 20 6b 65 79 76 61 6c 6c 73 74 20 22 20 66 6c " keyvallst " fl
3990: 61 67 73 3a 20 22 20 28 68 61 73 68 2d 74 61 62 ags: " (hash-tab
39a0: 6c 65 2d 3e 61 6c 69 73 74 20 66 6c 61 67 73 29 le->alist flags)
39b0: 29 0a 20 20 28 6c 65 74 20 28 28 73 6f 72 74 65 ). (let ((sorte
39c0: 64 2d 74 65 73 74 2d 6e 61 6d 65 73 20 28 74 65 d-test-names (te
39d0: 73 74 73 3a 73 6f 72 74 2d 62 79 2d 70 72 69 6f sts:sort-by-prio
39e0: 72 69 74 79 2d 61 6e 64 2d 77 61 69 74 6f 6e 20 rity-and-waiton
39f0: 74 65 73 74 2d 72 65 63 6f 72 64 73 29 29 0a 09 test-records))..
3a00: 28 69 74 65 6d 2d 70 61 74 74 73 20 20 20 20 20 (item-patts
3a10: 20 20 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 (hash-table-r
3a20: 65 66 2f 64 65 66 61 75 6c 74 20 66 6c 61 67 73 ef/default flags
3a30: 20 22 2d 69 74 65 6d 70 61 74 74 22 20 23 66 29 "-itempatt" #f)
3a40: 29 0a 09 28 74 65 73 74 2d 72 65 67 69 73 74 65 )..(test-registe
3a50: 72 79 20 20 20 20 28 6d 61 6b 65 2d 68 61 73 68 ry (make-hash
3a60: 2d 74 61 62 6c 65 29 29 0a 09 28 6e 75 6d 2d 72 -table))..(num-r
3a70: 65 74 72 69 65 73 20 20 20 20 20 20 20 20 30 29 etries 0)
3a80: 0a 09 28 6d 61 78 2d 72 65 74 72 69 65 73 20 20 ..(max-retries
3a90: 20 20 20 20 20 28 63 6f 6e 66 69 67 2d 6c 6f 6f (config-loo
3aa0: 6b 75 70 20 2a 63 6f 6e 66 69 67 64 61 74 2a 20 kup *configdat*
3ab0: 22 73 65 74 75 70 22 20 22 6d 61 78 72 65 74 72 "setup" "maxretr
3ac0: 69 65 73 22 29 29 29 0a 20 20 20 20 28 73 65 74 ies"))). (set
3ad0: 21 20 6d 61 78 2d 72 65 74 72 69 65 73 20 28 69 ! max-retries (i
3ae0: 66 20 28 61 6e 64 20 6d 61 78 2d 72 65 74 72 69 f (and max-retri
3af0: 65 73 20 28 73 74 72 69 6e 67 2d 3e 6e 75 6d 62 es (string->numb
3b00: 65 72 20 6d 61 78 2d 72 65 74 72 69 65 73 29 29 er max-retries))
3b10: 28 73 74 72 69 6e 67 2d 3e 6e 75 6d 62 65 72 20 (string->number
3b20: 6d 61 78 2d 72 65 74 72 69 65 73 29 20 31 30 30 max-retries) 100
3b30: 29 29 0a 20 20 20 20 28 69 66 20 28 6e 6f 74 20 )). (if (not
3b40: 28 6e 75 6c 6c 3f 20 73 6f 72 74 65 64 2d 74 65 (null? sorted-te
3b50: 73 74 2d 6e 61 6d 65 73 29 29 0a 09 28 6c 65 74 st-names))..(let
3b60: 20 6c 6f 6f 70 20 28 28 68 65 64 20 20 20 20 20 loop ((hed
3b70: 20 20 20 20 28 63 61 72 20 73 6f 72 74 65 64 2d (car sorted-
3b80: 74 65 73 74 2d 6e 61 6d 65 73 29 29 0a 09 09 20 test-names))...
3b90: 20 20 28 74 61 6c 20 20 20 20 20 20 20 20 20 28 (tal (
3ba0: 63 64 72 20 73 6f 72 74 65 64 2d 74 65 73 74 2d cdr sorted-test-
3bb0: 6e 61 6d 65 73 29 29 0a 09 09 20 20 20 28 72 65 names))... (re
3bc0: 72 75 6e 73 20 20 20 20 20 20 27 28 29 29 29 0a runs '())).
3bd0: 09 20 20 28 69 66 20 28 6e 6f 74 20 28 6e 75 6c . (if (not (nul
3be0: 6c 3f 20 72 65 72 75 6e 73 29 29 28 64 65 62 75 l? reruns))(debu
3bf0: 67 3a 70 72 69 6e 74 20 34 20 22 49 4e 46 4f 3a g:print 4 "INFO:
3c00: 20 72 65 72 75 6e 73 3d 22 20 72 65 72 75 6e 73 reruns=" reruns
3c10: 29 29 0a 09 20 20 3b 3b 20 28 70 72 69 6e 74 20 )).. ;; (print
3c20: 22 54 6f 70 20 6f 66 20 6c 6f 6f 70 2c 20 68 65 "Top of loop, he
3c30: 64 3d 22 20 68 65 64 20 22 2c 20 74 61 6c 3d 22 d=" hed ", tal="
3c40: 20 74 61 6c 20 22 20 2c 72 65 72 75 6e 73 3d 22 tal " ,reruns="
3c50: 20 72 65 72 75 6e 73 29 0a 09 20 20 28 6c 65 74 reruns).. (let
3c60: 2a 20 28 28 74 65 73 74 2d 72 65 63 6f 72 64 20 * ((test-record
3c70: 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 20 (hash-table-ref
3c80: 74 65 73 74 2d 72 65 63 6f 72 64 73 20 68 65 64 test-records hed
3c90: 29 29 0a 09 09 20 28 74 65 73 74 2d 6e 61 6d 65 ))... (test-name
3ca0: 20 20 20 28 74 65 73 74 73 3a 74 65 73 74 71 75 (tests:testqu
3cb0: 65 75 65 2d 67 65 74 2d 74 65 73 74 6e 61 6d 65 eue-get-testname
3cc0: 20 74 65 73 74 2d 72 65 63 6f 72 64 29 29 0a 09 test-record))..
3cd0: 09 20 28 74 63 6f 6e 66 69 67 20 20 20 20 20 28 . (tconfig (
3ce0: 74 65 73 74 73 3a 74 65 73 74 71 75 65 75 65 2d tests:testqueue-
3cf0: 67 65 74 2d 74 65 73 74 63 6f 6e 66 69 67 20 74 get-testconfig t
3d00: 65 73 74 2d 72 65 63 6f 72 64 29 29 0a 09 09 20 est-record))...
3d10: 28 74 65 73 74 6d 6f 64 65 20 20 20 20 28 6c 65 (testmode (le
3d20: 74 20 28 28 6d 20 28 63 6f 6e 66 69 67 2d 6c 6f t ((m (config-lo
3d30: 6f 6b 75 70 20 74 63 6f 6e 66 69 67 20 22 72 65 okup tconfig "re
3d40: 71 75 69 72 65 6d 65 6e 74 73 22 20 22 6d 6f 64 quirements" "mod
3d50: 65 22 29 29 29 0a 09 09 09 09 28 69 66 20 6d 20 e"))).....(if m
3d60: 28 73 74 72 69 6e 67 2d 3e 73 79 6d 62 6f 6c 20 (string->symbol
3d70: 6d 29 20 27 6e 6f 72 6d 61 6c 29 29 29 0a 09 09 m) 'normal)))...
3d80: 20 28 77 61 69 74 6f 6e 73 20 20 20 20 20 28 74 (waitons (t
3d90: 65 73 74 73 3a 74 65 73 74 71 75 65 75 65 2d 67 ests:testqueue-g
3da0: 65 74 2d 77 61 69 74 6f 6e 73 20 20 20 20 74 65 et-waitons te
3db0: 73 74 2d 72 65 63 6f 72 64 29 29 0a 09 09 20 28 st-record))... (
3dc0: 70 72 69 6f 72 69 74 79 20 20 20 20 28 74 65 73 priority (tes
3dd0: 74 73 3a 74 65 73 74 71 75 65 75 65 2d 67 65 74 ts:testqueue-get
3de0: 2d 70 72 69 6f 72 69 74 79 20 20 20 74 65 73 74 -priority test
3df0: 2d 72 65 63 6f 72 64 29 29 0a 09 09 20 28 69 74 -record))... (it
3e00: 65 6d 64 61 74 20 20 20 20 20 28 74 65 73 74 73 emdat (tests
3e10: 3a 74 65 73 74 71 75 65 75 65 2d 67 65 74 2d 69 :testqueue-get-i
3e20: 74 65 6d 64 61 74 20 20 20 20 74 65 73 74 2d 72 temdat test-r
3e30: 65 63 6f 72 64 29 29 20 3b 3b 20 69 74 65 6d 64 ecord)) ;; itemd
3e40: 61 74 20 63 61 6e 20 62 65 20 61 20 73 74 72 69 at can be a stri
3e50: 6e 67 2c 20 6c 69 73 74 20 6f 72 20 23 66 0a 09 ng, list or #f..
3e60: 09 20 28 69 74 65 6d 73 20 20 20 20 20 20 20 28 . (items (
3e70: 74 65 73 74 73 3a 74 65 73 74 71 75 65 75 65 2d tests:testqueue-
3e80: 67 65 74 2d 69 74 65 6d 73 20 20 20 20 20 20 74 get-items t
3e90: 65 73 74 2d 72 65 63 6f 72 64 29 29 0a 09 09 20 est-record))...
3ea0: 28 69 74 65 6d 2d 70 61 74 68 20 20 20 28 69 74 (item-path (it
3eb0: 65 6d 2d 6c 69 73 74 2d 3e 70 61 74 68 20 69 74 em-list->path it
3ec0: 65 6d 64 61 74 29 29 0a 09 09 20 28 6e 65 77 74 emdat))... (newt
3ed0: 61 6c 20 20 20 20 20 20 28 61 70 70 65 6e 64 20 al (append
3ee0: 74 61 6c 20 28 6c 69 73 74 20 68 65 64 29 29 29 tal (list hed)))
3ef0: 29 0a 09 20 20 20 20 0a 09 20 20 20 20 28 64 65 ).. .. (de
3f00: 62 75 67 3a 70 72 69 6e 74 20 36 0a 09 09 09 20 bug:print 6....
3f10: 22 74 65 73 74 2d 6e 61 6d 65 3a 20 22 20 74 65 "test-name: " te
3f20: 73 74 2d 6e 61 6d 65 0a 09 09 09 20 22 5c 6e 20 st-name.... "\n
3f30: 20 68 65 64 3a 20 20 20 20 20 20 20 20 20 22 20 hed: "
3f40: 68 65 64 0a 09 09 09 20 22 5c 6e 20 20 69 74 65 hed.... "\n ite
3f50: 6d 64 61 74 3a 20 20 20 20 20 22 20 69 74 65 6d mdat: " item
3f60: 64 61 74 0a 09 09 09 20 22 5c 6e 20 20 69 74 65 dat.... "\n ite
3f70: 6d 73 3a 20 20 20 20 20 20 20 22 20 69 74 65 6d ms: " item
3f80: 73 0a 09 09 09 20 22 5c 6e 20 20 69 74 65 6d 2d s.... "\n item-
3f90: 70 61 74 68 3a 20 20 20 22 20 69 74 65 6d 2d 70 path: " item-p
3fa0: 61 74 68 0a 09 09 09 20 22 5c 6e 20 20 77 61 69 ath.... "\n wai
3fb0: 74 6f 6e 73 3a 20 20 20 20 20 22 20 77 61 69 74 tons: " wait
3fc0: 6f 6e 73 0a 09 09 09 20 22 5c 6e 20 20 6e 75 6d ons.... "\n num
3fd0: 2d 72 65 74 72 69 65 73 3a 20 22 20 6e 75 6d 2d -retries: " num-
3fe0: 72 65 74 72 69 65 73 0a 09 09 09 20 22 5c 6e 20 retries.... "\n
3ff0: 20 74 61 6c 3a 20 20 20 20 20 20 20 20 20 22 20 tal: "
4000: 74 61 6c 0a 09 09 09 20 22 5c 6e 20 20 72 65 72 tal.... "\n rer
4010: 75 6e 73 3a 20 20 20 20 20 20 22 20 72 65 72 75 uns: " reru
4020: 6e 73 29 0a 0a 09 20 20 20 20 3b 3b 20 63 68 65 ns)... ;; che
4030: 63 6b 20 66 6f 72 20 68 65 64 20 69 6e 20 77 61 ck for hed in wa
4040: 69 74 6f 6e 73 20 3d 3e 20 74 68 69 73 20 77 6f itons => this wo
4050: 75 6c 64 20 62 65 20 63 69 72 63 75 6c 61 72 2c uld be circular,
4060: 20 72 65 6d 6f 76 65 20 69 74 20 61 6e 64 20 69 remove it and i
4070: 73 73 75 65 20 61 6e 0a 09 20 20 20 20 3b 3b 20 ssue an.. ;;
4080: 65 72 72 6f 72 0a 09 20 20 20 20 28 69 66 20 28 error.. (if (
4090: 6d 65 6d 62 65 72 20 74 65 73 74 2d 6e 61 6d 65 member test-name
40a0: 20 77 61 69 74 6f 6e 73 29 0a 09 09 28 62 65 67 waitons)...(beg
40b0: 69 6e 0a 09 09 20 20 28 64 65 62 75 67 3a 70 72 in... (debug:pr
40c0: 69 6e 74 20 30 20 22 45 52 52 4f 52 3a 20 74 65 int 0 "ERROR: te
40d0: 73 74 20 22 20 74 65 73 74 2d 6e 61 6d 65 20 22 st " test-name "
40e0: 20 68 61 73 20 6c 69 73 74 65 64 20 69 74 73 65 has listed itse
40f0: 6c 66 20 61 73 20 61 20 77 61 69 74 6f 6e 2c 20 lf as a waiton,
4100: 70 6c 65 61 73 65 20 63 6f 72 72 65 63 74 20 74 please correct t
4110: 68 69 73 21 22 29 0a 09 09 20 20 28 73 65 74 21 his!")... (set!
4120: 20 77 61 69 74 6f 6e 20 28 66 69 6c 74 65 72 20 waiton (filter
4130: 28 6c 61 6d 62 64 61 20 28 78 29 28 6e 6f 74 20 (lambda (x)(not
4140: 28 65 71 75 61 6c 3f 20 78 20 68 65 64 29 29 29 (equal? x hed)))
4150: 20 77 61 69 74 6f 6e 73 29 29 29 29 0a 0a 09 20 waitons))))...
4160: 20 20 20 28 63 6f 6e 64 20 3b 3b 20 4f 55 54 45 (cond ;; OUTE
4170: 52 20 43 4f 4e 44 0a 09 20 20 20 20 20 28 28 6e R COND.. ((n
4180: 6f 74 20 69 74 65 6d 73 29 20 3b 3b 20 77 68 65 ot items) ;; whe
4190: 6e 20 66 61 6c 73 65 20 74 68 65 20 74 65 73 74 n false the test
41a0: 20 69 73 20 6f 6b 20 74 6f 20 62 65 20 68 61 6e is ok to be han
41b0: 64 65 64 20 6f 66 66 20 74 6f 20 6c 61 75 6e 63 ded off to launc
41c0: 68 20 28 62 75 74 20 6e 6f 74 20 62 65 66 6f 72 h (but not befor
41d0: 65 29 0a 09 20 20 20 20 20 20 28 6c 65 74 2a 20 e).. (let*
41e0: 28 28 72 75 6e 2d 6c 69 6d 69 74 73 2d 69 6e 66 ((run-limits-inf
41f0: 6f 20 20 20 20 20 20 20 20 20 28 6f 70 65 6e 2d o (open-
4200: 72 75 6e 2d 63 6c 6f 73 65 20 72 75 6e 73 3a 63 run-close runs:c
4210: 61 6e 2d 72 75 6e 2d 6d 6f 72 65 2d 74 65 73 74 an-run-more-test
4220: 73 20 23 66 20 74 65 73 74 2d 72 65 63 6f 72 64 s #f test-record
4230: 29 29 20 3b 3b 20 6c 6f 6f 6b 20 61 74 20 74 68 )) ;; look at th
4240: 65 20 74 65 73 74 20 6a 6f 62 67 72 6f 75 70 20 e test jobgroup
4250: 61 6e 64 20 74 6f 74 20 6a 6f 62 73 20 72 75 6e and tot jobs run
4260: 6e 69 6e 67 0a 09 09 20 20 20 20 20 28 68 61 76 ning... (hav
4270: 65 2d 72 65 73 6f 75 72 63 65 73 20 20 20 20 20 e-resources
4280: 20 20 20 20 20 28 63 61 72 20 72 75 6e 2d 6c 69 (car run-li
4290: 6d 69 74 73 2d 69 6e 66 6f 29 29 0a 09 09 20 20 mits-info))...
42a0: 20 20 20 28 6e 75 6d 2d 72 75 6e 6e 69 6e 67 20 (num-running
42b0: 20 20 20 20 20 20 20 20 20 20 20 20 28 6c 69 73 (lis
42c0: 74 2d 72 65 66 20 72 75 6e 2d 6c 69 6d 69 74 73 t-ref run-limits
42d0: 2d 69 6e 66 6f 20 31 29 29 0a 09 09 20 20 20 20 -info 1))...
42e0: 20 28 6e 75 6d 2d 72 75 6e 6e 69 6e 67 2d 69 6e (num-running-in
42f0: 2d 6a 6f 62 67 72 6f 75 70 20 28 6c 69 73 74 2d -jobgroup (list-
4300: 72 65 66 20 72 75 6e 2d 6c 69 6d 69 74 73 2d 69 ref run-limits-i
4310: 6e 66 6f 20 32 29 29 0a 09 09 20 20 20 20 20 28 nfo 2))... (
4320: 6d 61 78 2d 63 6f 6e 63 75 72 72 65 6e 74 2d 6a max-concurrent-j
4330: 6f 62 73 20 20 20 20 20 28 6c 69 73 74 2d 72 65 obs (list-re
4340: 66 20 72 75 6e 2d 6c 69 6d 69 74 73 2d 69 6e 66 f run-limits-inf
4350: 6f 20 33 29 29 0a 09 09 20 20 20 20 20 28 6a 6f o 3))... (jo
4360: 62 2d 67 72 6f 75 70 2d 6c 69 6d 69 74 20 20 20 b-group-limit
4370: 20 20 20 20 20 20 28 6c 69 73 74 2d 72 65 66 20 (list-ref
4380: 72 75 6e 2d 6c 69 6d 69 74 73 2d 69 6e 66 6f 20 run-limits-info
4390: 34 29 29 0a 09 09 20 20 20 20 20 28 70 72 65 72 4))... (prer
43a0: 65 71 73 2d 6e 6f 74 2d 6d 65 74 20 20 20 20 20 eqs-not-met
43b0: 20 20 20 20 28 6f 70 65 6e 2d 72 75 6e 2d 63 6c (open-run-cl
43c0: 6f 73 65 20 64 62 3a 67 65 74 2d 70 72 65 72 65 ose db:get-prere
43d0: 71 73 2d 6e 6f 74 2d 6d 65 74 20 23 66 20 72 75 qs-not-met #f ru
43e0: 6e 2d 69 64 20 77 61 69 74 6f 6e 73 20 69 74 65 n-id waitons ite
43f0: 6d 2d 70 61 74 68 20 6d 6f 64 65 3a 20 74 65 73 m-path mode: tes
4400: 74 6d 6f 64 65 29 29 0a 09 09 20 20 20 20 20 28 tmode))... (
4410: 66 61 69 6c 73 20 20 20 20 20 20 20 20 20 20 20 fails
4420: 20 20 20 20 20 20 20 20 28 72 75 6e 73 3a 63 61 (runs:ca
4430: 6c 63 2d 66 61 69 6c 73 20 70 72 65 72 65 71 73 lc-fails prereqs
4440: 2d 6e 6f 74 2d 6d 65 74 29 29 0a 09 09 20 20 20 -not-met))...
4450: 20 20 28 6e 6f 6e 2d 63 6f 6d 70 6c 65 74 65 64 (non-completed
4460: 20 20 20 20 20 20 20 20 20 20 20 28 72 75 6e 73 (runs
4470: 3a 63 61 6c 63 2d 6e 6f 74 2d 63 6f 6d 70 6c 65 :calc-not-comple
4480: 74 65 64 20 70 72 65 72 65 71 73 2d 6e 6f 74 2d ted prereqs-not-
4490: 6d 65 74 29 29 29 0a 09 09 28 64 65 62 75 67 3a met)))...(debug:
44a0: 70 72 69 6e 74 20 38 20 22 49 4e 46 4f 3a 20 68 print 8 "INFO: h
44b0: 61 76 65 2d 72 65 73 6f 75 72 63 65 73 3a 20 22 ave-resources: "
44c0: 20 68 61 76 65 2d 72 65 73 6f 75 72 63 65 73 20 have-resources
44d0: 22 20 70 72 65 72 65 71 73 2d 6e 6f 74 2d 6d 65 " prereqs-not-me
44e0: 74 3a 20 22 20 0a 09 09 09 20 20 20 20 20 28 73 t: " .... (s
44f0: 74 72 69 6e 67 2d 69 6e 74 65 72 73 70 65 72 73 tring-interspers
4500: 65 20 0a 09 09 09 20 20 20 20 20 20 28 6d 61 70 e .... (map
4510: 20 28 6c 61 6d 62 64 61 20 28 74 29 0a 09 09 09 (lambda (t)....
4520: 09 20 20 20 20 20 28 69 66 20 28 76 65 63 74 6f . (if (vecto
4530: 72 3f 20 74 29 0a 09 09 09 09 09 20 28 63 6f 6e r? t)...... (con
4540: 63 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 73 c (db:test-get-s
4550: 74 61 74 65 20 74 29 20 22 2f 22 20 28 64 62 3a tate t) "/" (db:
4560: 74 65 73 74 2d 67 65 74 2d 73 74 61 74 75 73 20 test-get-status
4570: 74 29 29 0a 09 09 09 09 09 20 28 63 6f 6e 63 20 t))...... (conc
4580: 22 20 57 41 52 4e 49 4e 47 3a 20 74 20 69 73 20 " WARNING: t is
4590: 6e 6f 74 20 61 20 76 65 63 74 6f 72 3d 22 20 74 not a vector=" t
45a0: 20 29 29 29 0a 09 09 09 09 20 20 20 70 72 65 72 )))..... prer
45b0: 65 71 73 2d 6e 6f 74 2d 6d 65 74 29 20 22 2c 20 eqs-not-met) ",
45c0: 22 29 20 22 20 66 61 69 6c 73 3a 20 22 20 66 61 ") " fails: " fa
45d0: 69 6c 73 29 0a 09 09 28 64 65 62 75 67 3a 70 72 ils)...(debug:pr
45e0: 69 6e 74 20 34 20 22 49 4e 46 4f 3a 20 68 65 64 int 4 "INFO: hed
45f0: 3d 22 20 68 65 64 29 0a 0a 09 09 3b 3b 20 44 6f =" hed)....;; Do
4600: 6e 27 74 20 6b 6e 6f 77 20 61 74 20 74 68 69 73 n't know at this
4610: 20 74 69 6d 65 20 69 66 20 74 68 65 20 74 65 73 time if the tes
4620: 74 20 68 61 76 65 20 62 65 65 6e 20 6c 61 75 6e t have been laun
4630: 63 68 65 64 20 61 74 20 73 6f 6d 65 20 74 69 6d ched at some tim
4640: 65 20 69 6e 20 74 68 65 20 70 61 73 74 0a 09 09 e in the past...
4650: 3b 3b 20 69 2e 65 2e 20 69 73 20 74 68 69 73 20 ;; i.e. is this
4660: 61 20 72 65 2d 6c 61 75 6e 63 68 3f 0a 09 09 28 a re-launch?...(
4670: 64 65 62 75 67 3a 70 72 69 6e 74 20 34 20 22 49 debug:print 4 "I
4680: 4e 46 4f 3a 20 72 75 6e 2d 6c 69 6d 69 74 73 2d NFO: run-limits-
4690: 69 6e 66 6f 20 3d 20 22 20 72 75 6e 2d 6c 69 6d info = " run-lim
46a0: 69 74 73 2d 69 6e 66 6f 29 0a 09 09 28 63 6f 6e its-info)...(con
46b0: 64 20 3b 3b 20 49 4e 4e 45 52 20 43 4f 4e 44 20 d ;; INNER COND
46c0: 23 31 20 66 6f 72 20 61 20 6c 61 75 6e 63 68 61 #1 for a launcha
46d0: 62 6c 65 20 74 65 73 74 0a 09 09 20 3b 3b 20 43 ble test... ;; C
46e0: 68 65 63 6b 20 69 74 65 6d 20 70 61 74 68 20 61 heck item path a
46f0: 67 61 69 6e 73 74 20 69 74 65 6d 2d 70 61 74 74 gainst item-patt
4700: 73 0a 09 09 20 28 28 61 6e 64 20 28 6e 6f 74 20 s... ((and (not
4710: 28 70 61 74 74 2d 6c 69 73 74 2d 6d 61 74 63 68 (patt-list-match
4720: 20 69 74 65 6d 2d 70 61 74 68 20 69 74 65 6d 2d item-path item-
4730: 70 61 74 74 73 29 29 0a 09 09 20 20 20 20 20 20 patts))...
4740: 20 28 6e 6f 74 20 28 65 71 75 61 6c 3f 20 69 74 (not (equal? it
4750: 65 6d 2d 70 61 74 68 20 22 22 29 29 29 0a 09 09 em-path "")))...
4760: 20 20 3b 3b 20 65 6c 73 65 20 74 68 65 20 72 75 ;; else the ru
4770: 6e 20 69 73 20 73 74 75 63 6b 2c 20 74 65 6d 70 n is stuck, temp
4780: 6f 72 61 72 69 6c 79 20 6f 72 20 70 65 72 6d 61 orarily or perma
4790: 6e 65 6e 74 6c 79 0a 09 09 20 20 3b 3b 20 62 75 nently... ;; bu
47a0: 74 20 73 68 6f 75 6c 64 20 63 68 65 63 6b 20 69 t should check i
47b0: 66 20 69 74 20 69 73 20 64 75 65 20 74 6f 20 6c f it is due to l
47c0: 61 63 6b 20 6f 66 20 72 65 73 6f 75 72 63 65 73 ack of resources
47d0: 20 76 73 2e 20 70 72 65 72 65 71 75 69 73 69 74 vs. prerequisit
47e0: 65 73 0a 09 09 20 20 28 64 65 62 75 67 3a 70 72 es... (debug:pr
47f0: 69 6e 74 20 31 20 22 49 4e 46 4f 3a 20 53 6b 69 int 1 "INFO: Ski
4800: 70 70 69 6e 67 20 22 20 28 74 65 73 74 73 3a 74 pping " (tests:t
4810: 65 73 74 71 75 65 75 65 2d 67 65 74 2d 74 65 73 estqueue-get-tes
4820: 74 6e 61 6d 65 20 74 65 73 74 2d 72 65 63 6f 72 tname test-recor
4830: 64 29 20 22 20 22 20 69 74 65 6d 2d 70 61 74 68 d) " " item-path
4840: 20 22 20 61 73 20 69 74 20 64 6f 65 73 6e 27 74 " as it doesn't
4850: 20 6d 61 74 63 68 20 22 20 69 74 65 6d 2d 70 61 match " item-pa
4860: 74 74 73 29 0a 09 09 20 20 28 74 68 72 65 61 64 tts)... (thread
4870: 2d 73 6c 65 65 70 21 20 2a 67 6c 6f 62 61 6c 2d -sleep! *global-
4880: 64 65 6c 74 61 2a 29 0a 09 09 20 20 28 69 66 20 delta*)... (if
4890: 28 6e 6f 74 20 28 6e 75 6c 6c 3f 20 74 61 6c 29 (not (null? tal)
48a0: 29 0a 09 09 20 20 20 20 20 20 28 6c 6f 6f 70 20 )... (loop
48b0: 28 63 61 72 20 74 61 6c 29 28 63 64 72 20 74 61 (car tal)(cdr ta
48c0: 6c 29 20 72 65 72 75 6e 73 29 29 29 0a 09 09 20 l) reruns)))...
48d0: 28 28 61 6e 64 20 28 6e 6f 74 20 28 68 61 73 68 ((and (not (hash
48e0: 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 -table-ref/defau
48f0: 6c 74 20 74 65 73 74 2d 72 65 67 69 73 74 65 72 lt test-register
4900: 79 20 28 72 75 6e 73 3a 6d 61 6b 65 2d 66 75 6c y (runs:make-ful
4910: 6c 2d 74 65 73 74 2d 6e 61 6d 65 20 74 65 73 74 l-test-name test
4920: 2d 6e 61 6d 65 20 69 74 65 6d 2d 70 61 74 68 29 -name item-path)
4930: 20 23 66 29 29 0a 09 09 20 20 20 20 20 20 20 28 #f))... (
4940: 61 6e 64 20 6d 61 78 2d 63 6f 6e 63 75 72 72 65 and max-concurre
4950: 6e 74 2d 6a 6f 62 73 20 28 3e 20 28 2d 20 6d 61 nt-jobs (> (- ma
4960: 78 2d 63 6f 6e 63 75 72 72 65 6e 74 2d 6a 6f 62 x-concurrent-job
4970: 73 20 6e 75 6d 2d 72 75 6e 6e 69 6e 67 29 20 35 s num-running) 5
4980: 29 29 29 0a 09 09 20 20 28 6f 70 65 6e 2d 72 75 )))... (open-ru
4990: 6e 2d 63 6c 6f 73 65 20 64 62 3a 74 65 73 74 73 n-close db:tests
49a0: 2d 72 65 67 69 73 74 65 72 2d 74 65 73 74 20 23 -register-test #
49b0: 66 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 6e 61 f run-id test-na
49c0: 6d 65 20 69 74 65 6d 2d 70 61 74 68 29 0a 09 09 me item-path)...
49d0: 20 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 (hash-table-se
49e0: 74 21 20 74 65 73 74 2d 72 65 67 69 73 74 65 72 t! test-register
49f0: 79 20 28 72 75 6e 73 3a 6d 61 6b 65 2d 66 75 6c y (runs:make-ful
4a00: 6c 2d 74 65 73 74 2d 6e 61 6d 65 20 74 65 73 74 l-test-name test
4a10: 2d 6e 61 6d 65 20 69 74 65 6d 2d 70 61 74 68 29 -name item-path)
4a20: 20 23 74 29 0a 09 09 20 20 28 74 68 72 65 61 64 #t)... (thread
4a30: 2d 73 6c 65 65 70 21 20 2a 67 6c 6f 62 61 6c 2d -sleep! *global-
4a40: 64 65 6c 74 61 2a 29 0a 09 09 20 20 28 6c 6f 6f delta*)... (loo
4a50: 70 20 28 63 61 72 20 6e 65 77 74 61 6c 29 28 63 p (car newtal)(c
4a60: 64 72 20 6e 65 77 74 61 6c 29 20 72 65 72 75 6e dr newtal) rerun
4a70: 73 29 29 0a 09 09 20 28 28 6e 6f 74 20 68 61 76 s))... ((not hav
4a80: 65 2d 72 65 73 6f 75 72 63 65 73 29 20 3b 3b 20 e-resources) ;;
4a90: 73 69 6d 70 6c 79 20 74 72 79 20 61 67 61 69 6e simply try again
4aa0: 20 61 66 74 65 72 20 77 61 69 74 69 6e 67 20 61 after waiting a
4ab0: 20 73 65 63 6f 6e 64 0a 09 09 20 20 28 74 68 72 second... (thr
4ac0: 65 61 64 2d 73 6c 65 65 70 21 20 28 2b 20 31 20 ead-sleep! (+ 1
4ad0: 2a 67 6c 6f 62 61 6c 2d 64 65 6c 74 61 2a 29 29 *global-delta*))
4ae0: 0a 09 09 20 20 28 64 65 62 75 67 3a 70 72 69 6e ... (debug:prin
4af0: 74 20 31 20 22 49 4e 46 4f 3a 20 6e 6f 20 72 65 t 1 "INFO: no re
4b00: 73 6f 75 72 63 65 73 20 74 6f 20 72 75 6e 20 6e sources to run n
4b10: 65 77 20 74 65 73 74 73 2c 20 77 61 69 74 69 6e ew tests, waitin
4b20: 67 20 2e 2e 2e 22 29 0a 09 09 20 20 3b 3b 20 63 g ...")... ;; c
4b30: 6f 75 6c 64 20 68 61 76 65 20 64 6f 6e 65 20 68 ould have done h
4b40: 65 64 20 74 61 6c 20 68 65 72 65 20 62 75 74 20 ed tal here but
4b50: 64 6f 69 6e 67 20 63 61 72 2f 63 64 72 20 6f 66 doing car/cdr of
4b60: 20 6e 65 77 74 61 6c 20 74 6f 20 72 6f 74 61 74 newtal to rotat
4b70: 65 20 74 65 73 74 73 0a 09 09 20 20 28 6c 6f 6f e tests... (loo
4b80: 70 20 28 63 61 72 20 6e 65 77 74 61 6c 29 28 63 p (car newtal)(c
4b90: 64 72 20 6e 65 77 74 61 6c 29 20 72 65 72 75 6e dr newtal) rerun
4ba0: 73 29 29 0a 09 09 20 28 28 61 6e 64 20 68 61 76 s))... ((and hav
4bb0: 65 2d 72 65 73 6f 75 72 63 65 73 0a 09 09 20 20 e-resources...
4bc0: 20 20 20 20 20 28 6f 72 20 28 6e 75 6c 6c 3f 20 (or (null?
4bd0: 70 72 65 72 65 71 73 2d 6e 6f 74 2d 6d 65 74 29 prereqs-not-met)
4be0: 0a 09 09 09 20 20 20 28 61 6e 64 20 28 65 71 3f .... (and (eq?
4bf0: 20 74 65 73 74 6d 6f 64 65 20 27 74 6f 70 6c 65 testmode 'tople
4c00: 76 65 6c 29 0a 09 09 09 09 28 6e 75 6c 6c 3f 20 vel).....(null?
4c10: 6e 6f 6e 2d 63 6f 6d 70 6c 65 74 65 64 29 29 29 non-completed)))
4c20: 29 0a 09 09 20 20 28 72 75 6e 3a 74 65 73 74 20 )... (run:test
4c30: 72 75 6e 2d 69 64 20 72 75 6e 6e 61 6d 65 20 6b run-id runname k
4c40: 65 79 76 61 6c 6c 73 74 20 74 65 73 74 2d 72 65 eyvallst test-re
4c50: 63 6f 72 64 20 66 6c 61 67 73 20 23 66 29 0a 09 cord flags #f)..
4c60: 09 20 20 28 74 68 72 65 61 64 2d 73 6c 65 65 70 . (thread-sleep
4c70: 21 20 2a 67 6c 6f 62 61 6c 2d 64 65 6c 74 61 2a ! *global-delta*
4c80: 29 0a 09 09 20 20 28 69 66 20 28 6e 6f 74 20 28 )... (if (not (
4c90: 6e 75 6c 6c 3f 20 74 61 6c 29 29 0a 09 09 20 20 null? tal))...
4ca0: 20 20 20 20 28 6c 6f 6f 70 20 28 63 61 72 20 74 (loop (car t
4cb0: 61 6c 29 28 63 64 72 20 74 61 6c 29 20 72 65 72 al)(cdr tal) rer
4cc0: 75 6e 73 29 29 29 0a 09 09 20 28 65 6c 73 65 20 uns)))... (else
4cd0: 3b 3b 20 6d 75 73 74 20 62 65 20 77 65 20 68 61 ;; must be we ha
4ce0: 76 65 20 75 6e 6d 65 74 20 70 72 65 72 65 71 75 ve unmet prerequ
4cf0: 69 73 69 74 65 73 0a 09 09 20 20 20 20 28 64 65 isites... (de
4d00: 62 75 67 3a 70 72 69 6e 74 20 34 20 22 46 41 49 bug:print 4 "FAI
4d10: 4c 53 3a 20 22 20 66 61 69 6c 73 29 0a 09 09 20 LS: " fails)...
4d20: 20 20 20 3b 3b 20 49 66 20 6f 6e 65 20 6f 72 20 ;; If one or
4d30: 6d 6f 72 65 20 6f 66 20 74 68 65 20 70 72 65 72 more of the prer
4d40: 65 71 73 2d 6e 6f 74 2d 6d 65 74 20 61 72 65 20 eqs-not-met are
4d50: 46 41 49 4c 20 74 68 65 6e 20 77 65 20 63 61 6e FAIL then we can
4d60: 20 69 73 73 75 65 0a 09 09 20 20 20 20 3b 3b 20 issue... ;;
4d70: 61 20 6d 65 73 73 61 67 65 20 61 6e 64 20 64 72 a message and dr
4d80: 6f 70 20 68 65 64 20 66 72 6f 6d 20 74 68 65 20 op hed from the
4d90: 69 74 65 6d 73 20 74 6f 20 62 65 20 70 72 6f 63 items to be proc
4da0: 65 73 73 65 64 2e 0a 09 09 20 20 20 20 28 69 66 essed.... (if
4db0: 20 28 6e 75 6c 6c 3f 20 66 61 69 6c 73 29 0a 09 (null? fails)..
4dc0: 09 09 28 62 65 67 69 6e 0a 09 09 09 20 20 3b 3b ..(begin.... ;;
4dd0: 20 63 6f 75 6c 64 6e 27 74 20 72 75 6e 2c 20 74 couldn't run, t
4de0: 61 6b 65 20 61 20 62 72 65 61 74 68 65 72 0a 09 ake a breather..
4df0: 09 09 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 .. (debug:print
4e00: 20 34 20 22 49 4e 46 4f 3a 20 53 68 6f 75 6c 64 4 "INFO: Should
4e10: 6e 27 74 20 72 65 61 6c 6c 79 20 67 65 74 20 68 n't really get h
4e20: 65 72 65 2c 20 72 61 63 65 20 63 6f 6e 64 69 74 ere, race condit
4e30: 69 6f 6e 3f 20 55 6e 61 62 6c 65 20 74 6f 20 6c ion? Unable to l
4e40: 61 75 6e 63 68 20 6d 6f 72 65 20 74 65 73 74 73 aunch more tests
4e50: 20 61 74 20 74 68 69 73 20 6d 6f 6d 65 6e 74 2c at this moment,
4e60: 20 6b 69 6c 6c 69 6e 67 20 74 69 6d 65 20 2e 2e killing time ..
4e70: 2e 22 29 0a 09 09 09 20 20 28 74 68 72 65 61 64 .").... (thread
4e80: 2d 73 6c 65 65 70 21 20 28 2b 20 31 20 2a 67 6c -sleep! (+ 1 *gl
4e90: 6f 62 61 6c 2d 64 65 6c 74 61 2a 29 29 20 3b 3b obal-delta*)) ;;
4ea0: 20 6c 6f 6e 67 20 73 6c 65 65 70 20 68 65 72 65 long sleep here
4eb0: 20 2d 20 6e 6f 20 72 65 73 6f 75 72 63 65 73 2c - no resources,
4ec0: 20 6d 61 79 20 61 73 20 77 65 6c 6c 20 62 65 20 may as well be
4ed0: 70 61 74 69 65 6e 74 0a 09 09 09 20 20 3b 3b 20 patient.... ;;
4ee0: 77 65 20 6d 61 64 65 20 6e 65 77 20 74 61 6c 20 we made new tal
4ef0: 62 79 20 73 74 69 63 6b 69 6e 67 20 68 65 64 20 by sticking hed
4f00: 61 74 20 74 68 65 20 62 61 63 6b 20 6f 66 20 74 at the back of t
4f10: 68 65 20 6c 69 73 74 0a 09 09 09 20 20 28 6c 6f he list.... (lo
4f20: 6f 70 20 28 63 61 72 20 6e 65 77 74 61 6c 29 28 op (car newtal)(
4f30: 63 64 72 20 6e 65 77 74 61 6c 29 20 72 65 72 75 cdr newtal) reru
4f40: 6e 73 29 29 0a 09 09 09 3b 3b 20 74 68 65 20 77 ns))....;; the w
4f50: 61 69 74 6f 6e 20 69 73 20 46 41 49 4c 20 73 6f aiton is FAIL so
4f60: 20 6e 6f 20 70 6f 69 6e 74 20 69 6e 20 74 72 79 no point in try
4f70: 69 6e 67 20 74 6f 20 72 75 6e 20 68 65 64 20 65 ing to run hed e
4f80: 76 65 72 20 61 67 61 69 6e 0a 09 09 09 28 69 66 ver again....(if
4f90: 20 28 6e 6f 74 20 28 6e 75 6c 6c 3f 20 74 61 6c (not (null? tal
4fa0: 29 29 0a 09 09 09 20 20 20 20 28 69 66 20 28 76 )).... (if (v
4fb0: 65 63 74 6f 72 3f 20 68 65 64 29 0a 09 09 09 09 ector? hed).....
4fc0: 28 62 65 67 69 6e 20 28 64 65 62 75 67 3a 70 72 (begin (debug:pr
4fd0: 69 6e 74 20 31 20 22 57 41 52 4e 3a 20 44 72 6f int 1 "WARN: Dro
4fe0: 70 70 69 6e 67 20 74 65 73 74 20 22 20 28 64 62 pping test " (db
4ff0: 3a 74 65 73 74 2d 67 65 74 2d 74 65 73 74 6e 61 :test-get-testna
5000: 6d 65 20 68 65 64 29 20 22 2f 22 20 28 64 62 3a me hed) "/" (db:
5010: 74 65 73 74 2d 67 65 74 2d 69 74 65 6d 2d 70 61 test-get-item-pa
5020: 74 68 20 68 65 64 29 0a 09 09 09 09 09 09 20 20 th hed).......
5030: 20 20 22 20 66 72 6f 6d 20 74 68 65 20 6c 61 75 " from the lau
5040: 6e 63 68 20 6c 69 73 74 20 61 73 20 69 74 20 68 nch list as it h
5050: 61 73 20 70 72 65 72 65 71 75 69 73 74 65 73 20 as prerequistes
5060: 74 68 61 74 20 61 72 65 20 46 41 49 4c 22 29 0a that are FAIL").
5070: 09 09 09 09 20 20 20 20 20 20 20 28 74 68 72 65 .... (thre
5080: 61 64 2d 73 6c 65 65 70 21 20 2a 67 6c 6f 62 61 ad-sleep! *globa
5090: 6c 2d 64 65 6c 74 61 2a 29 0a 09 09 09 09 20 20 l-delta*).....
50a0: 20 20 20 20 20 28 6c 6f 6f 70 20 28 63 61 72 20 (loop (car
50b0: 74 61 6c 29 28 63 64 72 20 74 61 6c 29 20 28 63 tal)(cdr tal) (c
50c0: 6f 6e 73 20 68 65 64 20 72 65 72 75 6e 73 29 29 ons hed reruns))
50d0: 29 0a 09 09 09 09 28 62 65 67 69 6e 0a 09 09 09 ).....(begin....
50e0: 09 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 . (debug:print
50f0: 31 20 22 57 41 52 4e 3a 20 54 65 73 74 20 6e 6f 1 "WARN: Test no
5100: 74 20 70 72 6f 63 65 73 73 65 64 20 63 6f 72 72 t processed corr
5110: 65 63 74 6c 79 2e 20 43 6f 75 6c 64 20 62 65 20 ectly. Could be
5120: 61 20 72 61 63 65 20 63 6f 6e 64 69 74 69 6f 6e a race condition
5130: 20 69 6e 20 79 6f 75 72 20 74 65 73 74 20 69 6d in your test im
5140: 70 6c 65 6d 65 6e 74 61 74 69 6f 6e 3f 20 22 20 plementation? "
5150: 68 65 64 29 20 3b 3b 20 20 22 20 61 73 20 69 74 hed) ;; " as it
5160: 20 68 61 73 20 70 72 65 72 65 71 75 69 73 74 65 has prerequiste
5170: 73 20 74 68 61 74 20 61 72 65 20 46 41 49 4c 2e s that are FAIL.
5180: 20 28 4e 4f 54 45 3a 20 68 65 64 20 69 73 20 6e (NOTE: hed is n
5190: 6f 74 20 61 20 76 65 63 74 6f 72 29 22 29 0a 09 ot a vector)")..
51a0: 09 09 09 20 20 28 74 68 72 65 61 64 2d 73 6c 65 ... (thread-sle
51b0: 65 70 21 20 2a 67 6c 6f 62 61 6c 2d 64 65 6c 74 ep! *global-delt
51c0: 61 2a 29 0a 09 09 09 09 20 20 28 6c 6f 6f 70 20 a*)..... (loop
51d0: 68 65 64 20 74 61 6c 20 72 65 72 75 6e 73 29 29 hed tal reruns))
51e0: 29 29 29 29 29 29 29 20 3b 3b 20 45 4e 44 20 4f ))))))) ;; END O
51f0: 46 20 49 4e 4e 45 52 20 43 4f 4e 44 0a 09 20 20 F INNER COND..
5200: 20 20 20 0a 09 20 20 20 20 20 3b 3b 20 63 61 73 .. ;; cas
5210: 65 20 77 68 65 72 65 20 61 6e 20 69 74 65 6d 73 e where an items
5220: 20 63 61 6d 65 20 69 6e 20 61 73 20 61 20 6c 69 came in as a li
5230: 73 74 20 62 65 65 6e 20 70 72 6f 63 65 73 73 65 st been processe
5240: 64 0a 09 20 20 20 20 20 28 28 61 6e 64 20 28 6c d.. ((and (l
5250: 69 73 74 3f 20 69 74 65 6d 73 29 20 20 20 20 20 ist? items)
5260: 3b 3b 20 74 68 75 73 20 77 65 20 6b 6e 6f 77 20 ;; thus we know
5270: 6f 75 72 20 69 74 65 6d 73 20 61 72 65 20 61 6c our items are al
5280: 72 65 61 64 79 20 63 61 6c 63 75 6c 61 74 65 64 ready calculated
5290: 0a 09 09 20 20 20 28 6e 6f 74 20 20 20 69 74 65 ... (not ite
52a0: 6d 64 61 74 29 29 20 3b 3b 20 61 6e 64 20 6e 6f mdat)) ;; and no
52b0: 74 20 79 65 74 20 65 78 70 61 6e 64 65 64 20 69 t yet expanded i
52c0: 6e 74 6f 20 74 68 65 20 6c 69 73 74 20 6f 66 20 nto the list of
52d0: 74 68 69 6e 67 73 20 74 6f 20 62 65 20 64 6f 6e things to be don
52e0: 65 0a 09 20 20 20 20 20 20 28 69 66 20 28 61 6e e.. (if (an
52f0: 64 20 28 3e 3d 20 2a 76 65 72 62 6f 73 69 74 79 d (>= *verbosity
5300: 2a 20 31 29 0a 09 09 20 20 20 20 20 20 20 28 3e * 1)... (>
5310: 20 28 6c 65 6e 67 74 68 20 69 74 65 6d 73 29 20 (length items)
5320: 30 29 0a 09 09 20 20 20 20 20 20 20 28 3e 20 28 0)... (> (
5330: 6c 65 6e 67 74 68 20 28 63 61 72 20 69 74 65 6d length (car item
5340: 73 29 29 20 30 29 29 0a 09 09 20 20 28 70 70 20 s)) 0))... (pp
5350: 69 74 65 6d 73 29 29 0a 09 20 20 20 20 20 20 28 items)).. (
5360: 66 6f 72 2d 65 61 63 68 0a 09 20 20 20 20 20 20 for-each..
5370: 20 28 6c 61 6d 62 64 61 20 28 6d 79 2d 69 74 65 (lambda (my-ite
5380: 6d 64 61 74 29 0a 09 09 20 28 6c 65 74 2a 20 28 mdat)... (let* (
5390: 28 6e 65 77 2d 74 65 73 74 2d 72 65 63 6f 72 64 (new-test-record
53a0: 20 28 6c 65 74 20 28 28 6e 65 77 72 65 63 20 28 (let ((newrec (
53b0: 6d 61 6b 65 2d 74 65 73 74 73 3a 74 65 73 74 71 make-tests:testq
53c0: 75 65 75 65 29 29 29 0a 09 09 09 09 09 20 20 20 ueue)))......
53d0: 28 76 65 63 74 6f 72 2d 63 6f 70 79 21 20 74 65 (vector-copy! te
53e0: 73 74 2d 72 65 63 6f 72 64 20 6e 65 77 72 65 63 st-record newrec
53f0: 29 0a 09 09 09 09 09 20 20 20 6e 65 77 72 65 63 )...... newrec
5400: 29 29 0a 09 09 09 28 6d 79 2d 69 74 65 6d 2d 70 ))....(my-item-p
5410: 61 74 68 20 28 69 74 65 6d 2d 6c 69 73 74 2d 3e ath (item-list->
5420: 70 61 74 68 20 6d 79 2d 69 74 65 6d 64 61 74 29 path my-itemdat)
5430: 29 29 0a 09 09 20 20 20 28 69 66 20 28 70 61 74 ))... (if (pat
5440: 74 2d 6c 69 73 74 2d 6d 61 74 63 68 20 6d 79 2d t-list-match my-
5450: 69 74 65 6d 2d 70 61 74 68 20 69 74 65 6d 2d 70 item-path item-p
5460: 61 74 74 73 29 20 20 20 20 20 20 20 20 20 20 20 atts)
5470: 3b 3b 20 79 65 73 2c 20 77 65 20 77 61 6e 74 20 ;; yes, we want
5480: 74 6f 20 70 72 6f 63 65 73 73 20 74 68 69 73 20 to process this
5490: 69 74 65 6d 2c 20 4e 4f 54 45 3a 20 53 68 6f 75 item, NOTE: Shou
54a0: 6c 64 20 6e 6f 74 20 6e 65 65 64 20 74 68 69 73 ld not need this
54b0: 20 63 68 65 63 6b 20 68 65 72 65 21 0a 09 09 20 check here!...
54c0: 20 20 20 20 20 20 28 6c 65 74 20 28 28 6e 65 77 (let ((new
54d0: 74 65 73 74 6e 61 6d 65 20 28 72 75 6e 73 3a 6d testname (runs:m
54e0: 61 6b 65 2d 66 75 6c 6c 2d 74 65 73 74 2d 6e 61 ake-full-test-na
54f0: 6d 65 20 68 65 64 20 6d 79 2d 69 74 65 6d 2d 70 me hed my-item-p
5500: 61 74 68 29 29 29 20 20 20 20 3b 3b 20 74 65 73 ath))) ;; tes
5510: 74 20 6e 61 6d 65 73 20 61 72 65 20 75 6e 69 71 t names are uniq
5520: 75 65 20 6f 6e 20 74 65 73 74 6e 61 6d 65 2f 69 ue on testname/i
5530: 74 65 6d 2d 70 61 74 68 0a 09 09 09 20 28 74 65 tem-path.... (te
5540: 73 74 73 3a 74 65 73 74 71 75 65 75 65 2d 73 65 sts:testqueue-se
5550: 74 2d 69 74 65 6d 73 21 20 20 20 20 20 6e 65 77 t-items! new
5560: 2d 74 65 73 74 2d 72 65 63 6f 72 64 20 23 66 29 -test-record #f)
5570: 0a 09 09 09 20 28 74 65 73 74 73 3a 74 65 73 74 .... (tests:test
5580: 71 75 65 75 65 2d 73 65 74 2d 69 74 65 6d 64 61 queue-set-itemda
5590: 74 21 20 20 20 6e 65 77 2d 74 65 73 74 2d 72 65 t! new-test-re
55a0: 63 6f 72 64 20 6d 79 2d 69 74 65 6d 64 61 74 29 cord my-itemdat)
55b0: 0a 09 09 09 20 28 74 65 73 74 73 3a 74 65 73 74 .... (tests:test
55c0: 71 75 65 75 65 2d 73 65 74 2d 69 74 65 6d 5f 70 queue-set-item_p
55d0: 61 74 68 21 20 6e 65 77 2d 74 65 73 74 2d 72 65 ath! new-test-re
55e0: 63 6f 72 64 20 6d 79 2d 69 74 65 6d 2d 70 61 74 cord my-item-pat
55f0: 68 29 0a 09 09 09 20 28 68 61 73 68 2d 74 61 62 h).... (hash-tab
5600: 6c 65 2d 73 65 74 21 20 74 65 73 74 2d 72 65 63 le-set! test-rec
5610: 6f 72 64 73 20 6e 65 77 74 65 73 74 6e 61 6d 65 ords newtestname
5620: 20 6e 65 77 2d 74 65 73 74 2d 72 65 63 6f 72 64 new-test-record
5630: 29 0a 09 09 09 20 28 73 65 74 21 20 74 61 6c 20 ).... (set! tal
5640: 28 63 6f 6e 73 20 6e 65 77 74 65 73 74 6e 61 6d (cons newtestnam
5650: 65 20 74 61 6c 29 29 29 29 29 29 20 3b 3b 20 73 e tal)))))) ;; s
5660: 69 6e 63 65 20 74 68 65 73 65 20 61 72 65 20 69 ince these are i
5670: 74 65 6d 69 7a 65 64 20 63 72 65 61 74 65 20 6e temized create n
5680: 65 77 20 74 65 73 74 20 6e 61 6d 65 73 20 74 65 ew test names te
5690: 73 74 6e 61 6d 65 2f 69 74 65 6d 70 61 74 68 0a stname/itempath.
56a0: 09 20 20 20 20 20 20 20 69 74 65 6d 73 29 0a 09 . items)..
56b0: 20 20 20 20 20 20 28 69 66 20 28 6e 6f 74 20 28 (if (not (
56c0: 6e 75 6c 6c 3f 20 74 61 6c 29 29 0a 09 09 20 20 null? tal))...
56d0: 28 62 65 67 69 6e 0a 09 09 20 20 20 20 28 74 68 (begin... (th
56e0: 72 65 61 64 2d 73 6c 65 65 70 21 20 2a 67 6c 6f read-sleep! *glo
56f0: 62 61 6c 2d 64 65 6c 74 61 2a 29 0a 09 09 20 20 bal-delta*)...
5700: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 34 (debug:print 4
5710: 20 22 49 4e 46 4f 3a 20 45 6e 64 20 6f 66 20 69 "INFO: End of i
5720: 74 65 6d 73 20 6c 69 73 74 2c 20 6c 6f 6f 70 69 tems list, loopi
5730: 6e 67 20 77 69 74 68 20 6e 65 78 74 22 29 0a 09 ng with next")..
5740: 09 20 20 20 20 28 6c 6f 6f 70 20 28 63 61 72 20 . (loop (car
5750: 74 61 6c 29 28 63 64 72 20 74 61 6c 29 20 72 65 tal)(cdr tal) re
5760: 72 75 6e 73 29 29 29 29 0a 0a 09 20 20 20 20 20 runs))))...
5770: 3b 3b 20 69 66 20 69 74 65 6d 73 20 69 73 20 61 ;; if items is a
5780: 20 70 72 6f 63 20 74 68 65 6e 20 6e 65 65 64 20 proc then need
5790: 74 6f 20 72 75 6e 20 69 74 65 6d 73 3a 67 65 74 to run items:get
57a0: 2d 69 74 65 6d 73 2d 66 72 6f 6d 2d 63 6f 6e 66 -items-from-conf
57b0: 69 67 2c 20 67 65 74 20 74 68 65 20 6c 69 73 74 ig, get the list
57c0: 20 61 6e 64 20 6c 6f 6f 70 20 0a 09 20 20 20 20 and loop ..
57d0: 20 3b 3b 20 20 20 20 2d 20 62 75 74 20 6f 6e 6c ;; - but onl
57e0: 79 20 64 6f 20 74 68 61 74 20 69 66 20 72 65 73 y do that if res
57f0: 6f 75 72 63 65 73 20 65 78 69 73 74 20 74 6f 20 ources exist to
5800: 6b 69 63 6b 20 6f 66 66 20 74 68 65 20 6a 6f 62 kick off the job
5810: 0a 09 20 20 20 20 20 28 28 6f 72 20 28 70 72 6f .. ((or (pro
5820: 63 65 64 75 72 65 3f 20 69 74 65 6d 73 29 28 65 cedure? items)(e
5830: 71 3f 20 69 74 65 6d 73 20 27 68 61 76 65 2d 70 q? items 'have-p
5840: 72 6f 63 65 64 75 72 65 29 29 0a 09 20 20 20 20 rocedure))..
5850: 20 20 28 6c 65 74 20 28 28 63 61 6e 2d 72 75 6e (let ((can-run
5860: 2d 6d 6f 72 65 20 20 20 20 28 6f 70 65 6e 2d 72 -more (open-r
5870: 75 6e 2d 63 6c 6f 73 65 20 72 75 6e 73 3a 63 61 un-close runs:ca
5880: 6e 2d 72 75 6e 2d 6d 6f 72 65 2d 74 65 73 74 73 n-run-more-tests
5890: 20 23 66 20 74 65 73 74 2d 72 65 63 6f 72 64 29 #f test-record)
58a0: 29 29 0a 09 09 28 69 66 20 63 61 6e 2d 72 75 6e ))...(if can-run
58b0: 2d 6d 6f 72 65 0a 09 09 20 20 20 20 28 6c 65 74 -more... (let
58c0: 2a 20 28 28 70 72 65 72 65 71 73 2d 6e 6f 74 2d * ((prereqs-not-
58d0: 6d 65 74 20 28 6f 70 65 6e 2d 72 75 6e 2d 63 6c met (open-run-cl
58e0: 6f 73 65 20 64 62 3a 67 65 74 2d 70 72 65 72 65 ose db:get-prere
58f0: 71 73 2d 6e 6f 74 2d 6d 65 74 20 23 66 20 72 75 qs-not-met #f ru
5900: 6e 2d 69 64 20 77 61 69 74 6f 6e 73 20 69 74 65 n-id waitons ite
5910: 6d 2d 70 61 74 68 20 6d 6f 64 65 3a 20 74 65 73 m-path mode: tes
5920: 74 6d 6f 64 65 29 29 0a 09 09 09 20 20 20 28 66 tmode)).... (f
5930: 61 69 6c 73 20 20 20 20 20 20 20 20 20 20 20 28 ails (
5940: 72 75 6e 73 3a 63 61 6c 63 2d 66 61 69 6c 73 20 runs:calc-fails
5950: 70 72 65 72 65 71 73 2d 6e 6f 74 2d 6d 65 74 29 prereqs-not-met)
5960: 29 0a 09 09 09 20 20 20 28 6e 6f 6e 2d 63 6f 6d ).... (non-com
5970: 70 6c 65 74 65 64 20 20 20 28 72 75 6e 73 3a 63 pleted (runs:c
5980: 61 6c 63 2d 6e 6f 74 2d 63 6f 6d 70 6c 65 74 65 alc-not-complete
5990: 64 20 70 72 65 72 65 71 73 2d 6e 6f 74 2d 6d 65 d prereqs-not-me
59a0: 74 29 29 29 0a 09 09 20 20 20 20 20 20 28 64 65 t)))... (de
59b0: 62 75 67 3a 70 72 69 6e 74 20 38 20 22 49 4e 46 bug:print 8 "INF
59c0: 4f 3a 20 63 61 6e 2d 72 75 6e 2d 6d 6f 72 65 3a O: can-run-more:
59d0: 20 22 20 63 61 6e 2d 72 75 6e 2d 6d 6f 72 65 0a " can-run-more.
59e0: 09 09 09 09 20 20 20 22 5c 6e 20 74 65 73 74 6e .... "\n testn
59f0: 61 6d 65 3a 20 20 20 20 20 20 20 20 22 20 68 65 ame: " he
5a00: 64 0a 09 09 09 09 20 20 20 22 5c 6e 20 70 72 65 d..... "\n pre
5a10: 72 65 71 73 2d 6e 6f 74 2d 6d 65 74 3a 20 22 20 reqs-not-met: "
5a20: 28 72 75 6e 73 3a 70 72 65 74 74 79 2d 73 74 72 (runs:pretty-str
5a30: 69 6e 67 20 70 72 65 72 65 71 73 2d 6e 6f 74 2d ing prereqs-not-
5a40: 6d 65 74 29 0a 09 09 09 09 20 20 20 22 5c 6e 20 met)..... "\n
5a50: 6e 6f 6e 2d 63 6f 6d 70 6c 65 74 65 64 3a 20 20 non-completed:
5a60: 20 22 20 28 72 75 6e 73 3a 70 72 65 74 74 79 2d " (runs:pretty-
5a70: 73 74 72 69 6e 67 20 6e 6f 6e 2d 63 6f 6d 70 6c string non-compl
5a80: 65 74 65 64 29 20 0a 09 09 09 09 20 20 20 22 5c eted) ..... "\
5a90: 6e 20 66 61 69 6c 73 3a 20 20 20 20 20 20 20 20 n fails:
5aa0: 20 20 20 22 20 28 72 75 6e 73 3a 70 72 65 74 74 " (runs:prett
5ab0: 79 2d 73 74 72 69 6e 67 20 66 61 69 6c 73 29 0a y-string fails).
5ac0: 09 09 09 09 20 20 20 22 5c 6e 20 74 65 73 74 6d .... "\n testm
5ad0: 6f 64 65 3a 20 20 20 20 20 20 20 20 22 20 74 65 ode: " te
5ae0: 73 74 6d 6f 64 65 0a 09 09 09 09 20 20 20 22 5c stmode..... "\
5af0: 6e 20 6e 75 6d 2d 72 65 74 72 69 65 73 3a 20 20 n num-retries:
5b00: 20 20 20 22 20 6e 75 6d 2d 72 65 74 72 69 65 73 " num-retries
5b10: 0a 09 09 09 09 20 20 20 22 5c 6e 20 28 65 71 3f ..... "\n (eq?
5b20: 20 74 65 73 74 6d 6f 64 65 20 27 74 6f 70 6c 65 testmode 'tople
5b30: 76 65 6c 29 3a 20 22 20 28 65 71 3f 20 74 65 73 vel): " (eq? tes
5b40: 74 6d 6f 64 65 20 27 74 6f 70 6c 65 76 65 6c 29 tmode 'toplevel)
5b50: 0a 09 09 09 09 20 20 20 22 5c 6e 20 28 6e 75 6c ..... "\n (nul
5b60: 6c 3f 20 6e 6f 6e 2d 63 6f 6d 70 6c 65 74 65 64 l? non-completed
5b70: 29 3a 20 20 20 20 22 20 28 6e 75 6c 6c 3f 20 6e ): " (null? n
5b80: 6f 6e 2d 63 6f 6d 70 6c 65 74 65 64 29 0a 09 09 on-completed)...
5b90: 09 09 20 20 20 22 5c 6e 20 72 65 72 75 6e 73 3a .. "\n reruns:
5ba0: 20 22 20 72 65 72 75 6e 73 29 0a 0a 09 09 20 20 " reruns)....
5bb0: 20 20 20 20 28 63 6f 6e 64 20 3b 3b 20 49 4e 4e (cond ;; INN
5bc0: 45 52 20 43 4f 4e 44 20 23 32 0a 09 09 20 20 20 ER COND #2...
5bd0: 20 20 20 20 28 28 6f 72 20 28 6e 75 6c 6c 3f 20 ((or (null?
5be0: 70 72 65 72 65 71 73 2d 6e 6f 74 2d 6d 65 74 29 prereqs-not-met)
5bf0: 20 3b 3b 20 61 6c 6c 20 70 72 65 72 65 71 73 20 ;; all prereqs
5c00: 6d 65 74 2c 20 66 69 72 65 20 6f 66 66 20 74 68 met, fire off th
5c10: 65 20 74 65 73 74 0a 09 09 09 20 20 20 20 3b 3b e test.... ;;
5c20: 20 6f 72 2c 20 69 66 20 69 74 20 69 73 20 61 20 or, if it is a
5c30: 27 74 6f 70 6c 65 76 65 6c 20 74 65 73 74 20 61 'toplevel test a
5c40: 6e 64 20 61 6c 6c 20 70 72 65 72 65 71 73 20 6e nd all prereqs n
5c50: 6f 74 20 6d 65 74 20 61 72 65 20 43 4f 4d 50 4c ot met are COMPL
5c60: 45 54 45 44 20 74 68 65 6e 20 6c 61 75 6e 63 68 ETED then launch
5c70: 0a 09 09 09 20 20 20 20 28 61 6e 64 20 28 65 71 .... (and (eq
5c80: 3f 20 74 65 73 74 6d 6f 64 65 20 27 74 6f 70 6c ? testmode 'topl
5c90: 65 76 65 6c 29 0a 09 09 09 09 20 28 6e 75 6c 6c evel)..... (null
5ca0: 3f 20 6e 6f 6e 2d 63 6f 6d 70 6c 65 74 65 64 29 ? non-completed)
5cb0: 29 29 0a 09 09 09 28 6c 65 74 20 28 28 74 65 73 ))....(let ((tes
5cc0: 74 2d 6e 61 6d 65 20 28 74 65 73 74 73 3a 74 65 t-name (tests:te
5cd0: 73 74 71 75 65 75 65 2d 67 65 74 2d 74 65 73 74 stqueue-get-test
5ce0: 6e 61 6d 65 20 74 65 73 74 2d 72 65 63 6f 72 64 name test-record
5cf0: 29 29 29 0a 09 09 09 20 20 28 73 65 74 65 6e 76 ))).... (setenv
5d00: 20 22 4d 54 5f 54 45 53 54 5f 4e 41 4d 45 22 20 "MT_TEST_NAME"
5d10: 74 65 73 74 2d 6e 61 6d 65 29 20 3b 3b 20 0a 09 test-name) ;; ..
5d20: 09 09 20 20 28 73 65 74 65 6e 76 20 22 4d 54 5f .. (setenv "MT_
5d30: 52 55 4e 4e 41 4d 45 22 20 20 20 72 75 6e 6e 61 RUNNAME" runna
5d40: 6d 65 29 0a 09 09 09 20 20 28 6f 70 65 6e 2d 72 me).... (open-r
5d50: 75 6e 2d 63 6c 6f 73 65 20 73 65 74 2d 6d 65 67 un-close set-meg
5d60: 61 74 65 73 74 2d 65 6e 76 2d 76 61 72 73 20 23 atest-env-vars #
5d70: 66 20 72 75 6e 2d 69 64 29 20 3b 3b 20 74 68 65 f run-id) ;; the
5d80: 73 65 20 6d 61 79 20 62 65 20 6e 65 65 64 65 64 se may be needed
5d90: 20 62 79 20 74 68 65 20 6c 61 75 6e 63 68 69 6e by the launchin
5da0: 67 20 70 72 6f 63 65 73 73 0a 09 09 09 20 20 28 g process.... (
5db0: 6c 65 74 20 28 28 69 74 65 6d 73 2d 6c 69 73 74 let ((items-list
5dc0: 20 28 69 74 65 6d 73 3a 67 65 74 2d 69 74 65 6d (items:get-item
5dd0: 73 2d 66 72 6f 6d 2d 63 6f 6e 66 69 67 20 74 63 s-from-config tc
5de0: 6f 6e 66 69 67 29 29 29 0a 09 09 09 20 20 20 20 onfig)))....
5df0: 28 69 66 20 28 6c 69 73 74 3f 20 69 74 65 6d 73 (if (list? items
5e00: 2d 6c 69 73 74 29 0a 09 09 09 09 28 62 65 67 69 -list).....(begi
5e10: 6e 0a 09 09 09 09 20 20 28 74 65 73 74 73 3a 74 n..... (tests:t
5e20: 65 73 74 71 75 65 75 65 2d 73 65 74 2d 69 74 65 estqueue-set-ite
5e30: 6d 73 21 20 74 65 73 74 2d 72 65 63 6f 72 64 20 ms! test-record
5e40: 69 74 65 6d 73 2d 6c 69 73 74 29 0a 09 09 09 09 items-list).....
5e50: 20 20 28 74 68 72 65 61 64 2d 73 6c 65 65 70 21 (thread-sleep!
5e60: 20 2a 67 6c 6f 62 61 6c 2d 64 65 6c 74 61 2a 29 *global-delta*)
5e70: 0a 09 09 09 09 20 20 28 6c 6f 6f 70 20 68 65 64 ..... (loop hed
5e80: 20 74 61 6c 20 72 65 72 75 6e 73 29 29 0a 09 09 tal reruns))...
5e90: 09 09 28 62 65 67 69 6e 0a 09 09 09 09 20 20 28 ..(begin..... (
5ea0: 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 22 45 debug:print 0 "E
5eb0: 52 52 4f 52 3a 20 54 68 65 20 70 72 6f 63 20 66 RROR: The proc f
5ec0: 72 6f 6d 20 72 65 61 64 69 6e 67 20 74 68 65 20 rom reading the
5ed0: 73 65 74 75 70 20 64 69 64 20 6e 6f 74 20 79 69 setup did not yi
5ee0: 65 6c 64 20 61 20 6c 69 73 74 20 2d 20 70 6c 65 eld a list - ple
5ef0: 61 73 65 20 72 65 70 6f 72 74 20 74 68 69 73 22 ase report this"
5f00: 29 0a 09 09 09 09 20 20 28 65 78 69 74 20 31 29 )..... (exit 1)
5f10: 29 29 29 29 29 0a 09 09 20 20 20 20 20 20 20 28 )))))... (
5f20: 28 6e 75 6c 6c 3f 20 66 61 69 6c 73 29 0a 09 09 (null? fails)...
5f30: 09 28 64 65 62 75 67 3a 70 72 69 6e 74 20 34 20 .(debug:print 4
5f40: 22 49 4e 46 4f 3a 20 66 61 69 6c 73 20 69 73 20 "INFO: fails is
5f50: 6e 75 6c 6c 2c 20 6d 6f 76 69 6e 67 20 6f 6e 20 null, moving on
5f60: 69 6e 20 74 68 65 20 71 75 65 75 65 20 62 75 74 in the queue but
5f70: 20 6b 65 65 70 69 6e 67 20 22 20 68 65 64 20 22 keeping " hed "
5f80: 20 66 6f 72 20 6e 6f 77 22 29 0a 09 09 09 28 74 for now")....(t
5f90: 68 72 65 61 64 2d 73 6c 65 65 70 21 20 2a 67 6c hread-sleep! *gl
5fa0: 6f 62 61 6c 2d 64 65 6c 74 61 2a 29 0a 09 09 09 obal-delta*)....
5fb0: 28 6c 6f 6f 70 20 28 63 61 72 20 6e 65 77 74 61 (loop (car newta
5fc0: 6c 29 28 63 64 72 20 6e 65 77 74 61 6c 29 20 72 l)(cdr newtal) r
5fd0: 65 72 75 6e 73 29 29 20 3b 3b 20 61 6e 20 69 73 eruns)) ;; an is
5fe0: 73 75 65 20 77 69 74 68 20 70 72 65 72 65 71 73 sue with prereqs
5ff0: 20 6e 6f 74 20 79 65 74 20 6d 65 74 3f 0a 09 09 not yet met?...
6000: 20 20 20 20 20 20 20 28 28 61 6e 64 20 28 6e 6f ((and (no
6010: 74 20 28 6e 75 6c 6c 3f 20 66 61 69 6c 73 29 29 t (null? fails))
6020: 28 65 71 3f 20 74 65 73 74 6d 6f 64 65 20 27 6e (eq? testmode 'n
6030: 6f 72 6d 61 6c 29 29 0a 09 09 09 28 64 65 62 75 ormal))....(debu
6040: 67 3a 70 72 69 6e 74 20 31 20 22 49 4e 46 4f 3a g:print 1 "INFO:
6050: 20 74 65 73 74 20 22 20 20 68 65 64 20 22 20 28 test " hed " (
6060: 6d 6f 64 65 3d 22 20 74 65 73 74 6d 6f 64 65 20 mode=" testmode
6070: 22 29 20 68 61 73 20 66 61 69 6c 65 64 20 70 72 ") has failed pr
6080: 65 72 65 71 75 69 73 69 74 65 28 73 29 3b 20 22 erequisite(s); "
6090: 0a 09 09 09 09 20 20 20 20 20 28 73 74 72 69 6e ..... (strin
60a0: 67 2d 69 6e 74 65 72 73 70 65 72 73 65 20 28 6d g-intersperse (m
60b0: 61 70 20 28 6c 61 6d 62 64 61 20 28 74 29 28 63 ap (lambda (t)(c
60c0: 6f 6e 63 20 28 64 62 3a 74 65 73 74 2d 67 65 74 onc (db:test-get
60d0: 2d 74 65 73 74 6e 61 6d 65 20 74 29 20 22 3a 22 -testname t) ":"
60e0: 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 73 74 (db:test-get-st
60f0: 61 74 65 20 74 29 22 2f 22 28 64 62 3a 74 65 73 ate t)"/"(db:tes
6100: 74 2d 67 65 74 2d 73 74 61 74 75 73 20 74 29 29 t-get-status t))
6110: 29 20 66 61 69 6c 73 29 20 22 2c 20 22 29 0a 09 ) fails) ", ")..
6120: 09 09 09 20 20 20 20 20 22 2c 20 72 65 6d 6f 76 ... ", remov
6130: 69 6e 67 20 69 74 20 66 72 6f 6d 20 74 6f 2d 64 ing it from to-d
6140: 6f 20 6c 69 73 74 22 29 0a 09 09 09 28 69 66 20 o list")....(if
6150: 28 6e 6f 74 20 28 6e 75 6c 6c 3f 20 74 61 6c 29 (not (null? tal)
6160: 29 0a 09 09 09 20 20 20 20 28 62 65 67 69 6e 0a ).... (begin.
6170: 09 09 09 20 20 20 20 20 20 28 74 68 72 65 61 64 ... (thread
6180: 2d 73 6c 65 65 70 21 20 2a 67 6c 6f 62 61 6c 2d -sleep! *global-
6190: 64 65 6c 74 61 2a 29 0a 09 09 09 20 20 20 20 20 delta*)....
61a0: 20 28 6c 6f 6f 70 20 28 63 61 72 20 74 61 6c 29 (loop (car tal)
61b0: 28 63 64 72 20 74 61 6c 29 28 63 6f 6e 73 20 68 (cdr tal)(cons h
61c0: 65 64 20 72 65 72 75 6e 73 29 29 29 29 29 0a 09 ed reruns)))))..
61d0: 09 20 20 20 20 20 20 20 28 65 6c 73 65 0a 09 09 . (else...
61e0: 09 28 64 65 62 75 67 3a 70 72 69 6e 74 20 38 20 .(debug:print 8
61f0: 22 45 52 52 4f 52 3a 20 4e 6f 20 68 61 6e 64 6c "ERROR: No handl
6200: 65 72 20 66 6f 72 20 74 68 69 73 20 63 6f 6e 64 er for this cond
6210: 69 74 69 6f 6e 2e 22 29 0a 09 09 09 28 74 68 72 ition.")....(thr
6220: 65 61 64 2d 73 6c 65 65 70 21 20 2a 67 6c 6f 62 ead-sleep! *glob
6230: 61 6c 2d 64 65 6c 74 61 2a 29 0a 09 09 09 28 6c al-delta*)....(l
6240: 6f 6f 70 20 28 63 61 72 20 6e 65 77 74 61 6c 29 oop (car newtal)
6250: 28 63 64 72 20 6e 65 77 74 61 6c 29 20 72 65 72 (cdr newtal) rer
6260: 75 6e 73 29 29 29 29 20 3b 3b 20 45 4e 44 20 4f uns)))) ;; END O
6270: 46 20 49 46 20 43 41 4e 20 52 55 4e 20 4d 4f 52 F IF CAN RUN MOR
6280: 45 0a 0a 09 09 20 20 20 20 3b 3b 20 69 66 20 63 E.... ;; if c
6290: 61 6e 27 74 20 72 75 6e 20 6d 6f 72 65 20 6a 75 an't run more ju
62a0: 73 74 20 6c 6f 6f 70 20 77 69 74 68 20 6e 65 78 st loop with nex
62b0: 74 20 70 6f 73 73 69 62 6c 65 20 74 65 73 74 0a t possible test.
62c0: 09 09 20 20 20 20 28 62 65 67 69 6e 0a 09 09 20 .. (begin...
62d0: 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e (debug:prin
62e0: 74 20 34 20 22 49 4e 46 4f 3a 20 70 72 6f 63 65 t 4 "INFO: proce
62f0: 73 73 69 6e 67 20 74 68 65 20 63 61 73 65 20 77 ssing the case w
6300: 69 74 68 20 61 20 6c 61 6d 62 64 61 20 66 6f 72 ith a lambda for
6310: 20 69 74 65 6d 73 20 6f 72 20 27 68 61 76 65 2d items or 'have-
6320: 70 72 6f 63 65 64 75 72 65 2e 20 4d 6f 76 69 6e procedure. Movin
6330: 67 20 74 68 72 6f 75 67 68 20 74 68 65 20 71 75 g through the qu
6340: 65 75 65 20 77 69 74 68 6f 75 74 20 64 72 6f 70 eue without drop
6350: 70 69 6e 67 20 22 20 68 65 64 29 0a 09 09 20 20 ping " hed)...
6360: 20 20 20 20 28 74 68 72 65 61 64 2d 73 6c 65 65 (thread-slee
6370: 70 21 20 28 2b 20 31 20 2a 67 6c 6f 62 61 6c 2d p! (+ 1 *global-
6380: 64 65 6c 74 61 2a 29 29 0a 09 09 20 20 20 20 20 delta*))...
6390: 20 28 6c 6f 6f 70 20 28 63 61 72 20 6e 65 77 74 (loop (car newt
63a0: 61 6c 29 28 63 64 72 20 6e 65 77 74 61 6c 29 20 al)(cdr newtal)
63b0: 72 65 72 75 6e 73 29 29 29 29 29 20 3b 3b 20 45 reruns))))) ;; E
63c0: 4e 44 20 4f 46 20 28 6f 72 20 28 70 72 6f 63 65 ND OF (or (proce
63d0: 64 75 72 65 3f 20 69 74 65 6d 73 29 28 65 71 3f dure? items)(eq?
63e0: 20 69 74 65 6d 73 20 27 68 61 76 65 2d 70 72 6f items 'have-pro
63f0: 63 65 64 75 72 65 29 29 0a 09 20 20 20 20 20 0a cedure)).. .
6400: 09 20 20 20 20 20 3b 3b 20 74 68 69 73 20 63 61 . ;; this ca
6410: 73 65 20 73 68 6f 75 6c 64 20 6e 6f 74 20 68 61 se should not ha
6420: 70 70 65 6e 2c 20 61 64 64 65 64 20 74 6f 20 68 ppen, added to h
6430: 65 6c 70 20 63 61 74 63 68 20 61 6e 79 20 62 75 elp catch any bu
6440: 67 73 0a 09 20 20 20 20 20 28 28 61 6e 64 20 28 gs.. ((and (
6450: 6c 69 73 74 3f 20 69 74 65 6d 73 29 20 69 74 65 list? items) ite
6460: 6d 64 61 74 29 0a 09 20 20 20 20 20 20 28 64 65 mdat).. (de
6470: 62 75 67 3a 70 72 69 6e 74 20 30 20 22 45 52 52 bug:print 0 "ERR
6480: 4f 52 3a 20 53 68 6f 75 6c 64 20 6e 6f 74 20 68 OR: Should not h
6490: 61 76 65 20 61 20 6c 69 73 74 20 6f 66 20 69 74 ave a list of it
64a0: 65 6d 73 20 69 6e 20 61 20 74 65 73 74 20 61 6e ems in a test an
64b0: 64 20 74 68 65 20 69 74 65 6d 73 70 61 74 68 20 d the itemspath
64c0: 73 65 74 20 2d 20 70 6c 65 61 73 65 20 72 65 70 set - please rep
64d0: 6f 72 74 20 74 68 69 73 22 29 0a 09 20 20 20 20 ort this")..
64e0: 20 20 28 65 78 69 74 20 31 29 29 0a 09 20 20 20 (exit 1))..
64f0: 20 20 28 28 6e 6f 74 20 28 6e 75 6c 6c 3f 20 72 ((not (null? r
6500: 65 72 75 6e 73 29 29 0a 09 20 20 20 20 20 20 28 eruns)).. (
6510: 6c 65 74 2a 20 28 28 6e 65 77 6c 73 74 20 28 6f let* ((newlst (o
6520: 70 65 6e 2d 72 75 6e 2d 63 6c 6f 73 65 20 74 65 pen-run-close te
6530: 73 74 73 3a 66 69 6c 74 65 72 2d 6e 6f 6e 2d 72 sts:filter-non-r
6540: 75 6e 6e 61 62 6c 65 20 23 66 20 72 75 6e 2d 69 unnable #f run-i
6550: 64 20 74 61 6c 20 74 65 73 74 2d 72 65 63 6f 72 d tal test-recor
6560: 64 73 29 29 20 3b 3b 20 69 2e 65 2e 20 6e 6f 74 ds)) ;; i.e. not
6570: 20 46 41 49 4c 2c 20 57 41 49 56 45 44 2c 20 49 FAIL, WAIVED, I
6580: 4e 43 4f 4d 50 4c 45 54 45 2c 20 50 41 53 53 2c NCOMPLETE, PASS,
6590: 20 4b 49 4c 4c 45 44 2c 0a 09 09 20 20 20 20 20 KILLED,...
65a0: 28 6a 75 6e 6b 65 64 20 28 6c 73 65 74 2d 64 69 (junked (lset-di
65b0: 66 66 65 72 65 6e 63 65 20 65 71 75 61 6c 3f 20 fference equal?
65c0: 74 61 6c 20 6e 65 77 6c 73 74 29 29 29 0a 09 09 tal newlst)))...
65d0: 28 64 65 62 75 67 3a 70 72 69 6e 74 20 34 20 22 (debug:print 4 "
65e0: 49 4e 46 4f 3a 20 66 75 6c 6c 20 64 72 6f 70 20 INFO: full drop
65f0: 74 68 72 6f 75 67 68 2c 20 69 66 20 72 65 72 75 through, if reru
6600: 6e 73 20 69 73 20 6c 65 73 73 20 74 68 61 6e 20 ns is less than
6610: 31 30 30 20 77 65 20 77 69 6c 6c 20 66 6f 72 63 100 we will forc
6620: 65 20 72 65 74 72 79 20 74 68 65 6d 2c 20 72 65 e retry them, re
6630: 72 75 6e 73 3d 22 20 72 65 72 75 6e 73 20 22 2c runs=" reruns ",
6640: 20 74 61 6c 3d 22 20 74 61 6c 29 0a 09 09 28 69 tal=" tal)...(i
6650: 66 20 28 3c 20 6e 75 6d 2d 72 65 74 72 69 65 73 f (< num-retries
6660: 20 6d 61 78 2d 72 65 74 72 69 65 73 29 0a 09 09 max-retries)...
6670: 20 20 20 20 28 73 65 74 21 20 6e 65 77 6c 73 74 (set! newlst
6680: 20 28 61 70 70 65 6e 64 20 72 65 72 75 6e 73 20 (append reruns
6690: 6e 65 77 6c 73 74 29 29 29 0a 09 09 28 73 65 74 newlst)))...(set
66a0: 21 20 6e 75 6d 2d 72 65 74 72 69 65 73 20 28 2b ! num-retries (+
66b0: 20 6e 75 6d 2d 72 65 74 72 69 65 73 20 31 29 29 num-retries 1))
66c0: 0a 09 09 28 74 68 72 65 61 64 2d 73 6c 65 65 70 ...(thread-sleep
66d0: 21 20 2a 67 6c 6f 62 61 6c 2d 64 65 6c 74 61 2a ! *global-delta*
66e0: 29 0a 09 09 28 69 66 20 28 6e 6f 74 20 28 6e 75 )...(if (not (nu
66f0: 6c 6c 3f 20 6e 65 77 6c 73 74 29 29 0a 09 09 20 ll? newlst))...
6700: 20 20 20 3b 3b 20 73 69 6e 63 65 20 72 65 72 75 ;; since reru
6710: 6e 73 20 68 61 76 65 20 62 65 65 6e 20 74 61 63 ns have been tac
6720: 6b 65 64 20 6f 6e 20 74 6f 20 6e 65 77 6c 73 74 ked on to newlst
6730: 20 63 72 65 61 74 65 20 6e 65 77 20 72 65 72 75 create new reru
6740: 6e 73 20 66 72 6f 6d 20 6a 75 6e 6b 65 64 0a 09 ns from junked..
6750: 09 20 20 20 20 28 6c 6f 6f 70 20 28 63 61 72 20 . (loop (car
6760: 6e 65 77 6c 73 74 29 28 63 64 72 20 6e 65 77 6c newlst)(cdr newl
6770: 73 74 29 28 64 65 6c 65 74 65 2d 64 75 70 6c 69 st)(delete-dupli
6780: 63 61 74 65 73 20 6a 75 6e 6b 65 64 29 29 29 29 cates junked))))
6790: 29 0a 09 20 20 20 20 20 28 28 6e 6f 74 20 28 6e ).. ((not (n
67a0: 75 6c 6c 3f 20 74 61 6c 29 29 0a 09 20 20 20 20 ull? tal))..
67b0: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 34 (debug:print 4
67c0: 20 22 49 4e 46 4f 3a 20 49 27 6d 20 70 72 65 74 "INFO: I'm pret
67d0: 74 79 20 73 75 72 65 20 49 20 73 68 6f 75 6c 64 ty sure I should
67e0: 6e 27 74 20 67 65 74 20 68 65 72 65 2e 22 29 29 n't get here."))
67f0: 0a 09 20 20 20 20 20 28 65 6c 73 65 0a 09 20 20 .. (else..
6800: 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 (debug:print
6810: 20 34 20 22 49 4e 46 4f 3a 20 45 78 69 74 69 6e 4 "INFO: Exitin
6820: 67 20 6c 6f 6f 70 20 77 69 74 68 2e 2e 2e 5c 6e g loop with...\n
6830: 20 20 68 65 64 3d 22 20 68 65 64 20 22 5c 6e 20 hed=" hed "\n
6840: 20 74 61 6c 3d 22 20 74 61 6c 20 22 5c 6e 20 20 tal=" tal "\n
6850: 72 65 72 75 6e 73 3d 22 20 72 65 72 75 6e 73 29 reruns=" reruns)
6860: 29 0a 09 20 20 20 20 20 29 29 29 29 20 3b 3b 20 ).. )))) ;;
6870: 4c 45 54 2a 20 28 28 74 65 73 74 2d 72 65 63 6f LET* ((test-reco
6880: 72 64 0a 0a 20 20 20 20 3b 3b 20 77 65 20 67 65 rd.. ;; we ge
6890: 74 20 68 65 72 65 20 6f 6e 20 22 64 72 6f 70 20 t here on "drop
68a0: 74 68 72 6f 75 67 68 22 20 2d 20 6c 6f 6f 70 20 through" - loop
68b0: 66 6f 72 20 6e 65 78 74 20 74 65 73 74 20 69 6e for next test in
68c0: 20 71 75 65 75 65 0a 20 20 20 20 3b 3b 20 46 49 queue. ;; FI
68d0: 58 4d 45 21 21 21 21 20 54 48 49 53 20 53 48 4f XME!!!! THIS SHO
68e0: 55 4c 44 20 4e 4f 54 20 52 45 51 55 49 52 45 20 ULD NOT REQUIRE
68f0: 41 4e 20 45 58 49 54 21 21 21 21 21 21 21 0a 20 AN EXIT!!!!!!!.
6900: 20 20 20 0a 20 20 20 20 28 64 65 62 75 67 3a 70 . (debug:p
6910: 72 69 6e 74 20 31 20 22 49 4e 46 4f 3a 20 41 6c rint 1 "INFO: Al
6920: 6c 20 74 65 73 74 73 20 6c 61 75 6e 63 68 65 64 l tests launched
6930: 22 29 0a 20 20 20 20 28 74 68 72 65 61 64 2d 73 "). (thread-s
6940: 6c 65 65 70 21 20 30 2e 35 29 0a 20 20 20 20 3b leep! 0.5). ;
6950: 3b 20 46 49 58 4d 45 21 20 54 68 69 73 20 68 61 ; FIXME! This ha
6960: 72 73 68 20 65 78 69 74 20 73 68 6f 75 6c 64 20 rsh exit should
6970: 6e 6f 74 20 62 65 20 6e 65 63 65 73 73 61 72 79 not be necessary
6980: 2e 2e 2e 2e 0a 20 20 20 20 3b 3b 20 28 69 66 20 ..... ;; (if
6990: 28 6e 6f 74 20 2a 72 75 6e 72 65 6d 6f 74 65 2a (not *runremote*
69a0: 29 28 65 78 69 74 29 29 20 3b 3b 20 0a 20 20 20 )(exit)) ;; .
69b0: 20 23 66 29 29 20 3b 3b 20 72 65 74 75 72 6e 20 #f)) ;; return
69c0: 61 20 23 66 20 61 73 20 61 20 68 69 6e 74 20 74 a #f as a hint t
69d0: 68 61 74 20 77 65 20 61 72 65 20 64 6f 6e 65 0a hat we are done.
69e0: 20 20 3b 3b 20 48 65 72 65 20 77 65 20 6e 65 65 ;; Here we nee
69f0: 64 20 74 6f 20 63 68 65 63 6b 20 74 68 61 74 20 d to check that
6a00: 61 6c 6c 20 74 68 65 20 74 65 73 74 73 20 72 65 all the tests re
6a10: 6d 61 69 6e 69 6e 67 20 74 6f 20 62 65 20 72 75 maining to be ru
6a20: 6e 20 61 72 65 20 65 6c 69 67 69 62 6c 65 20 74 n are eligible t
6a30: 6f 20 72 75 6e 0a 20 20 3b 3b 20 61 6e 64 20 61 o run. ;; and a
6a40: 72 65 20 6e 6f 74 20 62 6c 6f 63 6b 65 64 20 62 re not blocked b
6a50: 79 20 66 61 69 6c 65 64 0a 20 20 0a 0a 3b 3b 20 y failed. ..;;
6a60: 70 61 72 65 6e 74 2d 74 65 73 74 20 69 73 20 74 parent-test is t
6a70: 68 65 72 65 20 61 73 20 61 20 70 6c 61 63 65 68 here as a placeh
6a80: 6f 6c 64 65 72 20 66 6f 72 20 77 68 65 6e 20 70 older for when p
6a90: 61 72 65 6e 74 2d 74 65 73 74 73 20 63 61 6e 20 arent-tests can
6aa0: 62 65 20 72 75 6e 20 61 73 20 61 20 73 65 74 75 be run as a setu
6ab0: 70 20 73 74 65 70 0a 28 64 65 66 69 6e 65 20 28 p step.(define (
6ac0: 72 75 6e 3a 74 65 73 74 20 72 75 6e 2d 69 64 20 run:test run-id
6ad0: 72 75 6e 6e 61 6d 65 20 6b 65 79 76 61 6c 6c 73 runname keyvalls
6ae0: 74 20 74 65 73 74 2d 72 65 63 6f 72 64 20 66 6c t test-record fl
6af0: 61 67 73 20 70 61 72 65 6e 74 2d 74 65 73 74 29 ags parent-test)
6b00: 0a 20 20 3b 3b 20 41 6c 6c 20 74 68 65 73 65 20 . ;; All these
6b10: 76 61 72 73 20 6d 69 67 68 74 20 62 65 20 72 65 vars might be re
6b20: 66 65 72 65 6e 63 65 64 20 62 79 20 74 68 65 20 ferenced by the
6b30: 74 65 73 74 63 6f 6e 66 69 67 20 66 69 6c 65 20 testconfig file
6b40: 72 65 61 64 65 72 0a 20 20 28 6c 65 74 2a 20 28 reader. (let* (
6b50: 28 74 65 73 74 2d 6e 61 6d 65 20 20 20 20 28 74 (test-name (t
6b60: 65 73 74 73 3a 74 65 73 74 71 75 65 75 65 2d 67 ests:testqueue-g
6b70: 65 74 2d 74 65 73 74 6e 61 6d 65 20 20 20 74 65 et-testname te
6b80: 73 74 2d 72 65 63 6f 72 64 29 29 0a 09 20 28 74 st-record)).. (t
6b90: 65 73 74 2d 77 61 69 74 6f 6e 73 20 28 74 65 73 est-waitons (tes
6ba0: 74 73 3a 74 65 73 74 71 75 65 75 65 2d 67 65 74 ts:testqueue-get
6bb0: 2d 77 61 69 74 6f 6e 73 20 20 20 20 74 65 73 74 -waitons test
6bc0: 2d 72 65 63 6f 72 64 29 29 0a 09 20 28 74 65 73 -record)).. (tes
6bd0: 74 2d 63 6f 6e 66 20 20 20 20 28 74 65 73 74 73 t-conf (tests
6be0: 3a 74 65 73 74 71 75 65 75 65 2d 67 65 74 2d 74 :testqueue-get-t
6bf0: 65 73 74 63 6f 6e 66 69 67 20 74 65 73 74 2d 72 estconfig test-r
6c00: 65 63 6f 72 64 29 29 0a 09 20 28 69 74 65 6d 64 ecord)).. (itemd
6c10: 61 74 20 20 20 20 20 20 28 74 65 73 74 73 3a 74 at (tests:t
6c20: 65 73 74 71 75 65 75 65 2d 67 65 74 2d 69 74 65 estqueue-get-ite
6c30: 6d 64 61 74 20 20 20 20 74 65 73 74 2d 72 65 63 mdat test-rec
6c40: 6f 72 64 29 29 0a 09 20 28 74 65 73 74 2d 70 61 ord)).. (test-pa
6c50: 74 68 20 20 20 20 28 63 6f 6e 63 20 2a 74 6f 70 th (conc *top
6c60: 70 61 74 68 2a 20 22 2f 74 65 73 74 73 2f 22 20 path* "/tests/"
6c70: 74 65 73 74 2d 6e 61 6d 65 29 29 20 3b 3b 20 63 test-name)) ;; c
6c80: 6f 75 6c 64 20 75 73 65 20 74 65 73 74 73 3a 67 ould use tests:g
6c90: 65 74 2d 74 65 73 74 63 6f 6e 66 69 67 20 68 65 et-testconfig he
6ca0: 72 65 20 2e 2e 2e 0a 09 20 28 66 6f 72 63 65 20 re ..... (force
6cb0: 20 20 20 20 20 20 20 28 68 61 73 68 2d 74 61 62 (hash-tab
6cc0: 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 66 le-ref/default f
6cd0: 6c 61 67 73 20 22 2d 66 6f 72 63 65 22 20 23 66 lags "-force" #f
6ce0: 29 29 0a 09 20 28 72 65 72 75 6e 20 20 20 20 20 )).. (rerun
6cf0: 20 20 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 (hash-table-r
6d00: 65 66 2f 64 65 66 61 75 6c 74 20 66 6c 61 67 73 ef/default flags
6d10: 20 22 2d 72 65 72 75 6e 22 20 23 66 29 29 0a 09 "-rerun" #f))..
6d20: 20 28 6b 65 65 70 67 6f 69 6e 67 20 20 20 20 28 (keepgoing (
6d30: 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 hash-table-ref/d
6d40: 65 66 61 75 6c 74 20 66 6c 61 67 73 20 22 2d 6b efault flags "-k
6d50: 65 65 70 67 6f 69 6e 67 22 20 23 66 29 29 0a 09 eepgoing" #f))..
6d60: 20 28 69 74 65 6d 2d 70 61 74 68 20 20 20 20 20 (item-path
6d70: 22 22 29 0a 09 20 28 64 62 20 20 20 20 20 20 20 "").. (db
6d80: 20 20 20 20 23 66 29 29 0a 20 20 20 20 28 64 65 #f)). (de
6d90: 62 75 67 3a 70 72 69 6e 74 20 34 0a 09 09 20 22 bug:print 4... "
6da0: 74 65 73 74 2d 63 6f 6e 66 69 67 3a 20 22 20 28 test-config: " (
6db0: 68 61 73 68 2d 74 61 62 6c 65 2d 3e 61 6c 69 73 hash-table->alis
6dc0: 74 20 74 65 73 74 2d 63 6f 6e 66 29 0a 09 09 20 t test-conf)...
6dd0: 22 5c 6e 20 20 20 69 74 65 6d 64 61 74 3a 20 22 "\n itemdat: "
6de0: 20 69 74 65 6d 64 61 74 0a 09 09 20 29 0a 20 20 itemdat... ).
6df0: 20 20 3b 3b 20 73 65 74 74 69 6e 67 20 69 74 65 ;; setting ite
6e00: 6d 64 61 74 20 74 6f 20 61 20 6c 69 73 74 20 69 mdat to a list i
6e10: 66 20 69 74 20 69 73 20 23 66 0a 20 20 20 20 28 f it is #f. (
6e20: 69 66 20 28 6e 6f 74 20 69 74 65 6d 64 61 74 29 if (not itemdat)
6e30: 28 73 65 74 21 20 69 74 65 6d 64 61 74 20 27 28 (set! itemdat '(
6e40: 29 29 29 0a 20 20 20 20 28 73 65 74 21 20 69 74 ))). (set! it
6e50: 65 6d 2d 70 61 74 68 20 28 69 74 65 6d 2d 6c 69 em-path (item-li
6e60: 73 74 2d 3e 70 61 74 68 20 69 74 65 6d 64 61 74 st->path itemdat
6e70: 29 29 0a 20 20 20 20 28 64 65 62 75 67 3a 70 72 )). (debug:pr
6e80: 69 6e 74 20 32 20 22 41 74 74 65 6d 70 74 69 6e int 2 "Attemptin
6e90: 67 20 74 6f 20 6c 61 75 6e 63 68 20 74 65 73 74 g to launch test
6ea0: 20 22 20 74 65 73 74 2d 6e 61 6d 65 20 28 69 66 " test-name (if
6eb0: 20 28 65 71 75 61 6c 3f 20 69 74 65 6d 2d 70 61 (equal? item-pa
6ec0: 74 68 20 22 2f 22 29 20 22 2f 22 20 69 74 65 6d th "/") "/" item
6ed0: 2d 70 61 74 68 29 29 0a 20 20 20 20 28 73 65 74 -path)). (set
6ee0: 65 6e 76 20 22 4d 54 5f 54 45 53 54 5f 4e 41 4d env "MT_TEST_NAM
6ef0: 45 22 20 74 65 73 74 2d 6e 61 6d 65 29 20 3b 3b E" test-name) ;;
6f00: 20 0a 20 20 20 20 28 73 65 74 65 6e 76 20 22 4d . (setenv "M
6f10: 54 5f 52 55 4e 4e 41 4d 45 22 20 20 20 72 75 6e T_RUNNAME" run
6f20: 6e 61 6d 65 29 0a 20 20 20 20 28 6f 70 65 6e 2d name). (open-
6f30: 72 75 6e 2d 63 6c 6f 73 65 20 73 65 74 2d 6d 65 run-close set-me
6f40: 67 61 74 65 73 74 2d 65 6e 76 2d 76 61 72 73 20 gatest-env-vars
6f50: 64 62 20 72 75 6e 2d 69 64 29 20 3b 3b 20 74 68 db run-id) ;; th
6f60: 65 73 65 20 6d 61 79 20 62 65 20 6e 65 65 64 65 ese may be neede
6f70: 64 20 62 79 20 74 68 65 20 6c 61 75 6e 63 68 69 d by the launchi
6f80: 6e 67 20 70 72 6f 63 65 73 73 0a 20 20 20 20 28 ng process. (
6f90: 63 68 61 6e 67 65 2d 64 69 72 65 63 74 6f 72 79 change-directory
6fa0: 20 2a 74 6f 70 70 61 74 68 2a 29 0a 0a 20 20 20 *toppath*)..
6fb0: 20 3b 3b 20 48 65 72 65 20 69 73 20 77 68 65 72 ;; Here is wher
6fc0: 65 20 74 68 65 20 74 65 73 74 5f 6d 65 74 61 20 e the test_meta
6fd0: 74 61 62 6c 65 20 69 73 20 62 65 73 74 20 75 70 table is best up
6fe0: 64 61 74 65 64 0a 20 20 20 20 3b 3b 20 59 65 73 dated. ;; Yes
6ff0: 2c 20 61 6e 6f 74 68 65 72 20 75 73 65 20 6f 66 , another use of
7000: 20 61 20 67 6c 6f 62 61 6c 20 66 6f 72 20 63 61 a global for ca
7010: 63 68 69 6e 67 2e 20 4e 65 65 64 20 61 20 62 65 ching. Need a be
7020: 74 74 65 72 20 77 61 79 3f 0a 20 20 20 20 28 69 tter way?. (i
7030: 66 20 28 6e 6f 74 20 28 68 61 73 68 2d 74 61 62 f (not (hash-tab
7040: 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 2a le-ref/default *
7050: 74 65 73 74 2d 6d 65 74 61 2d 75 70 64 61 74 65 test-meta-update
7060: 64 2a 20 74 65 73 74 2d 6e 61 6d 65 20 23 66 29 d* test-name #f)
7070: 29 0a 20 20 20 20 20 20 20 20 28 62 65 67 69 6e ). (begin
7080: 0a 09 20 20 20 28 68 61 73 68 2d 74 61 62 6c 65 .. (hash-table
7090: 2d 73 65 74 21 20 2a 74 65 73 74 2d 6d 65 74 61 -set! *test-meta
70a0: 2d 75 70 64 61 74 65 64 2a 20 74 65 73 74 2d 6e -updated* test-n
70b0: 61 6d 65 20 23 74 29 0a 20 20 20 20 20 20 20 20 ame #t).
70c0: 20 20 20 28 6f 70 65 6e 2d 72 75 6e 2d 63 6c 6f (open-run-clo
70d0: 73 65 20 72 75 6e 73 3a 75 70 64 61 74 65 2d 74 se runs:update-t
70e0: 65 73 74 5f 6d 65 74 61 20 64 62 20 74 65 73 74 est_meta db test
70f0: 2d 6e 61 6d 65 20 74 65 73 74 2d 63 6f 6e 66 29 -name test-conf)
7100: 29 29 0a 20 20 20 20 0a 20 20 20 20 3b 3b 20 28 )). . ;; (
7110: 6c 61 6d 62 64 61 20 28 69 74 65 6d 64 61 74 29 lambda (itemdat)
7120: 20 3b 3b 3b 20 28 28 72 69 70 65 6e 65 73 73 20 ;;; ((ripeness
7130: 22 6f 76 65 72 72 69 70 65 22 29 20 28 74 65 6d "overripe") (tem
7140: 70 65 72 61 74 75 72 65 20 22 63 6f 6f 6c 22 29 perature "cool")
7150: 20 28 73 65 61 73 6f 6e 20 22 73 75 6d 6d 65 72 (season "summer
7160: 22 29 29 0a 20 20 20 20 28 6c 65 74 2a 20 28 28 ")). (let* ((
7170: 6e 65 77 2d 74 65 73 74 2d 70 61 74 68 20 28 73 new-test-path (s
7180: 74 72 69 6e 67 2d 69 6e 74 65 72 73 70 65 72 73 tring-interspers
7190: 65 20 28 63 6f 6e 73 20 74 65 73 74 2d 70 61 74 e (cons test-pat
71a0: 68 20 28 6d 61 70 20 63 61 64 72 20 69 74 65 6d h (map cadr item
71b0: 64 61 74 29 29 20 22 2f 22 29 29 0a 09 20 20 20 dat)) "/"))..
71c0: 28 6e 65 77 2d 74 65 73 74 2d 6e 61 6d 65 20 28 (new-test-name (
71d0: 69 66 20 28 65 71 75 61 6c 3f 20 69 74 65 6d 2d if (equal? item-
71e0: 70 61 74 68 20 22 22 29 20 74 65 73 74 2d 6e 61 path "") test-na
71f0: 6d 65 20 28 63 6f 6e 63 20 74 65 73 74 2d 6e 61 me (conc test-na
7200: 6d 65 20 22 2f 22 20 69 74 65 6d 2d 70 61 74 68 me "/" item-path
7210: 29 29 29 20 3b 3b 20 6a 75 73 74 20 6e 65 65 64 ))) ;; just need
7220: 20 69 74 20 74 6f 20 62 65 20 75 6e 69 71 75 65 it to be unique
7230: 0a 09 20 20 20 28 74 65 73 74 2d 69 64 20 20 20 .. (test-id
7240: 20 20 20 20 28 6f 70 65 6e 2d 72 75 6e 2d 63 6c (open-run-cl
7250: 6f 73 65 20 64 62 3a 67 65 74 2d 74 65 73 74 2d ose db:get-test-
7260: 69 64 20 64 62 20 20 72 75 6e 2d 69 64 20 74 65 id db run-id te
7270: 73 74 2d 6e 61 6d 65 20 69 74 65 6d 2d 70 61 74 st-name item-pat
7280: 68 29 29 0a 09 20 20 20 28 74 65 73 74 64 61 74 h)).. (testdat
7290: 20 20 20 20 20 20 20 28 6f 70 65 6e 2d 72 75 6e (open-run
72a0: 2d 63 6c 6f 73 65 20 64 62 3a 67 65 74 2d 74 65 -close db:get-te
72b0: 73 74 2d 69 6e 66 6f 2d 62 79 2d 69 64 20 64 62 st-info-by-id db
72c0: 20 74 65 73 74 2d 69 64 29 29 29 0a 20 20 20 20 test-id))).
72d0: 20 20 28 69 66 20 28 6e 6f 74 20 74 65 73 74 64 (if (not testd
72e0: 61 74 29 0a 09 20 20 28 62 65 67 69 6e 0a 09 20 at).. (begin..
72f0: 20 20 20 3b 3b 20 65 6e 73 75 72 65 20 74 68 61 ;; ensure tha
7300: 74 20 74 68 65 20 70 61 74 68 20 65 78 69 73 74 t the path exist
7310: 73 20 62 65 66 6f 72 65 20 72 65 67 69 73 74 65 s before registe
7320: 72 69 6e 67 20 74 68 65 20 74 65 73 74 0a 09 20 ring the test..
7330: 20 20 20 3b 3b 20 4e 4f 50 45 3a 20 43 61 6e 6e ;; NOPE: Cann
7340: 6f 74 21 20 44 6f 6e 27 74 20 6b 6e 6f 77 20 79 ot! Don't know y
7350: 65 74 20 77 68 69 63 68 20 64 69 73 6b 20 61 72 et which disk ar
7360: 65 61 20 77 69 6c 6c 20 62 65 20 61 73 73 69 67 ea will be assig
7370: 6e 65 64 2e 2e 2e 2e 0a 09 20 20 20 20 3b 3b 20 ned...... ;;
7380: 28 73 79 73 74 65 6d 20 28 63 6f 6e 63 20 22 6d (system (conc "m
7390: 6b 64 69 72 20 2d 70 20 22 20 6e 65 77 2d 74 65 kdir -p " new-te
73a0: 73 74 2d 70 61 74 68 29 29 0a 09 20 20 20 20 3b st-path)).. ;
73b0: 3b 0a 09 20 20 20 20 3b 3b 20 28 6f 70 65 6e 2d ;.. ;; (open-
73c0: 72 75 6e 2d 63 6c 6f 73 65 20 74 65 73 74 73 3a run-close tests:
73d0: 72 65 67 69 73 74 65 72 2d 74 65 73 74 20 64 62 register-test db
73e0: 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 6e 61 6d run-id test-nam
73f0: 65 20 69 74 65 6d 2d 70 61 74 68 29 0a 09 20 20 e item-path)..
7400: 20 20 3b 3b 0a 09 20 20 20 20 3b 3b 20 4e 42 2f ;;.. ;; NB/
7410: 2f 20 66 6f 72 20 74 68 65 20 61 62 6f 76 65 20 / for the above
7420: 6c 69 6e 65 2e 20 49 20 77 61 6e 74 20 74 68 65 line. I want the
7430: 20 74 65 73 74 20 74 6f 20 62 65 20 72 65 67 69 test to be regi
7440: 73 74 65 72 65 64 20 6c 6f 6e 67 20 62 65 66 6f stered long befo
7450: 72 65 20 74 68 69 73 20 72 6f 75 74 69 6e 65 20 re this routine
7460: 67 65 74 73 20 63 61 6c 6c 65 64 21 0a 09 20 20 gets called!..
7470: 20 20 3b 3b 0a 09 20 20 20 20 28 73 65 74 21 20 ;;.. (set!
7480: 74 65 73 74 2d 69 64 20 28 6f 70 65 6e 2d 72 75 test-id (open-ru
7490: 6e 2d 63 6c 6f 73 65 20 64 62 3a 67 65 74 2d 74 n-close db:get-t
74a0: 65 73 74 2d 69 64 20 64 62 20 72 75 6e 2d 69 64 est-id db run-id
74b0: 20 74 65 73 74 2d 6e 61 6d 65 20 69 74 65 6d 2d test-name item-
74c0: 70 61 74 68 29 29 0a 09 20 20 20 20 28 69 66 20 path)).. (if
74d0: 28 6e 6f 74 20 74 65 73 74 2d 69 64 29 0a 09 09 (not test-id)...
74e0: 28 62 65 67 69 6e 0a 09 09 20 20 28 64 65 62 75 (begin... (debu
74f0: 67 3a 70 72 69 6e 74 20 32 20 22 57 41 52 4e 3a g:print 2 "WARN:
7500: 20 54 65 73 74 20 6e 6f 74 20 70 72 65 2d 63 72 Test not pre-cr
7510: 65 61 74 65 64 3f 20 74 65 73 74 2d 6e 61 6d 65 eated? test-name
7520: 3d 22 20 74 65 73 74 2d 6e 61 6d 65 20 22 2c 20 =" test-name ",
7530: 69 74 65 6d 2d 70 61 74 68 3d 22 20 69 74 65 6d item-path=" item
7540: 2d 70 61 74 68 20 22 2c 20 72 75 6e 2d 69 64 3d -path ", run-id=
7550: 22 20 72 75 6e 2d 69 64 29 0a 09 09 20 20 28 6f " run-id)... (o
7560: 70 65 6e 2d 72 75 6e 2d 63 6c 6f 73 65 20 64 62 pen-run-close db
7570: 3a 74 65 73 74 73 2d 72 65 67 69 73 74 65 72 2d :tests-register-
7580: 74 65 73 74 20 23 66 20 72 75 6e 2d 69 64 20 74 test #f run-id t
7590: 65 73 74 2d 6e 61 6d 65 20 69 74 65 6d 2d 70 61 est-name item-pa
75a0: 74 68 29 0a 09 09 20 20 28 73 65 74 21 20 74 65 th)... (set! te
75b0: 73 74 2d 69 64 20 28 6f 70 65 6e 2d 72 75 6e 2d st-id (open-run-
75c0: 63 6c 6f 73 65 20 64 62 3a 67 65 74 2d 74 65 73 close db:get-tes
75d0: 74 2d 69 64 20 64 62 20 72 75 6e 2d 69 64 20 74 t-id db run-id t
75e0: 65 73 74 2d 6e 61 6d 65 20 69 74 65 6d 2d 70 61 est-name item-pa
75f0: 74 68 29 29 29 29 0a 09 20 20 20 20 28 64 65 62 th)))).. (deb
7600: 75 67 3a 70 72 69 6e 74 20 34 20 22 49 4e 46 4f ug:print 4 "INFO
7610: 3a 20 74 65 73 74 2d 69 64 3d 22 20 74 65 73 74 : test-id=" test
7620: 2d 69 64 20 22 2c 20 72 75 6e 2d 69 64 3d 22 20 -id ", run-id="
7630: 72 75 6e 2d 69 64 20 22 2c 20 74 65 73 74 2d 6e run-id ", test-n
7640: 61 6d 65 3d 22 20 74 65 73 74 2d 6e 61 6d 65 20 ame=" test-name
7650: 22 2c 20 69 74 65 6d 2d 70 61 74 68 3d 5c 22 22 ", item-path=\""
7660: 20 69 74 65 6d 2d 70 61 74 68 20 22 5c 22 22 29 item-path "\"")
7670: 0a 09 20 20 20 20 28 73 65 74 21 20 74 65 73 74 .. (set! test
7680: 64 61 74 20 28 6f 70 65 6e 2d 72 75 6e 2d 63 6c dat (open-run-cl
7690: 6f 73 65 20 64 62 3a 67 65 74 2d 74 65 73 74 2d ose db:get-test-
76a0: 69 6e 66 6f 2d 62 79 2d 69 64 20 64 62 20 74 65 info-by-id db te
76b0: 73 74 2d 69 64 29 29 29 29 0a 20 20 20 20 20 20 st-id)))).
76c0: 28 73 65 74 21 20 74 65 73 74 2d 69 64 20 28 64 (set! test-id (d
76d0: 62 3a 74 65 73 74 2d 67 65 74 2d 69 64 20 74 65 b:test-get-id te
76e0: 73 74 64 61 74 29 29 0a 20 20 20 20 20 20 28 63 stdat)). (c
76f0: 68 61 6e 67 65 2d 64 69 72 65 63 74 6f 72 79 20 hange-directory
7700: 74 65 73 74 2d 70 61 74 68 29 0a 20 20 20 20 20 test-path).
7710: 20 28 63 61 73 65 20 28 69 66 20 66 6f 72 63 65 (case (if force
7720: 20 3b 3b 20 28 61 72 67 73 3a 67 65 74 2d 61 72 ;; (args:get-ar
7730: 67 20 22 2d 66 6f 72 63 65 22 29 0a 09 09 27 4e g "-force")...'N
7740: 4f 54 5f 53 54 41 52 54 45 44 0a 09 09 28 69 66 OT_STARTED...(if
7750: 20 74 65 73 74 64 61 74 0a 09 09 20 20 20 20 28 testdat... (
7760: 73 74 72 69 6e 67 2d 3e 73 79 6d 62 6f 6c 20 28 string->symbol (
7770: 74 65 73 74 3a 67 65 74 2d 73 74 61 74 65 20 74 test:get-state t
7780: 65 73 74 64 61 74 29 29 0a 09 09 20 20 20 20 27 estdat))... '
7790: 66 61 69 6c 65 64 2d 74 6f 2d 69 6e 73 65 72 74 failed-to-insert
77a0: 29 29 0a 09 28 28 66 61 69 6c 65 64 2d 74 6f 2d ))..((failed-to-
77b0: 69 6e 73 65 72 74 29 0a 09 20 28 64 65 62 75 67 insert).. (debug
77c0: 3a 70 72 69 6e 74 20 30 20 22 45 52 52 4f 52 3a :print 0 "ERROR:
77d0: 20 46 61 69 6c 65 64 20 74 6f 20 69 6e 73 65 72 Failed to inser
77e0: 74 20 74 68 65 20 72 65 63 6f 72 64 20 69 6e 74 t the record int
77f0: 6f 20 74 68 65 20 64 62 22 29 29 0a 09 28 28 4e o the db"))..((N
7800: 4f 54 5f 53 54 41 52 54 45 44 20 43 4f 4d 50 4c OT_STARTED COMPL
7810: 45 54 45 44 20 44 45 4c 45 54 45 44 29 0a 09 20 ETED DELETED)..
7820: 28 6c 65 74 20 28 28 72 75 6e 66 6c 61 67 20 23 (let ((runflag #
7830: 66 29 29 0a 09 20 20 20 28 63 6f 6e 64 0a 09 20 f)).. (cond..
7840: 20 20 20 3b 3b 20 2d 66 6f 72 63 65 2c 20 72 75 ;; -force, ru
7850: 6e 20 6e 6f 20 6d 61 74 74 65 72 20 77 68 61 74 n no matter what
7860: 0a 09 20 20 20 20 28 66 6f 72 63 65 20 28 73 65 .. (force (se
7870: 74 21 20 72 75 6e 66 6c 61 67 20 23 74 29 29 0a t! runflag #t)).
7880: 09 20 20 20 20 3b 3b 20 4e 4f 54 5f 53 54 41 52 . ;; NOT_STAR
7890: 54 45 44 2c 20 72 75 6e 20 6e 6f 20 6d 61 74 74 TED, run no matt
78a0: 65 72 20 77 68 61 74 0a 09 20 20 20 20 28 28 6d er what.. ((m
78b0: 65 6d 62 65 72 20 28 74 65 73 74 3a 67 65 74 2d ember (test:get-
78c0: 73 74 61 74 65 20 74 65 73 74 64 61 74 29 20 27 state testdat) '
78d0: 28 22 44 45 4c 45 54 45 44 22 20 22 4e 4f 54 5f ("DELETED" "NOT_
78e0: 53 54 41 52 54 45 44 22 29 29 28 73 65 74 21 20 STARTED"))(set!
78f0: 72 75 6e 66 6c 61 67 20 23 74 29 29 0a 09 20 20 runflag #t))..
7900: 20 20 3b 3b 20 6e 6f 74 20 2d 72 65 72 75 6e 20 ;; not -rerun
7910: 61 6e 64 20 50 41 53 53 2c 20 57 41 52 4e 20 6f and PASS, WARN o
7920: 72 20 43 48 45 43 4b 2c 20 64 6f 20 6e 6f 20 72 r CHECK, do no r
7930: 75 6e 0a 09 20 20 20 20 28 28 61 6e 64 20 28 6f un.. ((and (o
7940: 72 20 28 6e 6f 74 20 72 65 72 75 6e 29 0a 09 09 r (not rerun)...
7950: 20 20 20 20 20 20 6b 65 65 70 67 6f 69 6e 67 29 keepgoing)
7960: 0a 09 09 20 20 3b 3b 20 52 65 71 75 69 72 65 20 ... ;; Require
7970: 74 6f 20 66 6f 72 63 65 20 72 65 2d 72 75 6e 20 to force re-run
7980: 66 6f 72 20 43 4f 4d 50 4c 45 54 45 44 20 6f 72 for COMPLETED or
7990: 20 2a 61 6e 79 74 68 69 6e 67 2a 20 2b 20 50 41 *anything* + PA
79a0: 53 53 2c 57 41 52 4e 20 6f 72 20 43 48 45 43 4b SS,WARN or CHECK
79b0: 0a 09 09 20 20 28 6f 72 20 28 6d 65 6d 62 65 72 ... (or (member
79c0: 20 28 74 65 73 74 3a 67 65 74 2d 73 74 61 74 75 (test:get-statu
79d0: 73 20 74 65 73 74 64 61 74 29 20 27 28 22 50 41 s testdat) '("PA
79e0: 53 53 22 20 22 57 41 52 4e 22 20 22 43 48 45 43 SS" "WARN" "CHEC
79f0: 4b 22 29 29 0a 09 09 20 20 20 20 20 20 28 6d 65 K"))... (me
7a00: 6d 62 65 72 20 28 74 65 73 74 3a 67 65 74 2d 73 mber (test:get-s
7a10: 74 61 74 65 20 20 74 65 73 74 64 61 74 29 20 27 tate testdat) '
7a20: 28 22 43 4f 4d 50 4c 45 54 45 44 22 29 29 29 29 ("COMPLETED"))))
7a30: 20 0a 09 20 20 20 20 20 28 64 65 62 75 67 3a 70 .. (debug:p
7a40: 72 69 6e 74 20 32 20 22 49 4e 46 4f 3a 20 72 75 rint 2 "INFO: ru
7a50: 6e 6e 69 6e 67 20 74 65 73 74 20 22 20 74 65 73 nning test " tes
7a60: 74 2d 6e 61 6d 65 20 22 2f 22 20 69 74 65 6d 2d t-name "/" item-
7a70: 70 61 74 68 20 22 20 73 75 70 70 72 65 73 73 65 path " suppresse
7a80: 64 20 61 73 20 69 74 20 69 73 20 22 20 28 74 65 d as it is " (te
7a90: 73 74 3a 67 65 74 2d 73 74 61 74 65 20 74 65 73 st:get-state tes
7aa0: 74 64 61 74 29 20 22 20 61 6e 64 20 22 20 28 74 tdat) " and " (t
7ab0: 65 73 74 3a 67 65 74 2d 73 74 61 74 75 73 20 74 est:get-status t
7ac0: 65 73 74 64 61 74 29 29 0a 09 20 20 20 20 20 28 estdat)).. (
7ad0: 73 65 74 21 20 72 75 6e 66 6c 61 67 20 23 66 29 set! runflag #f)
7ae0: 29 0a 09 20 20 20 20 3b 3b 20 2d 72 65 72 75 6e ).. ;; -rerun
7af0: 20 61 6e 64 20 73 74 61 74 75 73 20 69 73 20 6f and status is o
7b00: 6e 65 20 6f 66 20 74 68 65 20 73 70 65 63 69 66 ne of the specif
7b10: 65 64 2c 20 72 75 6e 20 69 74 0a 09 20 20 20 20 ed, run it..
7b20: 28 28 61 6e 64 20 72 65 72 75 6e 0a 09 09 20 20 ((and rerun...
7b30: 28 6c 65 74 2a 20 28 28 72 65 72 75 6e 6c 73 74 (let* ((rerunlst
7b40: 20 20 20 28 73 74 72 69 6e 67 2d 73 70 6c 69 74 (string-split
7b50: 20 72 65 72 75 6e 20 22 2c 22 29 29 0a 09 09 09 rerun ","))....
7b60: 20 28 6d 75 73 74 2d 72 65 72 75 6e 20 28 6d 65 (must-rerun (me
7b70: 6d 62 65 72 20 28 74 65 73 74 3a 67 65 74 2d 73 mber (test:get-s
7b80: 74 61 74 75 73 20 74 65 73 74 64 61 74 29 20 72 tatus testdat) r
7b90: 65 72 75 6e 6c 73 74 29 29 29 0a 09 09 20 20 20 erunlst)))...
7ba0: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 33 20 (debug:print 3
7bb0: 22 49 4e 46 4f 3a 20 2d 72 65 72 75 6e 20 6c 69 "INFO: -rerun li
7bc0: 73 74 3a 20 22 20 72 65 72 75 6e 20 22 2c 20 74 st: " rerun ", t
7bd0: 65 73 74 2d 73 74 61 74 75 73 3a 20 22 20 28 74 est-status: " (t
7be0: 65 73 74 3a 67 65 74 2d 73 74 61 74 75 73 20 74 est:get-status t
7bf0: 65 73 74 64 61 74 29 22 2c 20 6d 75 73 74 2d 72 estdat)", must-r
7c00: 65 72 75 6e 3a 20 22 20 6d 75 73 74 2d 72 65 72 erun: " must-rer
7c10: 75 6e 29 0a 09 09 20 20 20 20 6d 75 73 74 2d 72 un)... must-r
7c20: 65 72 75 6e 29 29 0a 09 20 20 20 20 20 28 64 65 erun)).. (de
7c30: 62 75 67 3a 70 72 69 6e 74 20 32 20 22 49 4e 46 bug:print 2 "INF
7c40: 4f 3a 20 52 65 72 75 6e 20 66 6f 72 63 65 64 20 O: Rerun forced
7c50: 66 6f 72 20 74 65 73 74 20 22 20 74 65 73 74 2d for test " test-
7c60: 6e 61 6d 65 20 22 2f 22 20 69 74 65 6d 2d 70 61 name "/" item-pa
7c70: 74 68 29 0a 09 20 20 20 20 20 28 73 65 74 21 20 th).. (set!
7c80: 72 75 6e 66 6c 61 67 20 23 74 29 29 0a 09 20 20 runflag #t))..
7c90: 20 20 3b 3b 20 2d 6b 65 65 70 67 6f 69 6e 67 2c ;; -keepgoing,
7ca0: 20 64 6f 20 6e 6f 74 20 72 65 72 75 6e 20 46 41 do not rerun FA
7cb0: 49 4c 0a 09 20 20 20 20 28 28 61 6e 64 20 6b 65 IL.. ((and ke
7cc0: 65 70 67 6f 69 6e 67 0a 09 09 20 20 28 6d 65 6d epgoing... (mem
7cd0: 62 65 72 20 28 74 65 73 74 3a 67 65 74 2d 73 74 ber (test:get-st
7ce0: 61 74 75 73 20 74 65 73 74 64 61 74 29 20 27 28 atus testdat) '(
7cf0: 22 46 41 49 4c 22 29 29 29 0a 09 20 20 20 20 20 "FAIL")))..
7d00: 28 73 65 74 21 20 72 75 6e 66 6c 61 67 20 23 66 (set! runflag #f
7d10: 29 29 0a 09 20 20 20 20 28 28 61 6e 64 20 28 6e )).. ((and (n
7d20: 6f 74 20 72 65 72 75 6e 29 0a 09 09 20 20 28 6d ot rerun)... (m
7d30: 65 6d 62 65 72 20 28 74 65 73 74 3a 67 65 74 2d ember (test:get-
7d40: 73 74 61 74 75 73 20 74 65 73 74 64 61 74 29 20 status testdat)
7d50: 27 28 22 46 41 49 4c 22 20 22 6e 2f 61 22 29 29 '("FAIL" "n/a"))
7d60: 29 0a 09 20 20 20 20 20 28 73 65 74 21 20 72 75 ).. (set! ru
7d70: 6e 66 6c 61 67 20 23 74 29 29 0a 09 20 20 20 20 nflag #t))..
7d80: 28 65 6c 73 65 20 28 73 65 74 21 20 72 75 6e 66 (else (set! runf
7d90: 6c 61 67 20 23 66 29 29 29 0a 09 20 20 20 28 64 lag #f))).. (d
7da0: 65 62 75 67 3a 70 72 69 6e 74 20 36 20 22 52 55 ebug:print 6 "RU
7db0: 4e 4e 49 4e 47 20 3d 3e 20 72 75 6e 66 6c 61 67 NNING => runflag
7dc0: 3a 20 22 20 72 75 6e 66 6c 61 67 20 22 20 53 54 : " runflag " ST
7dd0: 41 54 45 3a 20 22 20 28 74 65 73 74 3a 67 65 74 ATE: " (test:get
7de0: 2d 73 74 61 74 65 20 74 65 73 74 64 61 74 29 20 -state testdat)
7df0: 22 20 53 54 41 54 55 53 3a 20 22 20 28 74 65 73 " STATUS: " (tes
7e00: 74 3a 67 65 74 2d 73 74 61 74 75 73 20 74 65 73 t:get-status tes
7e10: 74 64 61 74 29 29 0a 09 20 20 20 28 69 66 20 28 tdat)).. (if (
7e20: 6e 6f 74 20 72 75 6e 66 6c 61 67 29 0a 09 20 20 not runflag)..
7e30: 20 20 20 20 20 28 69 66 20 28 6e 6f 74 20 70 61 (if (not pa
7e40: 72 65 6e 74 2d 74 65 73 74 29 0a 09 09 20 20 20 rent-test)...
7e50: 28 64 65 62 75 67 3a 70 72 69 6e 74 20 31 20 22 (debug:print 1 "
7e60: 4e 4f 54 45 3a 20 4e 6f 74 20 73 74 61 72 74 69 NOTE: Not starti
7e70: 6e 67 20 74 65 73 74 20 22 20 6e 65 77 2d 74 65 ng test " new-te
7e80: 73 74 2d 6e 61 6d 65 20 22 20 61 73 20 69 74 20 st-name " as it
7e90: 69 73 20 73 74 61 74 65 20 5c 22 22 20 28 74 65 is state \"" (te
7ea0: 73 74 3a 67 65 74 2d 73 74 61 74 65 20 74 65 73 st:get-state tes
7eb0: 74 64 61 74 29 20 0a 09 09 09 09 22 5c 22 20 61 tdat) ....."\" a
7ec0: 6e 64 20 73 74 61 74 75 73 20 5c 22 22 20 28 74 nd status \"" (t
7ed0: 65 73 74 3a 67 65 74 2d 73 74 61 74 75 73 20 74 est:get-status t
7ee0: 65 73 74 64 61 74 29 20 22 5c 22 2c 20 75 73 65 estdat) "\", use
7ef0: 20 2d 72 65 72 75 6e 20 5c 22 22 20 28 74 65 73 -rerun \"" (tes
7f00: 74 3a 67 65 74 2d 73 74 61 74 75 73 20 74 65 73 t:get-status tes
7f10: 74 64 61 74 29 0a 20 20 20 20 20 20 20 20 20 20 tdat).
7f20: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7f30: 20 20 20 20 20 20 22 5c 22 20 6f 72 20 2d 66 6f "\" or -fo
7f40: 72 63 65 20 74 6f 20 6f 76 65 72 72 69 64 65 22 rce to override"
7f50: 29 29 0a 09 20 20 20 20 20 20 20 3b 3b 20 4e 4f )).. ;; NO
7f60: 54 45 3a 20 4e 6f 20 6c 6f 6e 67 65 72 20 62 65 TE: No longer be
7f70: 20 63 68 65 63 6b 69 6e 67 20 70 72 65 72 65 71 checking prereq
7f80: 75 69 73 69 74 65 73 20 68 65 72 65 21 20 57 69 uisites here! Wi
7f90: 6c 6c 20 6e 65 76 65 72 20 67 65 74 20 68 65 72 ll never get her
7fa0: 65 20 75 6e 6c 65 73 73 20 70 72 65 72 65 71 73 e unless prereqs
7fb0: 20 61 72 65 0a 09 20 20 20 20 20 20 20 3b 3b 20 are.. ;;
7fc0: 20 20 20 20 20 20 61 6c 72 65 61 64 79 20 6d 65 already me
7fd0: 74 2e 0a 09 20 20 20 20 20 20 20 28 69 66 20 28 t... (if (
7fe0: 6e 6f 74 20 28 6c 61 75 6e 63 68 2d 74 65 73 74 not (launch-test
7ff0: 20 23 66 20 72 75 6e 2d 69 64 20 72 75 6e 6e 61 #f run-id runna
8000: 6d 65 20 74 65 73 74 2d 63 6f 6e 66 20 6b 65 79 me test-conf key
8010: 76 61 6c 6c 73 74 20 74 65 73 74 2d 6e 61 6d 65 vallst test-name
8020: 20 74 65 73 74 2d 70 61 74 68 20 69 74 65 6d 64 test-path itemd
8030: 61 74 20 66 6c 61 67 73 29 29 0a 09 09 20 20 20 at flags))...
8040: 28 62 65 67 69 6e 0a 09 09 20 20 20 20 20 28 70 (begin... (p
8050: 72 69 6e 74 20 22 45 52 52 4f 52 3a 20 46 61 69 rint "ERROR: Fai
8060: 6c 65 64 20 74 6f 20 6c 61 75 6e 63 68 20 74 68 led to launch th
8070: 65 20 74 65 73 74 2e 20 45 78 69 74 69 6e 67 20 e test. Exiting
8080: 61 73 20 73 6f 6f 6e 20 61 73 20 70 6f 73 73 69 as soon as possi
8090: 62 6c 65 22 29 0a 09 09 20 20 20 20 20 28 73 65 ble")... (se
80a0: 74 21 20 2a 67 6c 6f 62 61 6c 65 78 69 74 73 74 t! *globalexitst
80b0: 61 74 75 73 2a 20 31 29 20 3b 3b 20 0a 09 09 20 atus* 1) ;; ...
80c0: 20 20 20 20 28 70 72 6f 63 65 73 73 2d 73 69 67 (process-sig
80d0: 6e 61 6c 20 28 63 75 72 72 65 6e 74 2d 70 72 6f nal (current-pro
80e0: 63 65 73 73 2d 69 64 29 20 73 69 67 6e 61 6c 2f cess-id) signal/
80f0: 6b 69 6c 6c 29 29 29 29 29 29 0a 09 28 28 4b 49 kill))))))..((KI
8100: 4c 4c 45 44 29 20 0a 09 20 28 64 65 62 75 67 3a LLED) .. (debug:
8110: 70 72 69 6e 74 20 31 20 22 4e 4f 54 45 3a 20 22 print 1 "NOTE: "
8120: 20 6e 65 77 2d 74 65 73 74 2d 6e 61 6d 65 20 22 new-test-name "
8130: 20 69 73 20 61 6c 72 65 61 64 79 20 72 75 6e 6e is already runn
8140: 69 6e 67 20 6f 72 20 77 61 73 20 65 78 70 6c 69 ing or was expli
8150: 63 74 6c 79 20 6b 69 6c 6c 65 64 2c 20 75 73 65 ctly killed, use
8160: 20 2d 66 6f 72 63 65 20 74 6f 20 6c 61 75 6e 63 -force to launc
8170: 68 20 69 74 2e 22 29 29 0a 09 28 28 4c 41 55 4e h it."))..((LAUN
8180: 43 48 45 44 20 52 45 4d 4f 54 45 48 4f 53 54 53 CHED REMOTEHOSTS
8190: 54 41 52 54 20 52 55 4e 4e 49 4e 47 29 20 20 0a TART RUNNING) .
81a0: 09 20 28 69 66 20 28 3e 20 28 2d 20 28 63 75 72 . (if (> (- (cur
81b0: 72 65 6e 74 2d 73 65 63 6f 6e 64 73 29 28 2b 20 rent-seconds)(+
81c0: 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 65 76 65 (db:test-get-eve
81d0: 6e 74 5f 74 69 6d 65 20 74 65 73 74 64 61 74 29 nt_time testdat)
81e0: 0a 09 09 09 09 20 20 20 20 20 20 20 28 64 62 3a ..... (db:
81f0: 74 65 73 74 2d 67 65 74 2d 72 75 6e 5f 64 75 72 test-get-run_dur
8200: 61 74 69 6f 6e 20 74 65 73 74 64 61 74 29 29 29 ation testdat)))
8210: 0a 09 09 36 30 30 29 20 3b 3b 20 69 2e 65 2e 20 ...600) ;; i.e.
8220: 6e 6f 20 75 70 64 61 74 65 20 66 6f 72 20 6d 6f no update for mo
8230: 72 65 20 74 68 61 6e 20 36 30 30 20 73 65 63 6f re than 600 seco
8240: 6e 64 73 0a 09 20 20 20 20 20 28 62 65 67 69 6e nds.. (begin
8250: 0a 09 20 20 20 20 20 20 20 28 64 65 62 75 67 3a .. (debug:
8260: 70 72 69 6e 74 20 30 20 22 57 41 52 4e 49 4e 47 print 0 "WARNING
8270: 3a 20 54 65 73 74 20 22 20 74 65 73 74 2d 6e 61 : Test " test-na
8280: 6d 65 20 22 20 61 70 70 65 61 72 73 20 74 6f 20 me " appears to
8290: 62 65 20 64 65 61 64 2e 20 46 6f 72 63 69 6e 67 be dead. Forcing
82a0: 20 69 74 20 74 6f 20 73 74 61 74 65 20 49 4e 43 it to state INC
82b0: 4f 4d 50 4c 45 54 45 20 61 6e 64 20 73 74 61 74 OMPLETE and stat
82c0: 75 73 20 53 54 55 43 4b 2f 44 45 41 44 22 29 0a us STUCK/DEAD").
82d0: 09 20 20 20 20 20 20 20 28 74 65 73 74 73 3a 74 . (tests:t
82e0: 65 73 74 2d 73 65 74 2d 73 74 61 74 75 73 21 20 est-set-status!
82f0: 74 65 73 74 2d 69 64 20 22 49 4e 43 4f 4d 50 4c test-id "INCOMPL
8300: 45 54 45 22 20 22 53 54 55 43 4b 2f 44 45 41 44 ETE" "STUCK/DEAD
8310: 22 20 22 54 65 73 74 20 69 73 20 73 74 75 63 6b " "Test is stuck
8320: 20 6f 72 20 64 65 61 64 22 20 23 66 29 29 0a 09 or dead" #f))..
8330: 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e (debug:prin
8340: 74 20 32 20 22 4e 4f 54 45 3a 20 22 20 74 65 73 t 2 "NOTE: " tes
8350: 74 2d 6e 61 6d 65 20 22 20 69 73 20 61 6c 72 65 t-name " is alre
8360: 61 64 79 20 72 75 6e 6e 69 6e 67 22 29 29 29 0a ady running"))).
8370: 09 28 65 6c 73 65 20 20 20 20 20 20 20 28 64 65 .(else (de
8380: 62 75 67 3a 70 72 69 6e 74 20 30 20 22 45 52 52 bug:print 0 "ERR
8390: 4f 52 3a 20 46 61 69 6c 65 64 20 74 6f 20 6c 61 OR: Failed to la
83a0: 75 6e 63 68 20 74 65 73 74 20 22 20 6e 65 77 2d unch test " new-
83b0: 74 65 73 74 2d 6e 61 6d 65 20 22 2e 20 55 6e 72 test-name ". Unr
83c0: 65 63 6f 67 6e 69 73 65 64 20 73 74 61 74 65 20 ecognised state
83d0: 22 20 28 74 65 73 74 3a 67 65 74 2d 73 74 61 74 " (test:get-stat
83e0: 65 20 74 65 73 74 64 61 74 29 29 29 29 29 29 29 e testdat)))))))
83f0: 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ..;;============
8400: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8410: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8420: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8430: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 45 4e ==========.;; EN
8440: 44 20 4f 46 20 4e 45 57 20 53 54 55 46 46 0a 3b D OF NEW STUFF.;
8450: 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;===============
8460: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8470: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8480: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8490: 3d 3d 3d 3d 3d 3d 3d 0a 0a 28 64 65 66 69 6e 65 =======..(define
84a0: 20 28 67 65 74 2d 64 69 72 2d 75 70 2d 6e 20 64 (get-dir-up-n d
84b0: 69 72 20 2e 20 70 61 72 61 6d 73 29 20 0a 20 20 ir . params) .
84c0: 28 6c 65 74 20 28 28 64 70 61 72 74 73 20 20 28 (let ((dparts (
84d0: 73 74 72 69 6e 67 2d 73 70 6c 69 74 20 64 69 72 string-split dir
84e0: 20 22 2f 22 29 29 0a 09 28 63 6f 75 6e 74 20 20 "/"))..(count
84f0: 20 28 69 66 20 28 6e 75 6c 6c 3f 20 70 61 72 61 (if (null? para
8500: 6d 73 29 20 31 20 28 63 61 72 20 70 61 72 61 6d ms) 1 (car param
8510: 73 29 29 29 29 0a 20 20 20 20 28 63 6f 6e 63 20 s)))). (conc
8520: 22 2f 22 20 28 73 74 72 69 6e 67 2d 69 6e 74 65 "/" (string-inte
8530: 72 73 70 65 72 73 65 20 0a 09 20 20 20 20 20 20 rsperse ..
8540: 20 28 74 61 6b 65 20 64 70 61 72 74 73 20 28 2d (take dparts (-
8550: 20 28 6c 65 6e 67 74 68 20 64 70 61 72 74 73 29 (length dparts)
8560: 20 63 6f 75 6e 74 29 29 0a 09 20 20 20 20 20 20 count))..
8570: 20 22 2f 22 29 29 29 29 0a 3b 3b 20 52 65 6d 6f "/")))).;; Remo
8580: 76 65 20 72 75 6e 73 0a 3b 3b 20 66 69 65 6c 64 ve runs.;; field
8590: 73 20 61 72 65 20 70 61 73 73 69 6e 67 20 69 6e s are passing in
85a0: 20 74 68 72 6f 75 67 68 20 0a 3b 3b 20 61 63 74 through .;; act
85b0: 69 6f 6e 3a 0a 3b 3b 20 20 20 20 27 72 65 6d 6f ion:.;; 'remo
85c0: 76 65 2d 72 75 6e 73 0a 3b 3b 20 20 20 20 27 73 ve-runs.;; 's
85d0: 65 74 2d 73 74 61 74 65 2d 73 74 61 74 75 73 0a et-state-status.
85e0: 3b 3b 0a 3b 3b 20 4e 42 2f 2f 20 73 68 6f 75 6c ;;.;; NB// shoul
85f0: 64 20 70 61 73 73 20 69 6e 20 6b 65 79 73 3f 0a d pass in keys?.
8600: 3b 3b 0a 28 64 65 66 69 6e 65 20 28 72 75 6e 73 ;;.(define (runs
8610: 3a 6f 70 65 72 61 74 65 2d 6f 6e 20 61 63 74 69 :operate-on acti
8620: 6f 6e 20 72 75 6e 6e 61 6d 65 70 61 74 74 20 74 on runnamepatt t
8630: 65 73 74 70 61 74 74 20 69 74 65 6d 70 61 74 74 estpatt itempatt
8640: 20 23 21 6b 65 79 20 28 73 74 61 74 65 20 23 66 #!key (state #f
8650: 29 28 73 74 61 74 75 73 20 23 66 29 28 6e 65 77 )(status #f)(new
8660: 2d 73 74 61 74 65 2d 73 74 61 74 75 73 20 23 66 -state-status #f
8670: 29 29 0a 20 20 28 6c 65 74 2a 20 28 28 64 62 20 )). (let* ((db
8680: 20 20 20 20 20 20 20 20 20 20 23 66 29 0a 09 20 #f)..
8690: 28 6b 65 79 73 20 20 20 20 20 20 20 20 20 28 6f (keys (o
86a0: 70 65 6e 2d 72 75 6e 2d 63 6c 6f 73 65 20 64 62 pen-run-close db
86b0: 3a 67 65 74 2d 6b 65 79 73 20 64 62 29 29 0a 09 :get-keys db))..
86c0: 20 28 72 75 6e 64 61 74 20 20 20 20 20 20 20 28 (rundat (
86d0: 6f 70 65 6e 2d 72 75 6e 2d 63 6c 6f 73 65 20 72 open-run-close r
86e0: 75 6e 73 3a 67 65 74 2d 72 75 6e 73 2d 62 79 2d uns:get-runs-by-
86f0: 70 61 74 74 20 64 62 20 6b 65 79 73 20 72 75 6e patt db keys run
8700: 6e 61 6d 65 70 61 74 74 29 29 0a 09 20 28 68 65 namepatt)).. (he
8710: 61 64 65 72 20 20 20 20 20 20 20 28 76 65 63 74 ader (vect
8720: 6f 72 2d 72 65 66 20 72 75 6e 64 61 74 20 30 29 or-ref rundat 0)
8730: 29 0a 09 20 28 72 75 6e 73 20 20 20 20 20 20 20 ).. (runs
8740: 20 20 28 76 65 63 74 6f 72 2d 72 65 66 20 72 75 (vector-ref ru
8750: 6e 64 61 74 20 31 29 29 0a 09 20 28 73 74 61 74 ndat 1)).. (stat
8760: 65 73 20 20 20 20 20 20 20 28 69 66 20 73 74 61 es (if sta
8770: 74 65 20 20 28 73 74 72 69 6e 67 2d 73 70 6c 69 te (string-spli
8780: 74 20 73 74 61 74 65 20 20 22 2c 22 29 20 27 28 t state ",") '(
8790: 29 29 29 0a 09 20 28 73 74 61 74 75 73 65 73 20 ))).. (statuses
87a0: 20 20 20 20 28 69 66 20 73 74 61 74 75 73 20 28 (if status (
87b0: 73 74 72 69 6e 67 2d 73 70 6c 69 74 20 73 74 61 string-split sta
87c0: 74 75 73 20 22 2c 22 29 20 27 28 29 29 29 0a 09 tus ",") '()))..
87d0: 20 28 73 74 61 74 65 2d 73 74 61 74 75 73 20 28 (state-status (
87e0: 69 66 20 28 73 74 72 69 6e 67 3f 20 6e 65 77 2d if (string? new-
87f0: 73 74 61 74 65 2d 73 74 61 74 75 73 29 20 28 73 state-status) (s
8800: 74 72 69 6e 67 2d 73 70 6c 69 74 20 6e 65 77 2d tring-split new-
8810: 73 74 61 74 65 2d 73 74 61 74 75 73 20 22 2c 22 state-status ","
8820: 29 20 27 28 23 66 20 23 66 29 29 29 29 0a 20 20 ) '(#f #f)))).
8830: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 32 (debug:print 2
8840: 20 22 48 65 61 64 65 72 3a 20 22 20 68 65 61 64 "Header: " head
8850: 65 72 20 22 20 61 63 74 69 6f 6e 3a 20 22 20 61 er " action: " a
8860: 63 74 69 6f 6e 20 22 20 6e 65 77 2d 73 74 61 74 ction " new-stat
8870: 65 2d 73 74 61 74 75 73 3a 20 22 20 6e 65 77 2d e-status: " new-
8880: 73 74 61 74 65 2d 73 74 61 74 75 73 29 0a 20 20 state-status).
8890: 20 20 28 66 6f 72 2d 65 61 63 68 0a 20 20 20 20 (for-each.
88a0: 20 28 6c 61 6d 62 64 61 20 28 72 75 6e 29 0a 20 (lambda (run).
88b0: 20 20 20 20 20 20 28 6c 65 74 20 28 28 72 75 6e (let ((run
88c0: 6b 65 79 20 28 73 74 72 69 6e 67 2d 69 6e 74 65 key (string-inte
88d0: 72 73 70 65 72 73 65 20 28 6d 61 70 20 28 6c 61 rsperse (map (la
88e0: 6d 62 64 61 20 28 6b 29 0a 09 09 09 09 09 09 28 mbda (k).......(
88f0: 64 62 3a 67 65 74 2d 76 61 6c 75 65 2d 62 79 2d db:get-value-by-
8900: 68 65 61 64 65 72 20 72 75 6e 20 68 65 61 64 65 header run heade
8910: 72 20 28 76 65 63 74 6f 72 2d 72 65 66 20 6b 20 r (vector-ref k
8920: 30 29 29 29 20 6b 65 79 73 29 20 22 2f 22 29 29 0))) keys) "/"))
8930: 0a 09 20 20 20 20 20 28 64 69 72 73 2d 74 6f 2d .. (dirs-to-
8940: 72 65 6d 6f 76 65 20 28 6d 61 6b 65 2d 68 61 73 remove (make-has
8950: 68 2d 74 61 62 6c 65 29 29 29 0a 09 20 28 6c 65 h-table))).. (le
8960: 74 2a 20 28 28 72 75 6e 2d 69 64 20 20 20 20 28 t* ((run-id (
8970: 64 62 3a 67 65 74 2d 76 61 6c 75 65 2d 62 79 2d db:get-value-by-
8980: 68 65 61 64 65 72 20 72 75 6e 20 68 65 61 64 65 header run heade
8990: 72 20 22 69 64 22 29 29 0a 09 09 28 72 75 6e 2d r "id"))...(run-
89a0: 73 74 61 74 65 20 28 64 62 3a 67 65 74 2d 76 61 state (db:get-va
89b0: 6c 75 65 2d 62 79 2d 68 65 61 64 65 72 20 72 75 lue-by-header ru
89c0: 6e 20 68 65 61 64 65 72 20 22 73 74 61 74 65 22 n header "state"
89d0: 29 29 0a 09 09 28 74 65 73 74 73 20 20 20 20 20 ))...(tests
89e0: 28 69 66 20 28 6e 6f 74 20 28 65 71 75 61 6c 3f (if (not (equal?
89f0: 20 72 75 6e 2d 73 74 61 74 65 20 22 6c 6f 63 6b run-state "lock
8a00: 65 64 22 29 29 0a 09 09 09 20 20 20 20 20 20 20 ed"))....
8a10: 28 6f 70 65 6e 2d 72 75 6e 2d 63 6c 6f 73 65 20 (open-run-close
8a20: 64 62 3a 67 65 74 2d 74 65 73 74 73 2d 66 6f 72 db:get-tests-for
8a30: 2d 72 75 6e 20 64 62 20 28 64 62 3a 67 65 74 2d -run db (db:get-
8a40: 76 61 6c 75 65 2d 62 79 2d 68 65 61 64 65 72 20 value-by-header
8a50: 72 75 6e 20 68 65 61 64 65 72 20 22 69 64 22 29 run header "id")
8a60: 0a 09 09 09 09 09 09 20 20 20 20 20 20 74 65 73 ....... tes
8a70: 74 70 61 74 74 20 69 74 65 6d 70 61 74 74 20 73 tpatt itempatt s
8a80: 74 61 74 65 73 20 73 74 61 74 75 73 65 73 0a 09 tates statuses..
8a90: 09 09 09 09 09 20 20 20 20 20 20 6e 6f 74 2d 69 ..... not-i
8aa0: 6e 3a 20 20 23 66 0a 09 09 09 09 09 09 20 20 20 n: #f.......
8ab0: 20 20 20 73 6f 72 74 2d 62 79 3a 20 28 63 61 73 sort-by: (cas
8ac0: 65 20 61 63 74 69 6f 6e 0a 09 09 09 09 09 09 09 e action........
8ad0: 09 20 28 28 72 65 6d 6f 76 65 2d 72 75 6e 73 29 . ((remove-runs)
8ae0: 20 27 72 75 6e 64 69 72 29 0a 09 09 09 09 09 09 'rundir).......
8af0: 09 09 20 28 65 6c 73 65 20 20 20 20 20 20 20 20 .. (else
8b00: 20 20 27 65 76 65 6e 74 5f 74 69 6d 65 29 29 29 'event_time)))
8b10: 0a 09 09 09 20 20 20 20 20 20 20 27 28 29 29 29 .... '()))
8b20: 0a 09 09 28 6c 61 73 74 74 70 61 74 68 20 22 2f ...(lasttpath "/
8b30: 64 6f 65 73 2f 6e 6f 74 2f 65 78 69 73 74 2f 49 does/not/exist/I
8b40: 2f 68 6f 70 65 22 29 29 0a 09 20 20 20 28 64 65 /hope")).. (de
8b50: 62 75 67 3a 70 72 69 6e 74 20 34 20 22 49 4e 46 bug:print 4 "INF
8b60: 4f 3a 20 72 75 6e 73 3a 6f 70 65 72 61 74 65 2d O: runs:operate-
8b70: 6f 6e 20 72 75 6e 3d 22 20 72 75 6e 20 22 2c 20 on run=" run ",
8b80: 68 65 61 64 65 72 3d 22 20 68 65 61 64 65 72 29 header=" header)
8b90: 0a 09 20 20 20 28 69 66 20 28 6e 6f 74 20 28 6e .. (if (not (n
8ba0: 75 6c 6c 3f 20 74 65 73 74 73 29 29 0a 09 20 20 ull? tests))..
8bb0: 20 20 20 20 20 28 62 65 67 69 6e 0a 09 09 20 28 (begin... (
8bc0: 63 61 73 65 20 61 63 74 69 6f 6e 0a 09 09 20 20 case action...
8bd0: 20 28 28 72 65 6d 6f 76 65 2d 72 75 6e 73 29 0a ((remove-runs).
8be0: 09 09 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 .. (debug:pri
8bf0: 6e 74 20 31 20 22 52 65 6d 6f 76 69 6e 67 20 74 nt 1 "Removing t
8c00: 65 73 74 73 20 66 6f 72 20 72 75 6e 3a 20 22 20 ests for run: "
8c10: 72 75 6e 6b 65 79 20 22 20 22 20 28 64 62 3a 67 runkey " " (db:g
8c20: 65 74 2d 76 61 6c 75 65 2d 62 79 2d 68 65 61 64 et-value-by-head
8c30: 65 72 20 72 75 6e 20 68 65 61 64 65 72 20 22 72 er run header "r
8c40: 75 6e 6e 61 6d 65 22 29 29 29 0a 09 09 20 20 20 unname")))...
8c50: 28 28 73 65 74 2d 73 74 61 74 65 2d 73 74 61 74 ((set-state-stat
8c60: 75 73 29 0a 09 09 20 20 20 20 28 64 65 62 75 67 us)... (debug
8c70: 3a 70 72 69 6e 74 20 31 20 22 4d 6f 64 69 66 79 :print 1 "Modify
8c80: 69 6e 67 20 73 74 61 74 65 20 61 6e 64 20 73 74 ing state and st
8c90: 61 75 73 20 66 6f 72 20 74 65 73 74 73 20 66 6f aus for tests fo
8ca0: 72 20 72 75 6e 3a 20 22 20 72 75 6e 6b 65 79 20 r run: " runkey
8cb0: 22 20 22 20 28 64 62 3a 67 65 74 2d 76 61 6c 75 " " (db:get-valu
8cc0: 65 2d 62 79 2d 68 65 61 64 65 72 20 72 75 6e 20 e-by-header run
8cd0: 68 65 61 64 65 72 20 22 72 75 6e 6e 61 6d 65 22 header "runname"
8ce0: 29 29 29 0a 09 09 20 20 20 28 28 70 72 69 6e 74 )))... ((print
8cf0: 2d 72 75 6e 29 0a 09 09 20 20 20 20 28 64 65 62 -run)... (deb
8d00: 75 67 3a 70 72 69 6e 74 20 31 20 22 50 72 69 6e ug:print 1 "Prin
8d10: 74 69 6e 67 20 69 6e 66 6f 20 66 6f 72 20 72 75 ting info for ru
8d20: 6e 20 22 20 72 75 6e 6b 65 79 20 22 2c 20 72 75 n " runkey ", ru
8d30: 6e 3d 22 20 72 75 6e 20 22 2c 20 74 65 73 74 73 n=" run ", tests
8d40: 3d 22 20 74 65 73 74 73 20 22 2c 20 68 65 61 64 =" tests ", head
8d50: 65 72 3d 22 20 68 65 61 64 65 72 29 0a 09 09 20 er=" header)...
8d60: 20 20 20 61 63 74 69 6f 6e 29 0a 09 09 20 20 20 action)...
8d70: 28 65 6c 73 65 0a 09 09 20 20 20 20 28 70 72 69 (else... (pri
8d80: 6e 74 20 22 49 4e 46 4f 3a 20 61 63 74 69 6f 6e nt "INFO: action
8d90: 20 6e 6f 74 20 72 65 63 6f 67 6e 69 73 65 64 20 not recognised
8da0: 22 20 61 63 74 69 6f 6e 29 29 29 0a 09 09 20 28 " action)))... (
8db0: 66 6f 72 2d 65 61 63 68 0a 09 09 20 20 28 6c 61 for-each... (la
8dc0: 6d 62 64 61 20 28 74 65 73 74 29 0a 09 09 20 20 mbda (test)...
8dd0: 20 20 28 6c 65 74 2a 20 28 28 69 74 65 6d 2d 70 (let* ((item-p
8de0: 61 74 68 20 28 64 62 3a 74 65 73 74 2d 67 65 74 ath (db:test-get
8df0: 2d 69 74 65 6d 2d 70 61 74 68 20 74 65 73 74 29 -item-path test)
8e00: 29 0a 09 09 09 20 20 20 28 74 65 73 74 2d 6e 61 ).... (test-na
8e10: 6d 65 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d me (db:test-get-
8e20: 74 65 73 74 6e 61 6d 65 20 74 65 73 74 29 29 0a testname test)).
8e30: 09 09 09 20 20 20 28 72 75 6e 2d 64 69 72 20 20 ... (run-dir
8e40: 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 72 75 (db:test-get-ru
8e50: 6e 64 69 72 20 74 65 73 74 29 29 0a 09 09 09 20 ndir test))....
8e60: 20 20 28 74 65 73 74 2d 69 64 20 20 20 28 64 62 (test-id (db
8e70: 3a 74 65 73 74 2d 67 65 74 2d 69 64 20 74 65 73 :test-get-id tes
8e80: 74 29 29 29 0a 09 09 20 20 20 20 20 20 3b 3b 20 t)))... ;;
8e90: 20 20 28 74 64 62 20 20 20 20 20 20 20 28 64 62 (tdb (db
8ea0: 3a 6f 70 65 6e 2d 74 65 73 74 2d 64 62 20 72 75 :open-test-db ru
8eb0: 6e 2d 64 69 72 29 29 29 0a 09 09 20 20 20 20 20 n-dir)))...
8ec0: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 31 20 (debug:print 1
8ed0: 22 20 20 22 20 28 64 62 3a 74 65 73 74 2d 67 65 " " (db:test-ge
8ee0: 74 2d 74 65 73 74 6e 61 6d 65 20 74 65 73 74 29 t-testname test)
8ef0: 20 22 20 69 64 3a 20 22 20 28 64 62 3a 74 65 73 " id: " (db:tes
8f00: 74 2d 67 65 74 2d 69 64 20 74 65 73 74 29 20 22 t-get-id test) "
8f10: 20 22 20 69 74 65 6d 2d 70 61 74 68 20 22 20 61 " item-path " a
8f20: 63 74 69 6f 6e 3a 20 22 20 61 63 74 69 6f 6e 29 ction: " action)
8f30: 0a 09 09 20 20 20 20 20 20 28 63 61 73 65 20 61 ... (case a
8f40: 63 74 69 6f 6e 0a 09 09 09 28 28 72 65 6d 6f 76 ction....((remov
8f50: 65 2d 72 75 6e 73 29 20 3b 3b 20 74 68 65 20 74 e-runs) ;; the t
8f60: 64 62 20 69 73 20 66 6f 72 20 66 75 74 75 72 65 db is for future
8f70: 20 70 6f 73 73 69 62 6c 65 2e 20 0a 09 09 09 20 possible. ....
8f80: 28 6f 70 65 6e 2d 72 75 6e 2d 63 6c 6f 73 65 20 (open-run-close
8f90: 64 62 3a 64 65 6c 65 74 65 2d 74 65 73 74 2d 72 db:delete-test-r
8fa0: 65 63 6f 72 64 73 20 64 62 20 23 66 20 28 64 62 ecords db #f (db
8fb0: 3a 74 65 73 74 2d 67 65 74 2d 69 64 20 74 65 73 :test-get-id tes
8fc0: 74 29 29 0a 09 09 09 20 28 64 65 62 75 67 3a 70 t)).... (debug:p
8fd0: 72 69 6e 74 20 31 20 22 49 4e 46 4f 3a 20 41 74 rint 1 "INFO: At
8fe0: 74 65 6d 70 74 69 6e 67 20 74 6f 20 72 65 6d 6f tempting to remo
8ff0: 76 65 20 64 69 72 20 22 20 72 75 6e 2d 64 69 72 ve dir " run-dir
9000: 29 0a 09 09 09 20 28 69 66 20 28 61 6e 64 20 28 ).... (if (and (
9010: 3e 20 28 73 74 72 69 6e 67 2d 6c 65 6e 67 74 68 > (string-length
9020: 20 72 75 6e 2d 64 69 72 29 20 35 29 0a 09 09 09 run-dir) 5)....
9030: 09 20 20 28 66 69 6c 65 2d 65 78 69 73 74 73 3f . (file-exists?
9040: 20 72 75 6e 2d 64 69 72 29 29 20 3b 3b 20 62 61 run-dir)) ;; ba
9050: 64 20 68 65 75 72 69 73 74 69 63 20 62 75 74 20 d heuristic but
9060: 73 68 6f 75 6c 64 20 70 72 65 76 65 6e 74 20 2f should prevent /
9070: 74 6d 70 20 2f 68 6f 6d 65 20 65 74 63 2e 0a 09 tmp /home etc...
9080: 09 09 20 20 20 20 20 28 6c 65 74 2a 20 28 28 72 .. (let* ((r
9090: 65 61 6c 70 61 74 68 20 28 72 65 73 6f 6c 76 65 ealpath (resolve
90a0: 2d 70 61 74 68 6e 61 6d 65 20 72 75 6e 2d 64 69 -pathname run-di
90b0: 72 29 29 29 0a 09 09 09 20 20 20 20 20 20 20 28 r))).... (
90c0: 64 65 62 75 67 3a 70 72 69 6e 74 20 31 20 22 49 debug:print 1 "I
90d0: 4e 46 4f 3a 20 52 65 61 6c 20 70 61 74 68 20 6f NFO: Real path o
90e0: 66 20 69 73 20 22 20 72 65 61 6c 70 61 74 68 29 f is " realpath)
90f0: 0a 09 09 09 20 20 20 20 20 20 20 28 69 66 20 28 .... (if (
9100: 66 69 6c 65 2d 65 78 69 73 74 73 3f 20 72 65 61 file-exists? rea
9110: 6c 70 61 74 68 29 0a 09 09 09 09 20 20 20 28 69 lpath)..... (i
9120: 66 20 28 3e 20 28 73 79 73 74 65 6d 20 28 63 6f f (> (system (co
9130: 6e 63 20 22 72 6d 20 2d 72 66 20 22 20 72 65 61 nc "rm -rf " rea
9140: 6c 70 61 74 68 29 29 20 30 29 0a 09 09 09 09 20 lpath)) 0).....
9150: 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 (debug:pri
9160: 6e 74 20 30 20 22 45 52 52 4f 52 3a 20 54 68 65 nt 0 "ERROR: The
9170: 72 65 20 77 61 73 20 61 20 70 72 6f 62 6c 65 6d re was a problem
9180: 20 72 65 6d 6f 76 69 6e 67 20 22 20 72 65 61 6c removing " real
9190: 70 61 74 68 20 22 20 77 69 74 68 20 72 6d 20 2d path " with rm -
91a0: 66 22 29 29 0a 09 09 09 09 20 20 20 28 64 65 62 f"))..... (deb
91b0: 75 67 3a 70 72 69 6e 74 20 30 20 22 57 41 52 4e ug:print 0 "WARN
91c0: 49 4e 47 3a 20 74 65 73 74 20 72 75 6e 20 64 69 ING: test run di
91d0: 72 20 22 20 72 65 61 6c 70 61 74 68 20 22 20 61 r " realpath " a
91e0: 70 70 65 61 72 73 20 74 6f 20 6e 6f 74 20 65 78 ppears to not ex
91f0: 69 73 74 22 29 29 0a 09 09 09 20 20 20 20 20 20 ist"))....
9200: 20 28 69 66 20 28 66 69 6c 65 2d 65 78 69 73 74 (if (file-exist
9210: 73 3f 20 72 75 6e 2d 64 69 72 29 20 3b 3b 20 74 s? run-dir) ;; t
9220: 68 65 20 6c 69 6e 6b 0a 09 09 09 09 20 20 20 28 he link..... (
9230: 69 66 20 28 73 79 6d 62 6f 6c 69 63 2d 6c 69 6e if (symbolic-lin
9240: 6b 3f 20 72 75 6e 2d 64 69 72 29 0a 09 09 09 09 k? run-dir).....
9250: 20 20 20 20 20 20 20 28 64 65 6c 65 74 65 2d 66 (delete-f
9260: 69 6c 65 20 72 75 6e 2d 64 69 72 29 0a 09 09 09 ile run-dir)....
9270: 09 20 20 20 20 20 20 20 28 69 66 20 28 64 69 72 . (if (dir
9280: 65 63 74 6f 72 79 3f 20 72 75 6e 2d 64 69 72 29 ectory? run-dir)
9290: 0a 09 09 09 09 09 20 20 20 28 69 66 20 28 3e 20 ...... (if (>
92a0: 28 64 69 72 65 63 74 6f 72 79 2d 66 6f 6c 64 20 (directory-fold
92b0: 28 6c 61 6d 62 64 61 20 28 66 20 78 29 28 2b 20 (lambda (f x)(+
92c0: 31 20 78 29 29 20 30 20 72 75 6e 2d 64 69 72 29 1 x)) 0 run-dir)
92d0: 20 30 29 0a 09 09 09 09 09 20 20 20 20 20 20 20 0)......
92e0: 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 22 (debug:print 0 "
92f0: 57 41 52 4e 49 4e 47 3a 20 72 65 66 75 73 69 6e WARNING: refusin
9300: 67 20 74 6f 20 72 65 6d 6f 76 65 20 22 20 72 75 g to remove " ru
9310: 6e 2d 64 69 72 20 22 20 61 73 20 69 74 20 69 73 n-dir " as it is
9320: 20 6e 6f 74 20 65 6d 70 74 79 22 29 0a 09 09 09 not empty")....
9330: 09 09 20 20 20 20 20 20 20 28 64 65 6c 65 74 65 .. (delete
9340: 2d 64 69 72 65 63 74 6f 72 79 20 72 75 6e 2d 64 -directory run-d
9350: 69 72 29 29 20 3b 3b 20 69 74 20 73 68 6f 75 6c ir)) ;; it shoul
9360: 64 20 62 65 20 65 6d 70 74 79 20 62 79 20 68 65 d be empty by he
9370: 72 65 20 42 55 47 20 42 55 47 2c 20 61 64 64 20 re BUG BUG, add
9380: 65 72 72 6f 72 20 63 61 74 63 68 0a 09 09 09 09 error catch.....
9390: 09 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 . (debug:print
93a0: 20 30 20 22 45 52 52 4f 52 3a 20 72 65 66 75 73 0 "ERROR: refus
93b0: 69 6e 67 20 74 6f 20 72 65 6d 6f 76 65 20 22 20 ing to remove "
93c0: 72 75 6e 2d 64 69 72 20 22 20 61 73 20 69 74 20 run-dir " as it
93d0: 69 73 20 6e 65 69 74 68 65 72 20 61 20 73 79 6d is neither a sym
93e0: 6c 69 6e 6b 20 6e 6f 72 20 61 20 64 69 72 65 63 link nor a direc
93f0: 74 6f 72 79 22 29 0a 09 09 09 09 09 20 20 20 29 tory")...... )
9400: 29 29 29 0a 09 09 09 20 20 20 20 20 28 64 65 62 ))).... (deb
9410: 75 67 3a 70 72 69 6e 74 20 30 20 22 57 41 52 4e ug:print 0 "WARN
9420: 49 4e 47 3a 20 64 69 72 65 63 74 6f 72 79 20 61 ING: directory a
9430: 6c 72 65 61 64 79 20 72 65 6d 6f 76 65 64 20 22 lready removed "
9440: 20 72 75 6e 2d 64 69 72 29 29 29 0a 09 09 09 28 run-dir)))....(
9450: 28 73 65 74 2d 73 74 61 74 65 2d 73 74 61 74 75 (set-state-statu
9460: 73 29 0a 09 09 09 20 28 64 65 62 75 67 3a 70 72 s).... (debug:pr
9470: 69 6e 74 20 32 20 22 49 4e 46 4f 3a 20 6e 65 77 int 2 "INFO: new
9480: 20 73 74 61 74 65 20 22 20 28 63 61 72 20 73 74 state " (car st
9490: 61 74 65 2d 73 74 61 74 75 73 29 20 22 2c 20 6e ate-status) ", n
94a0: 65 77 20 73 74 61 74 75 73 20 22 20 28 63 61 64 ew status " (cad
94b0: 72 20 73 74 61 74 65 2d 73 74 61 74 75 73 29 29 r state-status))
94c0: 0a 09 09 09 20 28 6f 70 65 6e 2d 72 75 6e 2d 63 .... (open-run-c
94d0: 6c 6f 73 65 20 64 62 3a 74 65 73 74 2d 73 65 74 lose db:test-set
94e0: 2d 73 74 61 74 65 2d 73 74 61 74 75 73 2d 62 79 -state-status-by
94f0: 2d 69 64 20 64 62 20 28 64 62 3a 74 65 73 74 2d -id db (db:test-
9500: 67 65 74 2d 69 64 20 74 65 73 74 29 20 28 63 61 get-id test) (ca
9510: 72 20 73 74 61 74 65 2d 73 74 61 74 75 73 29 28 r state-status)(
9520: 63 61 64 72 20 73 74 61 74 65 2d 73 74 61 74 75 cadr state-statu
9530: 73 29 20 23 66 29 29 29 29 29 0a 09 09 20 20 74 s) #f)))))... t
9540: 65 73 74 73 29 29 29 0a 09 20 20 20 0a 09 20 20 ests))).. ..
9550: 20 3b 3b 20 72 65 6d 6f 76 65 20 74 68 65 20 72 ;; remove the r
9560: 75 6e 20 69 66 20 7a 65 72 6f 20 74 65 73 74 73 un if zero tests
9570: 20 72 65 6d 61 69 6e 0a 09 20 20 20 28 69 66 20 remain.. (if
9580: 28 65 71 3f 20 61 63 74 69 6f 6e 20 27 72 65 6d (eq? action 'rem
9590: 6f 76 65 2d 72 75 6e 73 29 0a 09 20 20 20 20 20 ove-runs)..
95a0: 20 20 28 6c 65 74 20 28 28 72 65 6d 74 65 73 74 (let ((remtest
95b0: 73 20 28 6f 70 65 6e 2d 72 75 6e 2d 63 6c 6f 73 s (open-run-clos
95c0: 65 20 64 62 3a 67 65 74 2d 74 65 73 74 73 2d 66 e db:get-tests-f
95d0: 6f 72 2d 72 75 6e 20 64 62 20 28 64 62 3a 67 65 or-run db (db:ge
95e0: 74 2d 76 61 6c 75 65 2d 62 79 2d 68 65 61 64 65 t-value-by-heade
95f0: 72 20 72 75 6e 20 68 65 61 64 65 72 20 22 69 64 r run header "id
9600: 22 29 20 23 66 20 23 66 20 27 28 22 44 45 4c 45 ") #f #f '("DELE
9610: 54 45 44 22 29 20 27 28 22 6e 2f 61 22 29 20 6e TED") '("n/a") n
9620: 6f 74 2d 69 6e 3a 20 23 74 29 29 29 0a 09 09 20 ot-in: #t)))...
9630: 28 69 66 20 28 6e 75 6c 6c 3f 20 72 65 6d 74 65 (if (null? remte
9640: 73 74 73 29 20 3b 3b 20 6e 6f 20 6d 6f 72 65 20 sts) ;; no more
9650: 74 65 73 74 73 20 72 65 6d 61 69 6e 69 6e 67 0a tests remaining.
9660: 09 09 20 20 20 20 20 28 6c 65 74 2a 20 28 28 64 .. (let* ((d
9670: 70 61 72 74 73 20 20 28 73 74 72 69 6e 67 2d 73 parts (string-s
9680: 70 6c 69 74 20 6c 61 73 74 74 70 61 74 68 20 22 plit lasttpath "
9690: 2f 22 29 29 0a 09 09 09 20 20 20 20 28 72 75 6e /")).... (run
96a0: 70 61 74 68 20 28 63 6f 6e 63 20 22 2f 22 20 28 path (conc "/" (
96b0: 73 74 72 69 6e 67 2d 69 6e 74 65 72 73 70 65 72 string-intersper
96c0: 73 65 20 0a 09 09 09 09 09 09 28 74 61 6b 65 20 se .......(take
96d0: 64 70 61 72 74 73 20 28 2d 20 28 6c 65 6e 67 74 dparts (- (lengt
96e0: 68 20 64 70 61 72 74 73 29 20 31 29 29 0a 09 09 h dparts) 1))...
96f0: 09 09 09 09 22 2f 22 29 29 29 29 0a 09 09 20 20 ...."/"))))...
9700: 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e (debug:prin
9710: 74 20 31 20 22 52 65 6d 6f 76 69 6e 67 20 72 75 t 1 "Removing ru
9720: 6e 3a 20 22 20 72 75 6e 6b 65 79 20 22 20 22 20 n: " runkey " "
9730: 28 64 62 3a 67 65 74 2d 76 61 6c 75 65 2d 62 79 (db:get-value-by
9740: 2d 68 65 61 64 65 72 20 72 75 6e 20 68 65 61 64 -header run head
9750: 65 72 20 22 72 75 6e 6e 61 6d 65 22 29 20 22 20 er "runname") "
9760: 61 6e 64 20 72 65 6c 61 74 65 64 20 72 65 63 6f and related reco
9770: 72 64 22 29 0a 09 09 20 20 20 20 20 20 20 28 6f rd")... (o
9780: 70 65 6e 2d 72 75 6e 2d 63 6c 6f 73 65 20 64 62 pen-run-close db
9790: 3a 64 65 6c 65 74 65 2d 72 75 6e 20 64 62 20 72 :delete-run db r
97a0: 75 6e 2d 69 64 29 0a 09 09 20 20 20 20 20 20 20 un-id)...
97b0: 3b 3b 20 54 68 69 73 20 69 73 20 61 20 70 72 65 ;; This is a pre
97c0: 74 74 79 20 67 6f 6f 64 20 70 6c 61 63 65 20 74 tty good place t
97d0: 6f 20 70 75 72 67 65 20 6f 6c 64 20 44 45 4c 45 o purge old DELE
97e0: 54 45 44 20 74 65 73 74 73 0a 09 09 20 20 20 20 TED tests...
97f0: 20 20 20 28 6f 70 65 6e 2d 72 75 6e 2d 63 6c 6f (open-run-clo
9800: 73 65 20 64 62 3a 64 65 6c 65 74 65 2d 74 65 73 se db:delete-tes
9810: 74 73 2d 66 6f 72 2d 72 75 6e 20 64 62 20 72 75 ts-for-run db ru
9820: 6e 2d 69 64 29 0a 09 09 20 20 20 20 20 20 20 28 n-id)... (
9830: 6f 70 65 6e 2d 72 75 6e 2d 63 6c 6f 73 65 20 64 open-run-close d
9840: 62 3a 64 65 6c 65 74 65 2d 6f 6c 64 2d 64 65 6c b:delete-old-del
9850: 65 74 65 64 2d 74 65 73 74 2d 72 65 63 6f 72 64 eted-test-record
9860: 73 20 64 62 29 0a 09 09 20 20 20 20 20 20 20 28 s db)... (
9870: 6f 70 65 6e 2d 72 75 6e 2d 63 6c 6f 73 65 20 64 open-run-close d
9880: 62 3a 73 65 74 2d 76 61 72 20 64 62 20 22 44 45 b:set-var db "DE
9890: 4c 45 54 45 44 5f 54 45 53 54 53 22 20 28 63 75 LETED_TESTS" (cu
98a0: 72 72 65 6e 74 2d 73 65 63 6f 6e 64 73 29 29 0a rrent-seconds)).
98b0: 09 09 20 20 20 20 20 20 20 3b 3b 20 6e 65 65 64 .. ;; need
98c0: 20 74 6f 20 66 69 67 75 72 65 20 6f 75 74 20 74 to figure out t
98d0: 68 65 20 70 61 74 68 20 74 6f 20 74 68 65 20 72 he path to the r
98e0: 75 6e 20 64 69 72 20 61 6e 64 20 72 65 6d 6f 76 un dir and remov
98f0: 65 20 69 74 20 69 66 20 65 6d 70 74 79 0a 09 09 e it if empty...
9900: 20 20 20 20 20 20 20 3b 3b 20 20 20 20 28 69 66 ;; (if
9910: 20 28 6e 75 6c 6c 3f 20 28 67 6c 6f 62 20 28 63 (null? (glob (c
9920: 6f 6e 63 20 72 75 6e 70 61 74 68 20 22 2f 2a 22 onc runpath "/*"
9930: 29 29 29 0a 09 09 20 20 20 20 20 20 20 3b 3b 20 )))... ;;
9940: 20 20 20 20 20 20 20 28 62 65 67 69 6e 0a 09 09 (begin...
9950: 20 20 20 20 20 20 20 3b 3b 20 09 20 28 64 65 62 ;; . (deb
9960: 75 67 3a 70 72 69 6e 74 20 31 20 22 52 65 6d 6f ug:print 1 "Remo
9970: 76 69 6e 67 20 72 75 6e 20 64 69 72 20 22 20 72 ving run dir " r
9980: 75 6e 70 61 74 68 29 0a 09 09 20 20 20 20 20 20 unpath)...
9990: 20 3b 3b 20 09 20 28 73 79 73 74 65 6d 20 28 63 ;; . (system (c
99a0: 6f 6e 63 20 22 72 6d 64 69 72 20 2d 70 20 22 20 onc "rmdir -p "
99b0: 72 75 6e 70 61 74 68 29 29 29 29 0a 09 09 20 20 runpath))))...
99c0: 20 20 20 20 20 29 29 29 29 29 0a 09 20 29 29 0a ))))).. )).
99d0: 20 20 20 20 20 72 75 6e 73 29 29 0a 20 20 23 74 runs)). #t
99e0: 29 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d )..;;===========
99f0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
9a00: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
9a10: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
9a20: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 52 ===========.;; R
9a30: 6f 75 74 69 6e 65 73 20 66 6f 72 20 6d 61 6e 69 outines for mani
9a40: 70 75 6c 61 74 69 6e 67 20 72 75 6e 73 0a 3b 3b pulating runs.;;
9a50: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
9a60: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
9a70: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
9a80: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
9a90: 3d 3d 3d 3d 3d 3d 0a 0a 3b 3b 20 53 69 6e 63 65 ======..;; Since
9aa0: 20 6d 61 6e 79 20 63 61 6c 6c 73 20 74 6f 20 61 many calls to a
9ab0: 20 72 75 6e 20 72 65 71 75 69 72 65 20 70 72 65 run require pre
9ac0: 74 74 79 20 6d 75 63 68 20 74 68 65 20 73 61 6d tty much the sam
9ad0: 65 20 73 65 74 75 70 20 0a 3b 3b 20 74 68 69 73 e setup .;; this
9ae0: 20 77 72 61 70 70 65 72 20 69 73 20 75 73 65 64 wrapper is used
9af0: 20 74 6f 20 72 65 64 75 63 65 20 74 68 65 20 72 to reduce the r
9b00: 65 70 6c 69 63 61 74 69 6f 6e 20 6f 66 20 63 6f eplication of co
9b10: 64 65 0a 28 64 65 66 69 6e 65 20 28 67 65 6e 65 de.(define (gene
9b20: 72 61 6c 2d 72 75 6e 2d 63 61 6c 6c 20 73 77 69 ral-run-call swi
9b30: 74 63 68 6e 61 6d 65 20 61 63 74 69 6f 6e 2d 64 tchname action-d
9b40: 65 73 63 20 70 72 6f 63 29 0a 20 20 28 6c 65 74 esc proc). (let
9b50: 20 28 28 72 75 6e 6e 61 6d 65 20 28 61 72 67 73 ((runname (args
9b60: 3a 67 65 74 2d 61 72 67 20 22 3a 72 75 6e 6e 61 :get-arg ":runna
9b70: 6d 65 22 29 29 0a 09 28 74 61 72 67 65 74 20 20 me"))..(target
9b80: 28 69 66 20 28 61 72 67 73 3a 67 65 74 2d 61 72 (if (args:get-ar
9b90: 67 20 22 2d 74 61 72 67 65 74 22 29 0a 09 09 20 g "-target")...
9ba0: 20 20 20 20 28 61 72 67 73 3a 67 65 74 2d 61 72 (args:get-ar
9bb0: 67 20 22 2d 74 61 72 67 65 74 22 29 0a 09 09 20 g "-target")...
9bc0: 20 20 20 20 28 61 72 67 73 3a 67 65 74 2d 61 72 (args:get-ar
9bd0: 67 20 22 2d 72 65 71 74 61 72 67 22 29 29 29 0a g "-reqtarg"))).
9be0: 09 28 74 68 31 20 20 20 20 20 23 66 29 29 0a 20 .(th1 #f)).
9bf0: 20 20 20 28 63 6f 6e 64 0a 20 20 20 20 20 28 28 (cond. ((
9c00: 6e 6f 74 20 74 61 72 67 65 74 29 0a 20 20 20 20 not target).
9c10: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 (debug:print 0
9c20: 20 22 45 52 52 4f 52 3a 20 4d 69 73 73 69 6e 67 "ERROR: Missing
9c30: 20 72 65 71 75 69 72 65 64 20 70 61 72 61 6d 65 required parame
9c40: 74 65 72 20 66 6f 72 20 22 20 73 77 69 74 63 68 ter for " switch
9c50: 6e 61 6d 65 20 22 2c 20 79 6f 75 20 6d 75 73 74 name ", you must
9c60: 20 73 70 65 63 69 66 79 20 74 68 65 20 74 61 72 specify the tar
9c70: 67 65 74 20 77 69 74 68 20 2d 74 61 72 67 65 74 get with -target
9c80: 22 29 0a 20 20 20 20 20 20 28 65 78 69 74 20 33 "). (exit 3
9c90: 29 29 0a 20 20 20 20 20 28 28 6e 6f 74 20 72 75 )). ((not ru
9ca0: 6e 6e 61 6d 65 29 0a 20 20 20 20 20 20 28 64 65 nname). (de
9cb0: 62 75 67 3a 70 72 69 6e 74 20 30 20 22 45 52 52 bug:print 0 "ERR
9cc0: 4f 52 3a 20 4d 69 73 73 69 6e 67 20 72 65 71 75 OR: Missing requ
9cd0: 69 72 65 64 20 70 61 72 61 6d 65 74 65 72 20 66 ired parameter f
9ce0: 6f 72 20 22 20 73 77 69 74 63 68 6e 61 6d 65 20 or " switchname
9cf0: 22 2c 20 79 6f 75 20 6d 75 73 74 20 73 70 65 63 ", you must spec
9d00: 69 66 79 20 74 68 65 20 72 75 6e 20 6e 61 6d 65 ify the run name
9d10: 20 77 69 74 68 20 3a 72 75 6e 6e 61 6d 65 20 72 with :runname r
9d20: 75 6e 6e 61 6d 65 22 29 0a 20 20 20 20 20 20 28 unname"). (
9d30: 65 78 69 74 20 33 29 29 0a 20 20 20 20 20 28 65 exit 3)). (e
9d40: 6c 73 65 0a 20 20 20 20 20 20 28 6c 65 74 20 28 lse. (let (
9d50: 28 64 62 20 20 20 23 66 29 0a 09 20 20 20 20 28 (db #f).. (
9d60: 6b 65 79 73 20 23 66 29 29 0a 09 28 69 66 20 28 keys #f))..(if (
9d70: 6e 6f 74 20 28 73 65 74 75 70 2d 66 6f 72 2d 72 not (setup-for-r
9d80: 75 6e 29 29 0a 09 20 20 20 20 28 62 65 67 69 6e un)).. (begin
9d90: 20 0a 09 20 20 20 20 20 20 28 64 65 62 75 67 3a .. (debug:
9da0: 70 72 69 6e 74 20 30 20 22 46 61 69 6c 65 64 20 print 0 "Failed
9db0: 74 6f 20 73 65 74 75 70 2c 20 65 78 69 74 69 6e to setup, exitin
9dc0: 67 22 29 0a 09 20 20 20 20 20 20 28 65 78 69 74 g").. (exit
9dd0: 20 31 29 29 29 0a 09 28 69 66 20 28 61 72 67 73 1)))..(if (args
9de0: 3a 67 65 74 2d 61 72 67 20 22 2d 73 65 72 76 65 :get-arg "-serve
9df0: 72 22 29 0a 09 20 20 20 20 28 6f 70 65 6e 2d 72 r").. (open-r
9e00: 75 6e 2d 63 6c 6f 73 65 20 73 65 72 76 65 72 3a un-close server:
9e10: 73 74 61 72 74 20 64 62 20 28 61 72 67 73 3a 67 start db (args:g
9e20: 65 74 2d 61 72 67 20 22 2d 73 65 72 76 65 72 22 et-arg "-server"
9e30: 29 29 0a 20 09 20 20 20 20 28 69 66 20 28 6e 6f )). . (if (no
9e40: 74 20 28 6f 72 20 28 61 72 67 73 3a 67 65 74 2d t (or (args:get-
9e50: 61 72 67 20 22 2d 72 75 6e 61 6c 6c 22 29 20 20 arg "-runall")
9e60: 20 20 20 3b 3b 20 72 75 6e 61 6c 6c 20 61 6e 64 ;; runall and
9e70: 20 72 75 6e 74 65 73 74 73 20 61 72 65 20 61 6c runtests are al
9e80: 6c 6f 77 65 64 20 74 6f 20 62 65 20 73 65 72 76 lowed to be serv
9e90: 65 72 73 0a 20 09 09 09 20 28 61 72 67 73 3a 67 ers. ... (args:g
9ea0: 65 74 2d 61 72 67 20 22 2d 72 75 6e 74 65 73 74 et-arg "-runtest
9eb0: 73 22 29 29 29 0a 09 09 28 73 65 72 76 65 72 3a s")))...(server:
9ec0: 63 6c 69 65 6e 74 2d 73 65 74 75 70 29 29 29 0a client-setup))).
9ed0: 09 28 73 65 74 21 20 6b 65 79 73 20 28 6f 70 65 .(set! keys (ope
9ee0: 6e 2d 72 75 6e 2d 63 6c 6f 73 65 20 64 62 3a 67 n-run-close db:g
9ef0: 65 74 2d 6b 65 79 73 20 64 62 29 29 0a 09 3b 3b et-keys db))..;;
9f00: 20 68 61 76 65 20 65 6e 6f 75 67 68 20 74 6f 20 have enough to
9f10: 70 72 6f 63 65 73 73 20 2d 74 61 72 67 65 74 20 process -target
9f20: 6f 72 20 2d 72 65 71 74 61 72 67 20 68 65 72 65 or -reqtarg here
9f30: 0a 09 28 69 66 20 28 61 72 67 73 3a 67 65 74 2d ..(if (args:get-
9f40: 61 72 67 20 22 2d 72 65 71 74 61 72 67 22 29 0a arg "-reqtarg").
9f50: 09 20 20 20 20 28 6c 65 74 2a 20 28 28 72 75 6e . (let* ((run
9f60: 63 6f 6e 66 69 67 66 20 28 63 6f 6e 63 20 20 2a configf (conc *
9f70: 74 6f 70 70 61 74 68 2a 20 22 2f 72 75 6e 63 6f toppath* "/runco
9f80: 6e 66 69 67 73 2e 63 6f 6e 66 69 67 22 29 29 20 nfigs.config"))
9f90: 3b 3b 20 44 4f 20 4e 4f 54 20 45 56 41 4c 55 41 ;; DO NOT EVALUA
9fa0: 54 45 20 41 4c 4c 20 0a 09 09 20 20 20 28 72 75 TE ALL ... (ru
9fb0: 6e 63 6f 6e 66 69 67 20 20 28 72 65 61 64 2d 63 nconfig (read-c
9fc0: 6f 6e 66 69 67 20 72 75 6e 63 6f 6e 66 69 67 66 onfig runconfigf
9fd0: 20 23 66 20 23 66 20 65 6e 76 69 72 6f 6e 2d 70 #f #f environ-p
9fe0: 61 74 74 3a 20 23 66 29 29 29 20 0a 09 20 20 20 att: #f))) ..
9ff0: 20 20 20 28 69 66 20 28 68 61 73 68 2d 74 61 62 (if (hash-tab
a000: 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 72 le-ref/default r
a010: 75 6e 63 6f 6e 66 69 67 20 28 61 72 67 73 3a 67 unconfig (args:g
a020: 65 74 2d 61 72 67 20 22 2d 72 65 71 74 61 72 67 et-arg "-reqtarg
a030: 22 29 20 23 66 29 0a 09 09 20 20 28 6b 65 79 73 ") #f)... (keys
a040: 3a 74 61 72 67 65 74 2d 73 65 74 2d 61 72 67 73 :target-set-args
a050: 20 6b 65 79 73 20 28 61 72 67 73 3a 67 65 74 2d keys (args:get-
a060: 61 72 67 20 22 2d 72 65 71 74 61 72 67 22 29 20 arg "-reqtarg")
a070: 61 72 67 73 3a 61 72 67 2d 68 61 73 68 29 0a 09 args:arg-hash)..
a080: 09 20 20 28 62 65 67 69 6e 0a 09 09 20 20 20 20 . (begin...
a090: 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 22 (debug:print 0 "
a0a0: 45 52 52 4f 52 3a 20 5b 22 20 28 61 72 67 73 3a ERROR: [" (args:
a0b0: 67 65 74 2d 61 72 67 20 22 2d 72 65 71 74 61 72 get-arg "-reqtar
a0c0: 67 22 29 20 22 5d 20 6e 6f 74 20 66 6f 75 6e 64 g") "] not found
a0d0: 20 69 6e 20 22 20 72 75 6e 63 6f 6e 66 69 67 66 in " runconfigf
a0e0: 29 0a 09 09 20 20 20 20 28 69 66 20 64 62 20 28 )... (if db (
a0f0: 73 71 6c 69 74 65 33 3a 66 69 6e 61 6c 69 7a 65 sqlite3:finalize
a100: 21 20 64 62 29 29 0a 09 09 20 20 20 20 28 65 78 ! db))... (ex
a110: 69 74 20 31 29 29 29 29 0a 09 20 20 20 20 28 69 it 1)))).. (i
a120: 66 20 28 61 72 67 73 3a 67 65 74 2d 61 72 67 20 f (args:get-arg
a130: 22 2d 74 61 72 67 65 74 22 29 0a 09 09 28 6b 65 "-target")...(ke
a140: 79 73 3a 74 61 72 67 65 74 2d 73 65 74 2d 61 72 ys:target-set-ar
a150: 67 73 20 6b 65 79 73 20 28 61 72 67 73 3a 67 65 gs keys (args:ge
a160: 74 2d 61 72 67 20 22 2d 74 61 72 67 65 74 22 20 t-arg "-target"
a170: 61 72 67 73 3a 61 72 67 2d 68 61 73 68 29 20 61 args:arg-hash) a
a180: 72 67 73 3a 61 72 67 2d 68 61 73 68 29 29 29 0a rgs:arg-hash))).
a190: 09 28 69 66 20 28 6e 6f 74 20 28 63 61 72 20 2a .(if (not (car *
a1a0: 63 6f 6e 66 69 67 69 6e 66 6f 2a 29 29 0a 09 20 configinfo*))..
a1b0: 20 20 20 28 62 65 67 69 6e 0a 09 20 20 20 20 20 (begin..
a1c0: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 (debug:print 0
a1d0: 22 45 52 52 4f 52 3a 20 41 74 74 65 6d 70 74 65 "ERROR: Attempte
a1e0: 64 20 74 6f 20 22 20 61 63 74 69 6f 6e 2d 64 65 d to " action-de
a1f0: 73 63 20 22 20 62 75 74 20 72 75 6e 20 61 72 65 sc " but run are
a200: 61 20 63 6f 6e 66 69 67 20 66 69 6c 65 20 6e 6f a config file no
a210: 74 20 66 6f 75 6e 64 22 29 0a 09 20 20 20 20 20 t found")..
a220: 20 28 65 78 69 74 20 31 29 29 0a 09 20 20 20 20 (exit 1))..
a230: 3b 3b 20 45 78 74 72 61 63 74 20 6f 75 74 20 73 ;; Extract out s
a240: 74 75 66 66 20 6e 65 65 64 65 64 20 69 6e 20 6d tuff needed in m
a250: 6f 73 74 20 6f 72 20 6d 61 6e 79 20 63 61 6c 6c ost or many call
a260: 73 0a 09 20 20 20 20 3b 3b 20 68 65 72 65 20 74 s.. ;; here t
a270: 68 65 6e 20 63 61 6c 6c 20 70 72 6f 63 0a 09 20 hen call proc..
a280: 20 20 20 28 6c 65 74 2a 20 28 28 6b 65 79 6e 61 (let* ((keyna
a290: 6d 65 73 20 20 20 28 6d 61 70 20 6b 65 79 3a 67 mes (map key:g
a2a0: 65 74 2d 66 69 65 6c 64 6e 61 6d 65 20 6b 65 79 et-fieldname key
a2b0: 73 29 29 0a 09 09 20 20 20 28 6b 65 79 76 61 6c s))... (keyval
a2c0: 6c 73 74 20 20 28 6b 65 79 73 2d 3e 76 61 6c 6c lst (keys->vall
a2d0: 69 73 74 20 6b 65 79 73 20 23 74 29 29 29 0a 09 ist keys #t)))..
a2e0: 20 20 20 20 20 20 28 70 72 6f 63 20 74 61 72 67 (proc targ
a2f0: 65 74 20 72 75 6e 6e 61 6d 65 20 6b 65 79 73 20 et runname keys
a300: 6b 65 79 6e 61 6d 65 73 20 6b 65 79 76 61 6c 6c keynames keyvall
a310: 73 74 29 29 29 0a 09 28 69 66 20 74 68 31 20 28 st)))..(if th1 (
a320: 74 68 72 65 61 64 2d 6a 6f 69 6e 21 20 74 68 31 thread-join! th1
a330: 29 29 0a 09 28 69 66 20 64 62 20 28 73 71 6c 69 ))..(if db (sqli
a340: 74 65 33 3a 66 69 6e 61 6c 69 7a 65 21 20 64 62 te3:finalize! db
a350: 29 29 0a 09 28 73 65 74 21 20 2a 64 69 64 73 6f ))..(set! *didso
a360: 6d 65 74 68 69 6e 67 2a 20 23 74 29 29 29 29 29 mething* #t)))))
a370: 29 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d )..;;===========
a380: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
a390: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
a3a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
a3b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 4c ===========.;; L
a3c0: 6f 63 6b 2f 75 6e 6c 6f 63 6b 20 72 75 6e 73 0a ock/unlock runs.
a3d0: 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;;==============
a3e0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
a3f0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
a400: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
a410: 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 28 64 65 66 69 6e ========..(defin
a420: 65 20 28 72 75 6e 73 3a 68 61 6e 64 6c 65 2d 6c e (runs:handle-l
a430: 6f 63 6b 69 6e 67 20 74 61 72 67 65 74 20 6b 65 ocking target ke
a440: 79 73 20 72 75 6e 6e 61 6d 65 20 6c 6f 63 6b 20 ys runname lock
a450: 75 6e 6c 6f 63 6b 20 75 73 65 72 29 0a 20 20 28 unlock user). (
a460: 6c 65 74 2a 20 28 28 64 62 20 20 20 20 20 20 20 let* ((db
a470: 23 66 29 0a 09 20 28 72 75 6e 64 61 74 20 20 20 #f).. (rundat
a480: 28 6f 70 65 6e 2d 72 75 6e 2d 63 6c 6f 73 65 20 (open-run-close
a490: 72 75 6e 73 3a 67 65 74 2d 72 75 6e 73 2d 62 79 runs:get-runs-by
a4a0: 2d 70 61 74 74 20 64 62 20 6b 65 79 73 20 72 75 -patt db keys ru
a4b0: 6e 6e 61 6d 65 29 29 0a 09 20 28 68 65 61 64 65 nname)).. (heade
a4c0: 72 20 20 20 28 76 65 63 74 6f 72 2d 72 65 66 20 r (vector-ref
a4d0: 72 75 6e 64 61 74 20 30 29 29 0a 09 20 28 72 75 rundat 0)).. (ru
a4e0: 6e 73 20 20 20 20 20 28 76 65 63 74 6f 72 2d 72 ns (vector-r
a4f0: 65 66 20 72 75 6e 64 61 74 20 31 29 29 29 0a 20 ef rundat 1))).
a500: 20 20 20 28 66 6f 72 2d 65 61 63 68 20 28 6c 61 (for-each (la
a510: 6d 62 64 61 20 28 72 75 6e 29 0a 09 09 28 6c 65 mbda (run)...(le
a520: 74 20 28 28 72 75 6e 2d 69 64 20 28 64 62 3a 67 t ((run-id (db:g
a530: 65 74 2d 76 61 6c 75 65 2d 62 79 2d 68 65 61 64 et-value-by-head
a540: 65 72 20 72 75 6e 20 68 65 61 64 65 72 20 22 69 er run header "i
a550: 64 22 29 29 29 0a 09 09 20 20 28 69 66 20 28 6f d")))... (if (o
a560: 72 20 6c 6f 63 6b 0a 09 09 09 20 20 28 61 6e 64 r lock.... (and
a570: 20 75 6e 6c 6f 63 6b 0a 09 09 09 20 20 20 20 20 unlock....
a580: 20 20 28 62 65 67 69 6e 0a 09 09 09 09 20 28 70 (begin..... (p
a590: 72 69 6e 74 20 22 44 6f 20 79 6f 75 20 72 65 61 rint "Do you rea
a5a0: 6c 6c 79 20 77 69 73 68 20 74 6f 20 75 6e 6c 6f lly wish to unlo
a5b0: 63 6b 20 72 75 6e 20 22 20 72 75 6e 2d 69 64 20 ck run " run-id
a5c0: 22 3f 5c 6e 20 20 20 79 2f 6e 3a 20 22 29 0a 09 "?\n y/n: ")..
a5d0: 09 09 09 20 28 65 71 75 61 6c 3f 20 22 79 22 20 ... (equal? "y"
a5e0: 28 72 65 61 64 2d 6c 69 6e 65 29 29 29 29 29 0a (read-line))))).
a5f0: 09 09 20 20 20 20 20 20 28 6f 70 65 6e 2d 72 75 .. (open-ru
a600: 6e 2d 63 6c 6f 73 65 20 64 62 3a 6c 6f 63 6b 2f n-close db:lock/
a610: 75 6e 6c 6f 63 6b 2d 72 75 6e 20 64 62 20 72 75 unlock-run db ru
a620: 6e 2d 69 64 20 6c 6f 63 6b 20 75 6e 6c 6f 63 6b n-id lock unlock
a630: 20 75 73 65 72 29 0a 09 09 20 20 20 20 20 20 28 user)... (
a640: 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 22 49 debug:print 0 "I
a650: 4e 46 4f 3a 20 53 6b 69 70 70 69 6e 67 20 6c 6f NFO: Skipping lo
a660: 63 6b 2f 75 6e 6c 6f 63 6b 20 6f 6e 20 22 20 72 ck/unlock on " r
a670: 75 6e 2d 69 64 29 29 29 29 0a 09 20 20 20 20 20 un-id))))..
a680: 20 72 75 6e 73 29 29 29 0a 3b 3b 3d 3d 3d 3d 3d runs))).;;=====
a690: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
a6a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
a6b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
a6c0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
a6d0: 3d 0a 3b 3b 20 52 6f 6c 6c 75 70 20 72 75 6e 73 =.;; Rollup runs
a6e0: 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d .;;=============
a6f0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
a700: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
a710: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
a720: 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 3b 3b 20 55 70 =========..;; Up
a730: 64 61 74 65 20 74 68 65 20 74 65 73 74 5f 6d 65 date the test_me
a740: 74 61 20 74 61 62 6c 65 20 66 6f 72 20 74 68 69 ta table for thi
a750: 73 20 74 65 73 74 0a 28 64 65 66 69 6e 65 20 28 s test.(define (
a760: 72 75 6e 73 3a 75 70 64 61 74 65 2d 74 65 73 74 runs:update-test
a770: 5f 6d 65 74 61 20 64 62 20 74 65 73 74 2d 6e 61 _meta db test-na
a780: 6d 65 20 74 65 73 74 2d 63 6f 6e 66 29 0a 20 20 me test-conf).
a790: 28 6c 65 74 20 28 28 63 75 72 72 72 65 63 6f 72 (let ((currrecor
a7a0: 64 20 28 6f 70 65 6e 2d 72 75 6e 2d 63 6c 6f 73 d (open-run-clos
a7b0: 65 20 64 62 3a 74 65 73 74 6d 65 74 61 2d 67 65 e db:testmeta-ge
a7c0: 74 2d 72 65 63 6f 72 64 20 64 62 20 74 65 73 74 t-record db test
a7d0: 2d 6e 61 6d 65 29 29 29 0a 20 20 20 20 28 69 66 -name))). (if
a7e0: 20 28 6e 6f 74 20 63 75 72 72 72 65 63 6f 72 64 (not currrecord
a7f0: 29 0a 09 28 62 65 67 69 6e 0a 09 20 20 28 73 65 )..(begin.. (se
a800: 74 21 20 63 75 72 72 72 65 63 6f 72 64 20 28 6d t! currrecord (m
a810: 61 6b 65 2d 76 65 63 74 6f 72 20 31 30 20 23 66 ake-vector 10 #f
a820: 29 29 0a 09 20 20 28 6f 70 65 6e 2d 72 75 6e 2d )).. (open-run-
a830: 63 6c 6f 73 65 20 64 62 3a 74 65 73 74 6d 65 74 close db:testmet
a840: 61 2d 61 64 64 2d 72 65 63 6f 72 64 20 64 62 20 a-add-record db
a850: 74 65 73 74 2d 6e 61 6d 65 29 29 29 0a 20 20 20 test-name))).
a860: 20 28 66 6f 72 2d 65 61 63 68 20 0a 20 20 20 20 (for-each .
a870: 20 28 6c 61 6d 62 64 61 20 28 6b 65 79 29 0a 20 (lambda (key).
a880: 20 20 20 20 20 20 28 6c 65 74 2a 20 28 28 69 64 (let* ((id
a890: 78 20 28 63 61 64 72 20 6b 65 79 29 29 0a 09 20 x (cadr key))..
a8a0: 20 20 20 20 20 28 66 6c 64 20 28 63 61 72 20 20 (fld (car
a8b0: 6b 65 79 29 29 0a 09 20 20 20 20 20 20 28 76 61 key)).. (va
a8c0: 6c 20 28 63 6f 6e 66 69 67 2d 6c 6f 6f 6b 75 70 l (config-lookup
a8d0: 20 74 65 73 74 2d 63 6f 6e 66 20 22 74 65 73 74 test-conf "test
a8e0: 5f 6d 65 74 61 22 20 66 6c 64 29 29 29 0a 09 20 _meta" fld)))..
a8f0: 3b 3b 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 ;; (debug:print
a900: 35 20 22 69 64 78 3a 20 22 20 69 64 78 20 22 20 5 "idx: " idx "
a910: 66 6c 64 3a 20 22 20 66 6c 64 20 22 20 76 61 6c fld: " fld " val
a920: 3a 20 22 20 76 61 6c 29 0a 09 20 28 69 66 20 28 : " val).. (if (
a930: 61 6e 64 20 76 61 6c 20 28 6e 6f 74 20 28 65 71 and val (not (eq
a940: 75 61 6c 3f 20 28 76 65 63 74 6f 72 2d 72 65 66 ual? (vector-ref
a950: 20 63 75 72 72 72 65 63 6f 72 64 20 69 64 78 29 currrecord idx)
a960: 20 76 61 6c 29 29 29 0a 09 20 20 20 20 20 28 62 val))).. (b
a970: 65 67 69 6e 0a 09 20 20 20 20 20 20 20 28 70 72 egin.. (pr
a980: 69 6e 74 20 22 55 70 64 61 74 69 6e 67 20 22 20 int "Updating "
a990: 74 65 73 74 2d 6e 61 6d 65 20 22 20 22 20 66 6c test-name " " fl
a9a0: 64 20 22 20 74 6f 20 22 20 76 61 6c 29 0a 09 20 d " to " val)..
a9b0: 20 20 20 20 20 20 28 6f 70 65 6e 2d 72 75 6e 2d (open-run-
a9c0: 63 6c 6f 73 65 20 64 62 3a 74 65 73 74 6d 65 74 close db:testmet
a9d0: 61 2d 75 70 64 61 74 65 2d 66 69 65 6c 64 20 64 a-update-field d
a9e0: 62 20 74 65 73 74 2d 6e 61 6d 65 20 66 6c 64 20 b test-name fld
a9f0: 76 61 6c 29 29 29 29 29 0a 20 20 20 20 20 27 28 val))))). '(
aa00: 28 22 61 75 74 68 6f 72 22 20 32 29 28 22 6f 77 ("author" 2)("ow
aa10: 6e 65 72 22 20 33 29 28 22 64 65 73 63 72 69 70 ner" 3)("descrip
aa20: 74 69 6f 6e 22 20 34 29 28 22 72 65 76 69 65 77 tion" 4)("review
aa30: 65 64 22 20 35 29 28 22 74 61 67 73 22 20 39 29 ed" 5)("tags" 9)
aa40: 29 29 29 29 0a 0a 3b 3b 20 55 70 64 61 74 65 20 ))))..;; Update
aa50: 74 65 73 74 5f 6d 65 74 61 20 66 6f 72 20 61 6c test_meta for al
aa60: 6c 20 74 65 73 74 73 0a 28 64 65 66 69 6e 65 20 l tests.(define
aa70: 28 72 75 6e 73 3a 75 70 64 61 74 65 2d 61 6c 6c (runs:update-all
aa80: 2d 74 65 73 74 5f 6d 65 74 61 20 64 62 29 0a 20 -test_meta db).
aa90: 20 28 6c 65 74 20 28 28 74 65 73 74 2d 6e 61 6d (let ((test-nam
aaa0: 65 73 20 28 67 65 74 2d 61 6c 6c 2d 6c 65 67 61 es (get-all-lega
aab0: 6c 2d 74 65 73 74 73 29 29 29 0a 20 20 20 20 28 l-tests))). (
aac0: 66 6f 72 2d 65 61 63 68 20 0a 20 20 20 20 20 28 for-each . (
aad0: 6c 61 6d 62 64 61 20 28 74 65 73 74 2d 6e 61 6d lambda (test-nam
aae0: 65 29 0a 20 20 20 20 20 20 20 28 6c 65 74 2a 20 e). (let*
aaf0: 28 28 74 65 73 74 2d 70 61 74 68 20 20 20 20 28 ((test-path (
ab00: 63 6f 6e 63 20 2a 74 6f 70 70 61 74 68 2a 20 22 conc *toppath* "
ab10: 2f 74 65 73 74 73 2f 22 20 74 65 73 74 2d 6e 61 /tests/" test-na
ab20: 6d 65 29 29 0a 09 20 20 20 20 20 20 28 74 65 73 me)).. (tes
ab30: 74 2d 63 6f 6e 66 69 67 66 20 28 63 6f 6e 63 20 t-configf (conc
ab40: 74 65 73 74 2d 70 61 74 68 20 22 2f 74 65 73 74 test-path "/test
ab50: 63 6f 6e 66 69 67 22 29 29 0a 09 20 20 20 20 20 config"))..
ab60: 20 28 74 65 73 74 65 78 69 73 74 73 20 20 20 28 (testexists (
ab70: 61 6e 64 20 28 66 69 6c 65 2d 65 78 69 73 74 73 and (file-exists
ab80: 3f 20 74 65 73 74 2d 63 6f 6e 66 69 67 66 29 28 ? test-configf)(
ab90: 66 69 6c 65 2d 72 65 61 64 2d 61 63 63 65 73 73 file-read-access
aba0: 3f 20 74 65 73 74 2d 63 6f 6e 66 69 67 66 29 29 ? test-configf))
abb0: 29 0a 09 20 20 20 20 20 20 3b 3b 20 72 65 61 64 ).. ;; read
abc0: 20 63 6f 6e 66 69 67 73 20 77 69 74 68 20 74 72 configs with tr
abd0: 69 63 6b 73 20 74 75 72 6e 65 64 20 6f 66 66 20 icks turned off
abe0: 28 69 2e 65 2e 20 6e 6f 20 73 79 73 74 65 6d 29 (i.e. no system)
abf0: 0a 09 20 20 20 20 20 20 28 74 65 73 74 2d 63 6f .. (test-co
ac00: 6e 66 20 20 20 20 28 69 66 20 74 65 73 74 65 78 nf (if testex
ac10: 69 73 74 73 20 28 72 65 61 64 2d 63 6f 6e 66 69 ists (read-confi
ac20: 67 20 74 65 73 74 2d 63 6f 6e 66 69 67 66 20 23 g test-configf #
ac30: 66 20 23 66 29 28 6d 61 6b 65 2d 68 61 73 68 2d f #f)(make-hash-
ac40: 74 61 62 6c 65 29 29 29 29 0a 09 20 3b 3b 20 75 table)))).. ;; u
ac50: 73 65 20 74 68 65 20 6f 70 65 6e 2d 72 75 6e 2d se the open-run-
ac60: 63 6c 6f 73 65 20 69 6e 73 74 65 61 64 20 6f 66 close instead of
ac70: 20 70 61 73 73 69 6e 67 20 69 6e 20 64 62 0a 09 passing in db..
ac80: 20 28 72 75 6e 73 3a 75 70 64 61 74 65 2d 74 65 (runs:update-te
ac90: 73 74 5f 6d 65 74 61 20 23 66 20 74 65 73 74 2d st_meta #f test-
aca0: 6e 61 6d 65 20 74 65 73 74 2d 63 6f 6e 66 29 29 name test-conf))
acb0: 29 0a 20 20 20 20 20 74 65 73 74 2d 6e 61 6d 65 ). test-name
acc0: 73 29 29 29 0a 0a 3b 3b 20 54 68 69 73 20 63 6f s)))..;; This co
acd0: 75 6c 64 20 70 72 6f 62 61 62 6c 79 20 62 65 20 uld probably be
ace0: 72 65 66 61 63 74 6f 72 65 64 20 69 6e 74 6f 20 refactored into
acf0: 6f 6e 65 20 63 6f 6d 70 6c 65 78 20 71 75 65 72 one complex quer
ad00: 79 20 2e 2e 2e 0a 28 64 65 66 69 6e 65 20 28 72 y ....(define (r
ad10: 75 6e 73 3a 72 6f 6c 6c 75 70 2d 72 75 6e 20 6b uns:rollup-run k
ad20: 65 79 73 20 6b 65 79 76 61 6c 6c 73 74 20 72 75 eys keyvallst ru
ad30: 6e 6e 61 6d 65 20 75 73 65 72 29 20 3b 3b 20 77 nname user) ;; w
ad40: 61 73 20 74 61 72 67 65 74 2c 20 6e 6f 77 20 6b as target, now k
ad50: 65 79 76 61 6c 6c 73 74 0a 20 20 28 64 65 62 75 eyvallst. (debu
ad60: 67 3a 70 72 69 6e 74 20 34 20 22 72 75 6e 73 3a g:print 4 "runs:
ad70: 72 6f 6c 6c 75 70 2d 72 75 6e 2c 20 6b 65 79 73 rollup-run, keys
ad80: 3a 20 22 20 6b 65 79 73 20 22 20 6b 65 79 76 61 : " keys " keyva
ad90: 6c 6c 73 74 3a 20 22 20 6b 65 79 76 61 6c 6c 73 llst: " keyvalls
ada0: 74 20 22 20 3a 72 75 6e 6e 61 6d 65 20 22 20 72 t " :runname " r
adb0: 75 6e 6e 61 6d 65 20 22 20 75 73 65 72 3a 20 22 unname " user: "
adc0: 20 75 73 65 72 29 0a 20 20 28 6c 65 74 2a 20 28 user). (let* (
add0: 28 64 62 20 20 20 20 20 20 20 20 20 20 20 20 20 (db
ade0: 20 23 66 29 20 3b 3b 20 28 6b 65 79 76 61 6c 6c #f) ;; (keyvall
adf0: 6c 73 74 20 20 20 20 20 20 28 6b 65 79 73 3a 74 lst (keys:t
ae00: 61 72 67 65 74 2d 3e 6b 65 79 76 61 6c 20 6b 65 arget->keyval ke
ae10: 79 73 20 74 61 72 67 65 74 29 29 0a 09 20 28 6e ys target)).. (n
ae20: 65 77 2d 72 75 6e 2d 69 64 20 20 20 20 20 20 28 ew-run-id (
ae30: 6f 70 65 6e 2d 72 75 6e 2d 63 6c 6f 73 65 20 72 open-run-close r
ae40: 75 6e 73 3a 72 65 67 69 73 74 65 72 2d 72 75 6e uns:register-run
ae50: 20 64 62 20 6b 65 79 73 20 6b 65 79 76 61 6c 6c db keys keyvall
ae60: 73 74 20 72 75 6e 6e 61 6d 65 20 22 6e 65 77 22 st runname "new"
ae70: 20 22 6e 2f 61 22 20 75 73 65 72 29 29 0a 09 20 "n/a" user))..
ae80: 28 70 72 65 76 2d 74 65 73 74 73 20 20 20 20 20 (prev-tests
ae90: 20 28 6f 70 65 6e 2d 72 75 6e 2d 63 6c 6f 73 65 (open-run-close
aea0: 20 74 65 73 74 3a 67 65 74 2d 6d 61 74 63 68 69 test:get-matchi
aeb0: 6e 67 2d 70 72 65 76 69 6f 75 73 2d 74 65 73 74 ng-previous-test
aec0: 2d 72 75 6e 2d 72 65 63 6f 72 64 73 20 64 62 20 -run-records db
aed0: 6e 65 77 2d 72 75 6e 2d 69 64 20 22 25 22 20 22 new-run-id "%" "
aee0: 25 22 29 29 0a 09 20 28 63 75 72 72 2d 74 65 73 %")).. (curr-tes
aef0: 74 73 20 20 20 20 20 20 28 6f 70 65 6e 2d 72 75 ts (open-ru
af00: 6e 2d 63 6c 6f 73 65 20 64 62 3a 67 65 74 2d 74 n-close db:get-t
af10: 65 73 74 73 2d 66 6f 72 2d 72 75 6e 20 64 62 20 ests-for-run db
af20: 6e 65 77 2d 72 75 6e 2d 69 64 20 22 25 22 20 22 new-run-id "%" "
af30: 25 22 20 27 28 29 20 27 28 29 29 29 0a 09 20 28 %" '() '())).. (
af40: 63 75 72 72 2d 74 65 73 74 73 2d 68 61 73 68 20 curr-tests-hash
af50: 28 6d 61 6b 65 2d 68 61 73 68 2d 74 61 62 6c 65 (make-hash-table
af60: 29 29 29 0a 20 20 20 20 28 6f 70 65 6e 2d 72 75 ))). (open-ru
af70: 6e 2d 63 6c 6f 73 65 20 64 62 3a 75 70 64 61 74 n-close db:updat
af80: 65 2d 72 75 6e 2d 65 76 65 6e 74 5f 74 69 6d 65 e-run-event_time
af90: 20 64 62 20 6e 65 77 2d 72 75 6e 2d 69 64 29 0a db new-run-id).
afa0: 20 20 20 20 3b 3b 20 69 6e 64 65 78 20 74 68 65 ;; index the
afb0: 20 61 6c 72 65 61 64 79 20 73 61 76 65 64 20 74 already saved t
afc0: 65 73 74 73 20 62 79 20 74 65 73 74 6e 61 6d 65 ests by testname
afd0: 20 61 6e 64 20 69 74 65 6d 64 61 74 20 69 6e 20 and itemdat in
afe0: 63 75 72 72 2d 74 65 73 74 73 2d 68 61 73 68 0a curr-tests-hash.
aff0: 20 20 20 20 28 66 6f 72 2d 65 61 63 68 0a 20 20 (for-each.
b000: 20 20 20 28 6c 61 6d 62 64 61 20 28 74 65 73 74 (lambda (test
b010: 64 61 74 29 0a 20 20 20 20 20 20 20 28 6c 65 74 dat). (let
b020: 2a 20 28 28 74 65 73 74 6e 61 6d 65 20 20 28 64 * ((testname (d
b030: 62 3a 74 65 73 74 2d 67 65 74 2d 74 65 73 74 6e b:test-get-testn
b040: 61 6d 65 20 74 65 73 74 64 61 74 29 29 0a 09 20 ame testdat))..
b050: 20 20 20 20 20 28 69 74 65 6d 2d 70 61 74 68 20 (item-path
b060: 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 69 74 65 (db:test-get-ite
b070: 6d 2d 70 61 74 68 20 74 65 73 74 64 61 74 29 29 m-path testdat))
b080: 0a 09 20 20 20 20 20 20 28 66 75 6c 6c 2d 6e 61 .. (full-na
b090: 6d 65 20 28 63 6f 6e 63 20 74 65 73 74 6e 61 6d me (conc testnam
b0a0: 65 20 22 2f 22 20 69 74 65 6d 2d 70 61 74 68 29 e "/" item-path)
b0b0: 29 29 0a 09 20 28 68 61 73 68 2d 74 61 62 6c 65 )).. (hash-table
b0c0: 2d 73 65 74 21 20 63 75 72 72 2d 74 65 73 74 73 -set! curr-tests
b0d0: 2d 68 61 73 68 20 66 75 6c 6c 2d 6e 61 6d 65 20 -hash full-name
b0e0: 74 65 73 74 64 61 74 29 29 29 0a 20 20 20 20 20 testdat))).
b0f0: 63 75 72 72 2d 74 65 73 74 73 29 0a 20 20 20 20 curr-tests).
b100: 3b 3b 20 4e 4f 50 45 3a 20 4e 6f 6e 2d 6f 70 74 ;; NOPE: Non-opt
b110: 69 6d 61 6c 20 61 70 70 72 6f 61 63 68 2e 20 54 imal approach. T
b120: 72 79 20 74 68 69 73 20 69 6e 73 74 65 61 64 2e ry this instead.
b130: 0a 20 20 20 20 3b 3b 20 20 20 31 2e 20 74 65 73 . ;; 1. tes
b140: 74 73 20 61 72 65 20 72 65 63 65 69 76 65 64 20 ts are received
b150: 69 6e 20 61 20 6c 69 73 74 2c 20 6d 6f 73 74 20 in a list, most
b160: 72 65 63 65 6e 74 20 66 69 72 73 74 0a 20 20 20 recent first.
b170: 20 3b 3b 20 20 20 32 2e 20 72 65 70 6c 61 63 65 ;; 2. replace
b180: 20 74 68 65 20 72 6f 6c 6c 75 70 20 74 65 73 74 the rollup test
b190: 20 77 69 74 68 20 74 68 65 20 6e 65 77 20 2a 61 with the new *a
b1a0: 6c 77 61 79 73 2a 0a 20 20 20 20 28 66 6f 72 2d lways*. (for-
b1b0: 65 61 63 68 20 0a 20 20 20 20 20 28 6c 61 6d 62 each . (lamb
b1c0: 64 61 20 28 74 65 73 74 64 61 74 29 0a 20 20 20 da (testdat).
b1d0: 20 20 20 20 28 6c 65 74 2a 20 28 28 74 65 73 74 (let* ((test
b1e0: 6e 61 6d 65 20 20 28 64 62 3a 74 65 73 74 2d 67 name (db:test-g
b1f0: 65 74 2d 74 65 73 74 6e 61 6d 65 20 74 65 73 74 et-testname test
b200: 64 61 74 29 29 0a 09 20 20 20 20 20 20 28 69 74 dat)).. (it
b210: 65 6d 2d 70 61 74 68 20 28 64 62 3a 74 65 73 74 em-path (db:test
b220: 2d 67 65 74 2d 69 74 65 6d 2d 70 61 74 68 20 74 -get-item-path t
b230: 65 73 74 64 61 74 29 29 0a 09 20 20 20 20 20 20 estdat))..
b240: 28 66 75 6c 6c 2d 6e 61 6d 65 20 28 63 6f 6e 63 (full-name (conc
b250: 20 74 65 73 74 6e 61 6d 65 20 22 2f 22 20 69 74 testname "/" it
b260: 65 6d 2d 70 61 74 68 29 29 0a 09 20 20 20 20 20 em-path))..
b270: 20 28 70 72 65 76 2d 74 65 73 74 2d 64 61 74 20 (prev-test-dat
b280: 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f (hash-table-ref/
b290: 64 65 66 61 75 6c 74 20 63 75 72 72 2d 74 65 73 default curr-tes
b2a0: 74 73 2d 68 61 73 68 20 66 75 6c 6c 2d 6e 61 6d ts-hash full-nam
b2b0: 65 20 23 66 29 29 0a 09 20 20 20 20 20 20 28 74 e #f)).. (t
b2c0: 65 73 74 2d 73 74 65 70 73 20 20 20 20 20 20 28 est-steps (
b2d0: 6f 70 65 6e 2d 72 75 6e 2d 63 6c 6f 73 65 20 64 open-run-close d
b2e0: 62 3a 67 65 74 2d 73 74 65 70 73 2d 66 6f 72 2d b:get-steps-for-
b2f0: 74 65 73 74 20 64 62 20 28 64 62 3a 74 65 73 74 test db (db:test
b300: 2d 67 65 74 2d 69 64 20 74 65 73 74 64 61 74 29 -get-id testdat)
b310: 29 29 0a 09 20 20 20 20 20 20 28 6e 65 77 2d 74 )).. (new-t
b320: 65 73 74 2d 72 65 63 6f 72 64 20 23 66 29 29 0a est-record #f)).
b330: 09 20 3b 3b 20 72 65 70 6c 61 63 65 20 74 68 65 . ;; replace the
b340: 73 65 20 77 69 74 68 20 69 6e 73 65 72 74 20 2e se with insert .
b350: 2e 2e 20 73 65 6c 65 63 74 0a 09 20 28 61 70 70 .. select.. (app
b360: 6c 79 20 73 71 6c 69 74 65 33 3a 65 78 65 63 75 ly sqlite3:execu
b370: 74 65 20 0a 09 09 64 62 20 0a 09 09 28 63 6f 6e te ...db ...(con
b380: 63 20 22 49 4e 53 45 52 54 20 4f 52 20 52 45 50 c "INSERT OR REP
b390: 4c 41 43 45 20 49 4e 54 4f 20 74 65 73 74 73 20 LACE INTO tests
b3a0: 28 72 75 6e 5f 69 64 2c 74 65 73 74 6e 61 6d 65 (run_id,testname
b3b0: 2c 73 74 61 74 65 2c 73 74 61 74 75 73 2c 65 76 ,state,status,ev
b3c0: 65 6e 74 5f 74 69 6d 65 2c 68 6f 73 74 2c 63 70 ent_time,host,cp
b3d0: 75 6c 6f 61 64 2c 64 69 73 6b 66 72 65 65 2c 75 uload,diskfree,u
b3e0: 6e 61 6d 65 2c 72 75 6e 64 69 72 2c 69 74 65 6d name,rundir,item
b3f0: 5f 70 61 74 68 2c 72 75 6e 5f 64 75 72 61 74 69 _path,run_durati
b400: 6f 6e 2c 66 69 6e 61 6c 5f 6c 6f 67 66 2c 63 6f on,final_logf,co
b410: 6d 6d 65 6e 74 29 20 22 0a 09 09 20 20 20 20 20 mment) "...
b420: 20 22 56 41 4c 55 45 53 20 28 3f 2c 3f 2c 3f 2c "VALUES (?,?,?,
b430: 3f 2c 3f 2c 3f 2c 3f 2c 3f 2c 3f 2c 3f 2c 3f 2c ?,?,?,?,?,?,?,?,
b440: 3f 2c 3f 2c 3f 29 3b 22 29 0a 09 09 6e 65 77 2d ?,?,?);")...new-
b450: 72 75 6e 2d 69 64 20 28 63 64 64 72 20 28 76 65 run-id (cddr (ve
b460: 63 74 6f 72 2d 3e 6c 69 73 74 20 74 65 73 74 64 ctor->list testd
b470: 61 74 29 29 29 0a 09 20 28 73 65 74 21 20 6e 65 at))).. (set! ne
b480: 77 2d 74 65 73 74 64 61 74 20 28 63 61 72 20 28 w-testdat (car (
b490: 6f 70 65 6e 2d 72 75 6e 2d 63 6c 6f 73 65 20 64 open-run-close d
b4a0: 62 3a 67 65 74 2d 74 65 73 74 73 2d 66 6f 72 2d b:get-tests-for-
b4b0: 72 75 6e 20 64 62 20 6e 65 77 2d 72 75 6e 2d 69 run db new-run-i
b4c0: 64 20 74 65 73 74 6e 61 6d 65 20 69 74 65 6d 2d d testname item-
b4d0: 70 61 74 68 20 27 28 29 20 27 28 29 29 29 29 0a path '() '()))).
b4e0: 09 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 . (hash-table-se
b4f0: 74 21 20 63 75 72 72 2d 74 65 73 74 73 2d 68 61 t! curr-tests-ha
b500: 73 68 20 66 75 6c 6c 2d 6e 61 6d 65 20 6e 65 77 sh full-name new
b510: 2d 74 65 73 74 64 61 74 29 20 3b 3b 20 74 68 69 -testdat) ;; thi
b520: 73 20 63 6f 75 6c 64 20 62 65 20 63 6f 6e 66 75 s could be confu
b530: 73 69 6e 67 2c 20 77 68 69 63 68 20 72 65 63 6f sing, which reco
b540: 72 64 20 73 68 6f 75 6c 64 20 67 6f 20 69 6e 74 rd should go int
b550: 6f 20 74 68 65 20 6c 6f 6f 6b 75 70 20 74 61 62 o the lookup tab
b560: 6c 65 3f 0a 09 20 3b 3b 20 4e 6f 77 20 64 75 70 le?.. ;; Now dup
b570: 6c 69 63 61 74 65 20 74 68 65 20 74 65 73 74 20 licate the test
b580: 73 74 65 70 73 0a 09 20 28 64 65 62 75 67 3a 70 steps.. (debug:p
b590: 72 69 6e 74 20 34 20 22 43 6f 70 79 69 6e 67 20 rint 4 "Copying
b5a0: 72 65 63 6f 72 64 73 20 69 6e 20 74 65 73 74 5f records in test_
b5b0: 73 74 65 70 73 20 66 72 6f 6d 20 74 65 73 74 5f steps from test_
b5c0: 69 64 3d 22 20 28 64 62 3a 74 65 73 74 2d 67 65 id=" (db:test-ge
b5d0: 74 2d 69 64 20 74 65 73 74 64 61 74 29 20 22 20 t-id testdat) "
b5e0: 74 6f 20 22 20 28 64 62 3a 74 65 73 74 2d 67 65 to " (db:test-ge
b5f0: 74 2d 69 64 20 6e 65 77 2d 74 65 73 74 64 61 74 t-id new-testdat
b600: 29 29 0a 09 20 28 6f 70 65 6e 2d 72 75 6e 2d 63 )).. (open-run-c
b610: 6c 6f 73 65 20 0a 09 20 20 28 6c 61 6d 62 64 61 lose .. (lambda
b620: 20 28 29 0a 09 20 20 20 20 28 73 71 6c 69 74 65 ().. (sqlite
b630: 33 3a 65 78 65 63 75 74 65 20 0a 09 20 20 20 20 3:execute ..
b640: 20 64 62 20 0a 09 20 20 20 20 20 28 63 6f 6e 63 db .. (conc
b650: 20 22 49 4e 53 45 52 54 20 4f 52 20 52 45 50 4c "INSERT OR REPL
b660: 41 43 45 20 49 4e 54 4f 20 74 65 73 74 5f 73 74 ACE INTO test_st
b670: 65 70 73 20 28 74 65 73 74 5f 69 64 2c 73 74 65 eps (test_id,ste
b680: 70 6e 61 6d 65 2c 73 74 61 74 65 2c 73 74 61 74 pname,state,stat
b690: 75 73 2c 65 76 65 6e 74 5f 74 69 6d 65 2c 63 6f us,event_time,co
b6a0: 6d 6d 65 6e 74 29 20 22 0a 09 09 20 20 20 22 53 mment) "... "S
b6b0: 45 4c 45 43 54 20 22 20 28 64 62 3a 74 65 73 74 ELECT " (db:test
b6c0: 2d 67 65 74 2d 69 64 20 6e 65 77 2d 74 65 73 74 -get-id new-test
b6d0: 64 61 74 29 20 22 2c 73 74 65 70 6e 61 6d 65 2c dat) ",stepname,
b6e0: 73 74 61 74 65 2c 73 74 61 74 75 73 2c 65 76 65 state,status,eve
b6f0: 6e 74 5f 74 69 6d 65 2c 63 6f 6d 6d 65 6e 74 20 nt_time,comment
b700: 46 52 4f 4d 20 74 65 73 74 5f 73 74 65 70 73 20 FROM test_steps
b710: 57 48 45 52 45 20 74 65 73 74 5f 69 64 3d 3f 3b WHERE test_id=?;
b720: 22 29 0a 09 20 20 20 20 20 28 64 62 3a 74 65 73 ").. (db:tes
b730: 74 2d 67 65 74 2d 69 64 20 74 65 73 74 64 61 74 t-get-id testdat
b740: 29 29 0a 09 20 20 20 20 3b 3b 20 4e 6f 77 20 64 )).. ;; Now d
b750: 75 70 6c 69 63 61 74 65 20 74 68 65 20 74 65 73 uplicate the tes
b760: 74 20 64 61 74 61 0a 09 20 20 20 20 28 64 65 62 t data.. (deb
b770: 75 67 3a 70 72 69 6e 74 20 34 20 22 43 6f 70 79 ug:print 4 "Copy
b780: 69 6e 67 20 72 65 63 6f 72 64 73 20 69 6e 20 74 ing records in t
b790: 65 73 74 5f 64 61 74 61 20 66 72 6f 6d 20 74 65 est_data from te
b7a0: 73 74 5f 69 64 3d 22 20 28 64 62 3a 74 65 73 74 st_id=" (db:test
b7b0: 2d 67 65 74 2d 69 64 20 74 65 73 74 64 61 74 29 -get-id testdat)
b7c0: 20 22 20 74 6f 20 22 20 28 64 62 3a 74 65 73 74 " to " (db:test
b7d0: 2d 67 65 74 2d 69 64 20 6e 65 77 2d 74 65 73 74 -get-id new-test
b7e0: 64 61 74 29 29 0a 09 20 20 20 20 28 73 71 6c 69 dat)).. (sqli
b7f0: 74 65 33 3a 65 78 65 63 75 74 65 20 0a 09 20 20 te3:execute ..
b800: 20 20 20 64 62 20 0a 09 20 20 20 20 20 28 63 6f db .. (co
b810: 6e 63 20 22 49 4e 53 45 52 54 20 4f 52 20 52 45 nc "INSERT OR RE
b820: 50 4c 41 43 45 20 49 4e 54 4f 20 74 65 73 74 5f PLACE INTO test_
b830: 64 61 74 61 20 28 74 65 73 74 5f 69 64 2c 63 61 data (test_id,ca
b840: 74 65 67 6f 72 79 2c 76 61 72 69 61 62 6c 65 2c tegory,variable,
b850: 76 61 6c 75 65 2c 65 78 70 65 63 74 65 64 2c 74 value,expected,t
b860: 6f 6c 2c 75 6e 69 74 73 2c 63 6f 6d 6d 65 6e 74 ol,units,comment
b870: 29 20 22 0a 09 09 20 20 20 22 53 45 4c 45 43 54 ) "... "SELECT
b880: 20 22 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d " (db:test-get-
b890: 69 64 20 6e 65 77 2d 74 65 73 74 64 61 74 29 20 id new-testdat)
b8a0: 22 2c 63 61 74 65 67 6f 72 79 2c 76 61 72 69 61 ",category,varia
b8b0: 62 6c 65 2c 76 61 6c 75 65 2c 65 78 70 65 63 74 ble,value,expect
b8c0: 65 64 2c 74 6f 6c 2c 75 6e 69 74 73 2c 63 6f 6d ed,tol,units,com
b8d0: 6d 65 6e 74 20 46 52 4f 4d 20 74 65 73 74 5f 64 ment FROM test_d
b8e0: 61 74 61 20 57 48 45 52 45 20 74 65 73 74 5f 69 ata WHERE test_i
b8f0: 64 3d 3f 3b 22 29 0a 09 20 20 20 20 20 28 64 62 d=?;").. (db
b900: 3a 74 65 73 74 2d 67 65 74 2d 69 64 20 74 65 73 :test-get-id tes
b910: 74 64 61 74 29 29 29 29 0a 09 20 29 29 0a 20 20 tdat)))).. )).
b920: 20 20 20 70 72 65 76 2d 74 65 73 74 73 29 29 29 prev-tests)))
b930: 0a 09 20 0a 20 20 20 20 20 0a .. . .